Return to struct.fs CVS log

Up to [gforth] / gforth / compat

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

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 )
        !            40:     create rot dup , ( align1 align size offset1 )
        !            41:     + >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
        !            69: : %align ( align size -- )
        !            70:     drop here swap nalign here - allot ;
1.1       anton      71: 
1.3     ! anton      72: : %allot ( align size -- addr )
        !            73:     tuck %align
1.1       anton      74:     here swap allot ;
                     75: 
1.3     ! anton      76: : %allocate ( align size -- addr ior )
        !            77:     nip allocate ;
1.2       anton      78: 
1.3     ! anton      79: : %alloc ( size align -- addr )
        !            80:     %allocate throw ;