Return to struct.fs CVS log

Up to [gforth] / gforth / compat

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

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.6       anton      26: : naligned ( addr1 n -- addr2 )
                     27:     \ addr2 is the aligned version of addr1 wrt the alignment size n
                     28:     1- tuck +  swap invert and ;
                     29: 
                     30: : nalign naligned ; \ old name, obsolete
1.1       anton      31: 
1.2       anton      32: : dofield ( -- )
                     33: does> ( name execution: addr1 -- addr2 )
                     34:     @ + ;
                     35: 
                     36: : dozerofield ( -- )
                     37:     immediate
                     38: does> ( name execution: -- )
                     39:     drop ;
                     40: 
1.3       anton      41: : create-field ( align1 offset1 align size "name" --  align2 offset2 )
1.5       anton      42:     create swap rot over nalign dup , ( align1 size align offset )
                     43:     rot + >r nalign r> ;
1.2       anton      44: 
1.3       anton      45: : field ( align1 offset1 align size "name" --  align2 offset2 )
1.2       anton      46:     \ name execution: addr1 -- addr2
1.3       anton      47:     2 pick >r \ this uglyness is just for optimizing with dozerofield
1.2       anton      48:     create-field
1.3       anton      49:     r> if \ offset<>0
1.2       anton      50:        dofield
                     51:     else
                     52:        dozerofield
                     53:     then ;
1.1       anton      54: 
1.3       anton      55: : end-struct ( align size "name" -- )
                     56:     over nalign \ pad size to full alignment
1.2       anton      57:     2constant ;
1.1       anton      58: 
1.3       anton      59: \ an empty struct
                     60: 1 chars 0 end-struct struct
1.1       anton      61: 
1.3       anton      62: \ type descriptors, all ( -- align size )
                     63: 1 aligned   1 cells   2constant cell%
                     64: 1 chars     1 chars   2constant char%
                     65: 1 faligned  1 floats  2constant float%
                     66: 1 dfaligned 1 dfloats 2constant dfloat%
                     67: 1 sfaligned 1 sfloats 2constant sfloat%
                     68: cell% 2*              2constant double%
                     69: 
                     70: \ memory allocation words
1.4       anton      71: : %alignment ( align size -- align )
                     72:     drop ;
                     73: 
                     74: : %size ( align size -- size )
                     75:     nip ;
                     76: 
1.3       anton      77: : %align ( align size -- )
                     78:     drop here swap nalign here - allot ;
1.1       anton      79: 
1.3       anton      80: : %allot ( align size -- addr )
                     81:     tuck %align
1.1       anton      82:     here swap allot ;
                     83: 
1.3       anton      84: : %allocate ( align size -- addr ior )
                     85:     nip allocate ;
1.2       anton      86: 
1.7     ! anton      87: : %alloc ( align size -- addr )
1.3       anton      88:     %allocate throw ;