Return to struct.fs CVS log

Up to [gforth] / gforth / compat

renamed nalign into naligned (nalign is present but obsolete)
Implemented a new solution for nested hold areas (<<# ... #> ... #>>)
minor changes

    1: \ data structures (like C structs)
    2: 
    3: \ This file is in the public domain. NO WARRANTY.
    4: 
    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 
   25: 
   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
   31: 
   32: : dofield ( -- )
   33: does> ( name execution: addr1 -- addr2 )
   34:     @ + ;
   35: 
   36: : dozerofield ( -- )
   37:     immediate
   38: does> ( name execution: -- )
   39:     drop ;
   40: 
   41: : create-field ( align1 offset1 align size "name" --  align2 offset2 )
   42:     create swap rot over nalign dup , ( align1 size align offset )
   43:     rot + >r nalign r> ;
   44: 
   45: : field ( align1 offset1 align size "name" --  align2 offset2 )
   46:     \ name execution: addr1 -- addr2
   47:     2 pick >r \ this uglyness is just for optimizing with dozerofield
   48:     create-field
   49:     r> if \ offset<>0
   50: 	dofield
   51:     else
   52: 	dozerofield
   53:     then ;
   54: 
   55: : end-struct ( align size "name" -- )
   56:     over nalign \ pad size to full alignment
   57:     2constant ;
   58: 
   59: \ an empty struct
   60: 1 chars 0 end-struct struct
   61: 
   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
   71: : %alignment ( align size -- align )
   72:     drop ;
   73: 
   74: : %size ( align size -- size )
   75:     nip ;
   76: 
   77: : %align ( align size -- )
   78:     drop here swap nalign here - allot ;
   79: 
   80: : %allot ( align size -- addr )
   81:     tuck %align
   82:     here swap allot ;
   83: 
   84: : %allocate ( align size -- addr ior )
   85:     nip allocate ;
   86: 
   87: : %alloc ( size align -- addr )
   88:     %allocate throw ;