\ @(#) 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> -- 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;structmapper 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" crTT[THEN]