[pforth] / fth / c_struct.fth

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