[pforth] / fth / c_struct.fth

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