\ @(#) 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.
\ 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.
\ STRUCT ======================================================
: <:STRUCT> ( pfa -- , run time action for a structure)
@ even-up here swap dup ( -- here # # )
allot ( make room for ivars )
0 fill ( initialize to zero )
\ 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 )
warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"
ob_def_struct ob-state ! ( set pair flags )
\ Create new struct defining word.
here ob-current-class ! ( set current )
0 , ( initial ivar offset )
0 , ( location for #byte to last )
: ;STRUCT ( -- , terminate structure )
ob-state @ ob_def_struct = NOT
abort" ;STRUCT - Missing :STRUCT above!"
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 )
IF [compile] literal compile +
: (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
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!"
: !BYTES ( value address size -- )
-cell OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002
true abort" s! - illegal size!"
\ These provide ways of setting and reading members values
\ without knowing their size in bytes.
: (S!) ( offset size -- , compile proper fetch )
ELSE ( -- value addr off size )
: S! ( value object <member> -- , store value in member )
: @BYTES ( addr +/-size -- value )
-cell OF @ if.rel->use ENDOF \ 00002
true abort" s@ - illegal size!"
: (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
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!"
: (S@) ( offset size -- , compile proper fetch )
: S@ ( object <member> -- value , fetch value from member )
\ 951112 Floating Point support
: FLPT ( <name> -- , declare space for a floating point value. )
: (S+F!) ( val addr offset -- ) + f! ;
: (S+F@) ( addr offset -- val ) + f@ ;
: FS! ( value object <member> -- , fetch value from member )
1 floats <> abort" FS@ with non-float!"
: FS@ ( object <member> -- value , fetch value from member )
1 floats <> abort" FS@ with non-float!"
map1 s@ map_l1 123456 - abort" map_l1 failed!"
map1 s@ map_l2 987654 - abort" map_l2 failed!"
map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!"
map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
map1 s@ map_b1 -89 - abort" map_s1 failed!"
map1 s@ map_r1 here - abort" map_r1 failed!"
map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
map1 fs@ map_f1 f. ." =?= 23.45" cr
." Testing c_struct.fth" cr
projects / pforth / blob