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 ( align size -- addr )
88: %allocate throw ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>