-\ @(#) 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
+\ @(#) 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, David Rosenboom
+\
+\ Permission to use, copy, modify, and/or distribute this
+\ software for any purpose with or without fee is hereby granted.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+\
+\ 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
+ -cell 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
+ -cell 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
+ -cell 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
+ -cell 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
+ short map_s1
+ ushort map_s2
+ byte map_b1
+ ubyte map_b2
+ aptr map_a1
+ rptr map_r1
+ flpt map_f1
+;struct
+mapper map1
+
+." compiling TT" cr
+: TT
+ 123456 map1 s! map_l1
+ map1 s@ map_l1 123456 - abort" map_l1 failed!"
+ 987654 map1 s! map_l2
+ map1 s@ map_l2 987654 - abort" map_l2 failed!"
+
+ -500 map1 s! map_s1
+ map1 s@ map_s1 dup . cr -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]
projects / pforth / blobdiff