git.gag.com Git - debian/pforth/blob - fth/c_struct.fth

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