File:  [gforth] / gforth / compat / struct.fs
Revision 1.5: download - view: text, annotated - select for diffs
Tue Apr 14 16:43:21 1998 UTC (23 years, 7 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
emacs update bug fix in gforth.el
bug fix in struct.fs, compat/struct.fs
main.c: stdout is now unbuffered, if it is a tty

    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: : nalign ( addr1 n -- addr2 )
   27: \ addr2 is the aligned version of addr1 wrt the alignment size n
   28:  1- tuck +  swap invert and ;
   29: 
   30: : dofield ( -- )
   31: does> ( name execution: addr1 -- addr2 )
   32:     @ + ;
   33: 
   34: : dozerofield ( -- )
   35:     immediate
   36: does> ( name execution: -- )
   37:     drop ;
   38: 
   39: : create-field ( align1 offset1 align size "name" --  align2 offset2 )
   40:     create swap rot over nalign dup , ( align1 size align offset )
   41:     rot + >r nalign r> ;
   42: 
   43: : field ( align1 offset1 align size "name" --  align2 offset2 )
   44:     \ name execution: addr1 -- addr2
   45:     2 pick >r \ this uglyness is just for optimizing with dozerofield
   46:     create-field
   47:     r> if \ offset<>0
   48: 	dofield
   49:     else
   50: 	dozerofield
   51:     then ;
   52: 
   53: : end-struct ( align size "name" -- )
   54:     over nalign \ pad size to full alignment
   55:     2constant ;
   56: 
   57: \ an empty struct
   58: 1 chars 0 end-struct struct
   59: 
   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: : %alignment ( align size -- align )
   70:     drop ;
   71: 
   72: : %size ( align size -- size )
   73:     nip ;
   74: 
   75: : %align ( align size -- )
   76:     drop here swap nalign here - allot ;
   77: 
   78: : %allot ( align size -- addr )
   79:     tuck %align
   80:     here swap allot ;
   81: 
   82: : %allocate ( align size -- addr ior )
   83:     nip allocate ;
   84: 
   85: : %alloc ( size align -- addr )
   86:     %allocate throw ;

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