bb6b2dcd |
1 | \ @(#) member.fth 98/01/26 1.2\r |
2 | \ This files, along with c_struct.fth, supports the definition of\r |
3 | \ structure members similar to those used in 'C'.\r |
4 | \\r |
5 | \ Some of this same code is also used by ODE,\r |
6 | \ the Object Development Environment.\r |
7 | \\r |
8 | \ Author: Phil Burk\r |
9 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r |
10 | \\r |
11 | \ The pForth software code is dedicated to the public domain,\r |
12 | \ and any third party may reproduce, distribute and modify\r |
13 | \ the pForth software code or any derivative works thereof\r |
14 | \ without any compensation or license. The pForth software\r |
15 | \ code is provided on an "as is" basis without any warranty\r |
16 | \ of any kind, including, without limitation, the implied\r |
17 | \ warranties of merchantability and fitness for a particular\r |
18 | \ purpose and their equivalents under the laws of any jurisdiction.\r |
19 | \\r |
20 | \ MOD: PLB 1/16/87 Use abort" instead of er.report.\r |
21 | \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.\r |
22 | \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.\r |
23 | \ MOD: PLB 7/31/88 Add USHORT and UBYTE.\r |
24 | \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.\r |
25 | \ MOD: RDG 9/19/90 Add floating point member support.\r |
26 | \ MOD: PLB 6/10/91 Add RPTR\r |
27 | \ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!\r |
28 | \ 941102 RDG port to pforth\r |
29 | \ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.\r |
30 | \ 960710 PLB align long members for SUN\r |
31 | \r |
32 | ANEW TASK-MEMBER.FTH\r |
33 | decimal\r |
34 | \r |
35 | : FIND.BODY ( -- , pfa true | $name false , look for word in dict. )\r |
36 | \ Return address of parameter data.\r |
c1b0551d |
37 | bl word find\r |
bb6b2dcd |
38 | IF >body true\r |
39 | ELSE false\r |
40 | THEN\r |
41 | ;\r |
42 | \r |
43 | \ Variables shared with object oriented code.\r |
44 | VARIABLE OB-STATE ( Compilation state. )\r |
45 | VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class )\r |
46 | 1 constant OB_DEF_CLASS ( defining a class )\r |
47 | 2 constant OB_DEF_STRUCT ( defining a structure )\r |
48 | \r |
49 | 4 constant OB_OFFSET_SIZE\r |
50 | \r |
51 | : OB.OFFSET@ ( member_def -- offset ) @ ;\r |
52 | : OB.OFFSET, ( value -- ) , ;\r |
53 | : OB.SIZE@ ( member_def -- offset )\r |
54 | ob_offset_size + @ ;\r |
55 | : OB.SIZE, ( value -- ) , ;\r |
56 | \r |
57 | ( Members are associated with an offset from the base of a structure. )\r |
58 | : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)\r |
59 | dup >r ( -- +-b , save #bytes )\r |
60 | ABS ( -- |+-b| )\r |
61 | ob-current-class @ ( -- b addr-space)\r |
62 | tuck @ ( as #b c , current space needed )\r |
63 | over 3 and 0= ( multiple of four? )\r |
64 | IF\r |
65 | aligned\r |
66 | ELSE\r |
67 | over 1 and 0= ( multiple of two? )\r |
68 | IF\r |
69 | even-up\r |
70 | THEN\r |
71 | THEN\r |
72 | swap over + rot ! ( update space needed )\r |
73 | \ Save data in member definition. %M\r |
74 | ob.offset, ( save old offset for ivar )\r |
75 | r> ob.size, ( store size in bytes for ..! and ..@ )\r |
76 | ;\r |
77 | \r |
78 | \ Unions allow one to address the same memory as different members.\r |
79 | \ Unions work by saving the current offset for members on\r |
80 | \ the stack and then reusing it for different members.\r |
81 | : UNION{ ( -- offset , Start union definition. )\r |
82 | ob-current-class @ @\r |
83 | ;\r |
84 | \r |
85 | : }UNION{ ( old-offset -- new-offset , Middle of union )\r |
86 | union{ ( Get current for }UNION to compare )\r |
87 | swap ob-current-class @ ! ( Set back to old )\r |
88 | ;\r |
89 | \r |
90 | : }UNION ( offset -- , Terminate union definition, check lengths. )\r |
91 | union{ = NOT\r |
92 | abort" }UNION - Two parts of UNION are not the same size!"\r |
93 | ;\r |
94 | \r |
95 | \ Make members compile their offset, for "disposable includes".\r |
96 | : OB.MEMBER ( #bytes -- , make room in an object at compile time)\r |
97 | ( -- offset , run time for structure )\r |
98 | CREATE ob.make.member immediate\r |
99 | DOES> ob.offset@ ( get offset ) ?literal\r |
100 | ;\r |
101 | \r |
102 | : OB.FINDIT ( <thing> -- pfa , get pfa of thing or error )\r |
103 | find.body not\r |
104 | IF cr count type ." ???"\r |
105 | true abort" OB.FINDIT - Word not found!"\r |
106 | THEN\r |
107 | ;\r |
108 | \r |
109 | : OB.STATS ( member_pfa -- offset #bytes )\r |
110 | dup ob.offset@ swap\r |
111 | ob.size@\r |
112 | ;\r |
113 | \r |
114 | : OB.STATS? ( <member> -- offset #bytes )\r |
115 | ob.findit ob.stats\r |
116 | ;\r |
117 | \r |
118 | : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )\r |
119 | ob.findit @\r |
120 | ?literal\r |
121 | ; immediate\r |
122 | \r |
123 | \ Basic word for defining structure members.\r |
124 | : BYTES ( #bytes -- , error check for structure only )\r |
125 | ob-state @ ob_def_struct = not\r |
126 | abort" BYTES - Only valid in :STRUCT definitions."\r |
127 | ob.member\r |
128 | ;\r |
129 | \r |
130 | \ Declare various types of structure members.\r |
131 | \ Negative size indicates a signed member.\r |
132 | : BYTE ( <name> -- , declare space for a byte )\r |
133 | -1 bytes ;\r |
134 | \r |
135 | : SHORT ( <name> -- , declare space for a 16 bit value )\r |
136 | -2 bytes ;\r |
137 | \r |
138 | : LONG ( <name> -- )\r |
139 | cell bytes ;\r |
140 | \r |
141 | : UBYTE ( <name> -- , declare space for signed byte )\r |
142 | 1 bytes ;\r |
143 | \r |
144 | : USHORT ( <name> -- , declare space for signed 16 bit value )\r |
145 | 2 bytes ;\r |
146 | \r |
147 | \r |
148 | \ Aliases\r |
149 | : APTR ( <name> -- ) long ;\r |
150 | : RPTR ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001\r |
151 | : ULONG ( <name> -- ) long ;\r |
152 | \r |
153 | : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )\r |
154 | [compile] sizeof() bytes\r |
155 | ;\r |