[pforth] / fth / c_struct.fth

\ @(#) c_struct.fth 98/01/26 1.2
\ STRUCTUREs are for interfacing with 'C' programs.
\ Structures are created using :STRUCT and ;STRUCT
\
\ This file must be loaded before loading any .J files.
\
\ 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
\      MDH 4/14/87 Added sign-extend words to ..@
\ MOD: PLB 9/1/87 Add pointer to last member for debug.
\ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..!
\ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long
\        fixed OB.COMPILE.+@/! for 0 offset
\ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE
\ MOD: RDG 9/19/90 Added floating point member support
\ MOD: PLB 12/21/90 Optimized ..@ and ..!
\ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed
\           Don't need MOVEQ.L  #0,D0 for 16@+WORD and 8@+WORD
\ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR
\ 951112 PLB Added FS@ and FS!
\ This version for the pForth system.

ANEW TASK-C_STRUCT

decimal
\ STRUCT ======================================================
: <:STRUCT> ( pfa -- , run time action for a structure)
    [COMPILE] CREATE
        @ even-up here swap dup ( -- here # # )
        allot  ( make room for ivars )
        0 fill  ( initialize to zero )
\       immediate \ 00001
\   DOES> [compile] aliteral \ 00001
;

\ Contents of a structure definition.
\    CELL 0 = size of instantiated structures
\    CELL 1 = #bytes to last member name in dictionary.
\             this is relative so it will work with structure
\             relocation schemes like MODULE

: :STRUCT (  -- , Create a 'C' structure )
\ Check pairs
   ob-state @
   warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"
   ob_def_struct ob-state !     ( set pair flags )
\
\ Create new struct defining word.
  CREATE
      here ob-current-class !  ( set current )
      0 ,        ( initial ivar offset )
      0 ,        ( location for #byte to last )
   DOES>  <:STRUCT>
;

: ;STRUCT ( -- , terminate structure )
   ob-state @ ob_def_struct = NOT
   abort" ;STRUCT - Missing :STRUCT above!"
   false ob-state !

\ Point to last member.
   latest ob-current-class @ body> >name -  ( byte difference of NFAs )
   ob-current-class @ cell+ !
\
\ Even up byte offset in case last member was BYTE.
   ob-current-class @ dup @ even-up swap !
;

\ Member reference words.
: ..   ( object <member> -- member_address , calc addr of member )
    ob.stats? drop state @
    IF   ?dup
         IF   [compile] literal compile +
         THEN
    ELSE +
    THEN
; immediate


: (S+C!)  ( val addr offset -- )  + c! ;
: (S+W!)  ( val addr  offset -- )  + w! ;
: (S+!)  ( val addr offset -- )  + ! ;
: (S+REL!)  ( ptr addr offset -- )  + >r if.use->rel r> ! ;

: compile+!bytes ( offset size -- )
\   ." compile+!bytes ( " over . dup . ." )" cr
    swap [compile] literal   \ compile offset into word
    CASE
    cell OF compile (s+!)  ENDOF
    2 OF compile (s+w!)      ENDOF
    1 OF compile (s+c!)      ENDOF
    -4 OF compile (s+rel!)   ENDOF \ 00002
    -2 OF compile (s+w!)     ENDOF
    -1 OF compile (s+c!)     ENDOF
    true abort" s! - illegal size!"
    ENDCASE
;

: !BYTES ( value address size -- )
    CASE
    cell OF ! ENDOF
    -4 OF ( aptr addr )  swap if.use->rel swap ! ENDOF \ 00002
    ABS
       2 OF w! ENDOF
       1 OF c! ENDOF
       true abort" s! - illegal size!"
    ENDCASE
;

\ These provide ways of setting and reading members values
\ without knowing their size in bytes.
: (S!) ( offset size -- , compile proper fetch )
    state @
    IF  compile+!bytes
    ELSE ( -- value addr off size )
        >r + r> !bytes
    THEN
;
: S! ( value object <member> -- , store value in member )
    ob.stats?
    (s!)
; immediate

: @BYTES ( addr +/-size -- value )
    CASE
    cell OF @  ENDOF
       2 OF w@      ENDOF
       1 OF c@      ENDOF
      -4 OF @ if.rel->use      ENDOF \ 00002
      -2 OF w@ w->s     ENDOF
      -1 OF c@ b->s     ENDOF
       true abort" s@ - illegal size!"
    ENDCASE
;

: (S+UC@)  ( addr offset -- val )  + c@ ;
: (S+UW@)  ( addr offset -- val )  + w@ ;
: (S+@)  ( addr offset -- val )  + @ ;
: (S+REL@)  ( addr offset -- val )  + @ if.rel->use ;
: (S+C@)  ( addr offset -- val )  + c@ b->s ;
: (S+W@)  ( addr offset -- val )  + w@ w->s ;

: compile+@bytes ( offset size -- )
\   ." compile+@bytes ( " over . dup . ." )" cr
    swap [compile] literal   \ compile offset into word
    CASE
    cell OF compile (s+@)  ENDOF
    2 OF compile (s+uw@)      ENDOF
    1 OF compile (s+uc@)      ENDOF
    -4 OF compile (s+rel@)      ENDOF \ 00002
    -2 OF compile (s+w@)     ENDOF
    -1 OF compile (s+c@)     ENDOF
    true abort" s@ - illegal size!"
    ENDCASE
;

: (S@) ( offset size -- , compile proper fetch )
    state @
    IF compile+@bytes
    ELSE >r + r> @bytes
    THEN
;

: S@ ( object <member> -- value , fetch value from member )
    ob.stats?
    (s@)
; immediate


exists? F* [IF]
\ 951112 Floating Point support
: FLPT  ( <name> -- , declare space for a floating point value. )
     1 floats bytes
;
: (S+F!)  ( val addr offset -- )  + f! ;
: (S+F@)  ( addr offset -- val )  + f@ ;

: FS! ( value object <member> -- , fetch value from member )
    ob.stats?
    1 floats <> abort" FS@ with non-float!"
    state @
    IF
        [compile] literal
        compile (s+f!)
    ELSE (s+f!)
    THEN
; immediate
: FS@ ( object <member> -- value , fetch value from member )
    ob.stats?
    1 floats <> abort" FS@ with non-float!"
    state @
    IF
        [compile] literal
        compile (s+f@)
    ELSE (s+f@)
    THEN
; immediate
[THEN]

0 [IF]
:struct mapper
    long map_l1
    long map_l2
    aptr map_a1
    rptr map_r1
    flpt map_f1
    short map_s1
    ushort map_s2
    byte map_b1
    ubyte map_b2
;struct
mapper map1

: TT
    -500 map1 s! map_s1
    map1 s@ map_s1 -500 - abort" map_s1 failed!"
    -500 map1 s! map_s2
    map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
    -89 map1 s! map_b1
    map1 s@ map_b1 -89 - abort" map_s1 failed!"
    here map1 s! map_r1
    map1 s@ map_r1 here - abort" map_r1 failed!"
    -89 map1 s! map_b2
    map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
    23.45 map1 fs! map_f1
    map1 fs@ map_f1 f. ." =?= 23.45" cr
;
." Testing c_struct.fth" cr
TT
[THEN]
Commit	Line	Data
8e9db35f PB	1	\ @(#) c_struct.fth 98/01/26 1.2
	2	\ STRUCTUREs are for interfacing with 'C' programs.
	3	\ Structures are created using :STRUCT and ;STRUCT
	4	\
	5	\ This file must be loaded before loading any .J files.
	6	\
	7	\ Author: Phil Burk
	8	\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
	9	\
	10	\ The pForth software code is dedicated to the public domain,
	11	\ and any third party may reproduce, distribute and modify
	12	\ the pForth software code or any derivative works thereof
	13	\ without any compensation or license. The pForth software
	14	\ code is provided on an "as is" basis without any warranty
	15	\ of any kind, including, without limitation, the implied
	16	\ warranties of merchantability and fitness for a particular
	17	\ purpose and their equivalents under the laws of any jurisdiction.
	18	\
	19	\ MOD: PLB 1/16/87 Use abort" instead of er.report
	20	\ MDH 4/14/87 Added sign-extend words to ..@
	21	\ MOD: PLB 9/1/87 Add pointer to last member for debug.
	22	\ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..!
	23	\ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long
	24	\ fixed OB.COMPILE.+@/! for 0 offset
	25	\ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE
	26	\ MOD: RDG 9/19/90 Added floating point member support
	27	\ MOD: PLB 12/21/90 Optimized ..@ and ..!
	28	\ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed
	29	\ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD
	30	\ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR
	31	\ 951112 PLB Added FS@ and FS!
	32	\ This version for the pForth system.
	33
	34	ANEW TASK-C_STRUCT
	35
	36	decimal
	37	\ STRUCT ======================================================
	38	: <:STRUCT> ( pfa -- , run time action for a structure)
	39	[COMPILE] CREATE
	40	@ even-up here swap dup ( -- here # # )
	41	allot ( make room for ivars )
	42	0 fill ( initialize to zero )
	43	\ immediate \ 00001
	44	\ DOES> [compile] aliteral \ 00001
	45	;
	46
	47	\ Contents of a structure definition.
	48	\ CELL 0 = size of instantiated structures
	49	\ CELL 1 = #bytes to last member name in dictionary.
	50	\ this is relative so it will work with structure
	51	\ relocation schemes like MODULE
	52
	53	: :STRUCT ( -- , Create a 'C' structure )
	54	\ Check pairs
	55	ob-state @
	56	warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"
	57	ob_def_struct ob-state ! ( set pair flags )
	58	\
	59	\ Create new struct defining word.
	60	CREATE
	61	here ob-current-class ! ( set current )
	62	0 , ( initial ivar offset )
	63	0 , ( location for #byte to last )
	64	DOES> <:STRUCT>
65	;
66
67	: ;STRUCT ( -- , terminate structure )
68	ob-state @ ob_def_struct = NOT
69	abort" ;STRUCT - Missing :STRUCT above!"
70	false ob-state !
71
72	\ Point to last member.
73	latest ob-current-class @ body> >name - ( byte difference of NFAs )
74	ob-current-class @ cell+ !
75	\
76	\ Even up byte offset in case last member was BYTE.
77	ob-current-class @ dup @ even-up swap !
78	;
79
80	\ Member reference words.
81	: .. ( object <member> -- member_address , calc addr of member )
82	ob.stats? drop state @
83	IF ?dup
84	IF [compile] literal compile +
85	THEN
86	ELSE +
87	THEN
88	; immediate
89
90
91	: (S+C!) ( val addr offset -- ) + c! ;
92	: (S+W!) ( val addr offset -- ) + w! ;
93	: (S+!) ( val addr offset -- ) + ! ;
94	: (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ;
95
96	: compile+!bytes ( offset size -- )
97	\ ." compile+!bytes ( " over . dup . ." )" cr
98	swap [compile] literal \ compile offset into word
99	CASE
100	cell OF compile (s+!) ENDOF
101	2 OF compile (s+w!) ENDOF
102	1 OF compile (s+c!) ENDOF
103	-4 OF compile (s+rel!) ENDOF \ 00002
104	-2 OF compile (s+w!) ENDOF
105	-1 OF compile (s+c!) ENDOF
106	true abort" s! - illegal size!"
107	ENDCASE
108	;
109
110	: !BYTES ( value address size -- )
111	CASE
112	cell OF ! ENDOF
113	-4 OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002
114	ABS
115	2 OF w! ENDOF
116	1 OF c! ENDOF
117	true abort" s! - illegal size!"
118	ENDCASE
119	;
120
121	\ These provide ways of setting and reading members values
122	\ without knowing their size in bytes.
123	: (S!) ( offset size -- , compile proper fetch )
124	state @
125	IF compile+!bytes
126	ELSE ( -- value addr off size )
127	>r + r> !bytes
128	THEN
129	;
130	: S! ( value object <member> -- , store value in member )
131	ob.stats?
132	(s!)
133	; immediate
134
135	: @BYTES ( addr +/-size -- value )
136	CASE
137	cell OF @ ENDOF
138	2 OF w@ ENDOF
139	1 OF c@ ENDOF
140	-4 OF @ if.rel->use ENDOF \ 00002
141	-2 OF w@ w->s ENDOF
142	-1 OF c@ b->s ENDOF
143	true abort" s@ - illegal size!"
144	ENDCASE
145	;
146
147	: (S+UC@) ( addr offset -- val ) + c@ ;
148	: (S+UW@) ( addr offset -- val ) + w@ ;
149	: (S+@) ( addr offset -- val ) + @ ;
150	: (S+REL@) ( addr offset -- val ) + @ if.rel->use ;
151	: (S+C@) ( addr offset -- val ) + c@ b->s ;
152	: (S+W@) ( addr offset -- val ) + w@ w->s ;
153
154	: compile+@bytes ( offset size -- )
155	\ ." compile+@bytes ( " over . dup . ." )" cr
156	swap [compile] literal \ compile offset into word
157	CASE
158	cell OF compile (s+@) ENDOF
159	2 OF compile (s+uw@) ENDOF
160	1 OF compile (s+uc@) ENDOF
161	-4 OF compile (s+rel@) ENDOF \ 00002
162	-2 OF compile (s+w@) ENDOF
163	-1 OF compile (s+c@) ENDOF
164	true abort" s@ - illegal size!"
165	ENDCASE
166	;
167
168	: (S@) ( offset size -- , compile proper fetch )
169	state @
170	IF compile+@bytes
171	ELSE >r + r> @bytes
172	THEN
173	;
174
175	: S@ ( object <member> -- value , fetch value from member )
176	ob.stats?
177	(s@)
178	; immediate
179
180
181
182	exists? F* [IF]
183	\ 951112 Floating Point support
184	: FLPT ( <name> -- , declare space for a floating point value. )
185	1 floats bytes
186	;
187	: (S+F!) ( val addr offset -- ) + f! ;
188	: (S+F@) ( addr offset -- val ) + f@ ;
189
190	: FS! ( value object <member> -- , fetch value from member )
191	ob.stats?
192	1 floats <> abort" FS@ with non-float!"
193	state @
194	IF
195	[compile] literal
196	compile (s+f!)
197	ELSE (s+f!)
198	THEN
199	; immediate
200	: FS@ ( object <member> -- value , fetch value from member )
201	ob.stats?
202	1 floats <> abort" FS@ with non-float!"
203	state @
204	IF
205	[compile] literal
206	compile (s+f@)
207	ELSE (s+f@)
208	THEN
209	; immediate
210	[THEN]
211
212	0 [IF]
213	:struct mapper
214	long map_l1
215	long map_l2
216	aptr map_a1
217	rptr map_r1
218	flpt map_f1
219	short map_s1
220	ushort map_s2
221	byte map_b1
222	ubyte map_b2
223	;struct
224	mapper map1
225
226	: TT
227	-500 map1 s! map_s1
228	map1 s@ map_s1 -500 - abort" map_s1 failed!"
229	-500 map1 s! map_s2
230	map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
231	-89 map1 s! map_b1
232	map1 s@ map_b1 -89 - abort" map_s1 failed!"
233	here map1 s! map_r1
234	map1 s@ map_r1 here - abort" map_r1 failed!"
235	-89 map1 s! map_b2
236	map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
237	23.45 map1 fs! map_f1
238	map1 fs@ map_f1 f. ." =?= 23.45" cr
239	;
240	." Testing c_struct.fth" cr
241	TT
242	[THEN]