Annotation of gforth/compat/struct.fs, revision 1.5

1.1       anton       1: \ data structures (like C structs)
                      2: 
1.3       anton       3: \ This file is in the public domain. NO WARRANTY.
1.1       anton       4: 
1.3       anton       5: \ This program uses the following words
                      6: \ from CORE :
                      7: \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
                      8: \ r> IF ELSE THEN over chars aligned cells 2* here - allot
                      9: \ from CORE-EXT :
                     10: \ tuck pick nip 
                     11: \ from BLOCK-EXT :
                     12: \ \ 
                     13: \ from DOUBLE :
                     14: \ 2Constant 
                     15: \ from EXCEPTION :
                     16: \ throw 
                     17: \ from FILE :
                     18: \ ( 
                     19: \ from FLOAT :
                     20: \ faligned floats 
                     21: \ from FLOAT-EXT :
                     22: \ dfaligned dfloats sfaligned sfloats 
                     23: \ from MEMORY :
                     24: \ allocate 
1.2       anton      25: 
1.1       anton      26: : nalign ( addr1 n -- addr2 )
                     27: \ addr2 is the aligned version of addr1 wrt the alignment size n
                     28:  1- tuck +  swap invert and ;
                     29: 
1.2       anton      30: : dofield ( -- )
                     31: does> ( name execution: addr1 -- addr2 )
                     32:     @ + ;
                     33: 
                     34: : dozerofield ( -- )
                     35:     immediate
                     36: does> ( name execution: -- )
                     37:     drop ;
                     38: 
1.3       anton      39: : create-field ( align1 offset1 align size "name" --  align2 offset2 )
1.5     ! anton      40:     create swap rot over nalign dup , ( align1 size align offset )
        !            41:     rot + >r nalign r> ;
1.2       anton      42: 
1.3       anton      43: : field ( align1 offset1 align size "name" --  align2 offset2 )
1.2       anton      44:     \ name execution: addr1 -- addr2
1.3       anton      45:     2 pick >r \ this uglyness is just for optimizing with dozerofield
1.2       anton      46:     create-field
1.3       anton      47:     r> if \ offset<>0
1.2       anton      48:        dofield
                     49:     else
                     50:        dozerofield
                     51:     then ;
1.1       anton      52: 
1.3       anton      53: : end-struct ( align size "name" -- )
                     54:     over nalign \ pad size to full alignment
1.2       anton      55:     2constant ;
1.1       anton      56: 
1.3       anton      57: \ an empty struct
                     58: 1 chars 0 end-struct struct
1.1       anton      59: 
1.3       anton      60: \ type descriptors, all ( -- align size )
                     61: 1 aligned   1 cells   2constant cell%
                     62: 1 chars     1 chars   2constant char%
                     63: 1 faligned  1 floats  2constant float%
                     64: 1 dfaligned 1 dfloats 2constant dfloat%
                     65: 1 sfaligned 1 sfloats 2constant sfloat%
                     66: cell% 2*              2constant double%
                     67: 
                     68: \ memory allocation words
1.4       anton      69: : %alignment ( align size -- align )
                     70:     drop ;
                     71: 
                     72: : %size ( align size -- size )
                     73:     nip ;
                     74: 
1.3       anton      75: : %align ( align size -- )
                     76:     drop here swap nalign here - allot ;
1.1       anton      77: 
1.3       anton      78: : %allot ( align size -- addr )
                     79:     tuck %align
1.1       anton      80:     here swap allot ;
                     81: 
1.3       anton      82: : %allocate ( align size -- addr ior )
                     83:     nip allocate ;
1.2       anton      84: 
1.3       anton      85: : %alloc ( size align -- addr )
                     86:     %allocate throw ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>