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