\ @(#) 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 \ \ 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_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 -- , 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 -- value , fetch value from member ) ob.stats? (s@) ; immediate exists? F* [IF] \ 951112 Floating Point support : FLPT ( -- , 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 -- , 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 -- 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]