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

   1 \ @(#) member.fth 98/01/26 1.2
   2 \ This files, along with c_struct.fth, supports the definition of
   3 \ structure members similar to those used in 'C'.
   4 \
   5 \ Some of this same code is also used by ODE,
   6 \ the Object Development Environment.
   7 \
   8 \ Author: Phil Burk
   9 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  10 \
  11 \ Permission to use, copy, modify, and/or distribute this
  12 \ software for any purpose with or without fee is hereby granted.
  13 \
  14 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  15 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  16 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  17 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  18 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  19 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  20 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  21 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  22 \
  23 \ MOD: PLB 1/16/87 Use abort" instead of er.report.
  24 \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.
  25 \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.
  26 \ MOD: PLB 7/31/88 Add USHORT and UBYTE.
  27 \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.
  28 \ MOD: RDG 9/19/90 Add floating point member support.
  29 \ MOD: PLB 6/10/91 Add RPTR
  30 \ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!
  31 \ 941102 RDG port to pforth
  32 \ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.
  33 \ 960710 PLB align long members for SUN
  34
  35 ANEW TASK-MEMBER.FTH
  36 decimal
  37
  38 : FIND.BODY   ( -- , pfa true | $name false , look for word in dict. )
  39 \ Return address of parameter data.
  40      bl word find
  41      IF  >body true
  42      ELSE false
  43      THEN
  44 ;
  45
  46 \ Variables shared with object oriented code.
  47 VARIABLE OB-STATE  ( Compilation state. )
  48 VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
  49 1 constant OB_DEF_CLASS   ( defining a class )
  50 2 constant OB_DEF_STRUCT  ( defining a structure )
  51
  52 \ A member contains:
  53 \   cell size of data in bytes (1, 2, cell)
  54 \   cell offset within structure
  55
  56 cell 1- constant CELL_MASK
  57 cell negate constant -CELL
  58 cell constant OB_OFFSET_SIZE
  59
  60 : OB.OFFSET@ ( member_def -- offset ) @ ;
  61 : OB.OFFSET, ( value -- ) , ;
  62 : OB.SIZE@ ( member_def -- offset )
  63         ob_offset_size + @ ;
  64 : OB.SIZE, ( value -- ) , ;
  65
  66 ( Members are associated with an offset from the base of a structure. )
  67 : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
  68     dup >r  ( -- +-b , save #bytes )
  69     ABS     ( -- |+-b| )
  70     ob-current-class @ ( -- b addr-space)
  71     tuck @          ( as #b c , current space needed )
  72     over CELL_MASK and 0=        ( multiple of cell? )
  73     IF
  74         aligned
  75     ELSE
  76         over 1 and 0=   ( multiple of two? )
  77         IF
  78             even-up
  79         THEN
  80     THEN
  81     swap over + rot !    ( update space needed )
  82 \ Save data in member definition. %M
  83     ob.offset,    ( save old offset for ivar )
  84     r> ob.size,   ( store size in bytes for ..! and ..@ )
  85 ;
  86
  87 \ Unions allow one to address the same memory as different members.
  88 \ Unions work by saving the current offset for members on
  89 \ the stack and then reusing it for different members.
  90 : UNION{  ( -- offset , Start union definition. )
  91     ob-current-class @ @
  92 ;
  93
  94 : }UNION{ ( old-offset -- new-offset , Middle of union )
  95     union{     ( Get current for }UNION to compare )
  96     swap ob-current-class @ !  ( Set back to old )
  97 ;
  98
  99 : }UNION ( offset -- , Terminate union definition, check lengths. )
 100     union{ = NOT
 101     abort" }UNION - Two parts of UNION are not the same size!"
 102 ;
 103
 104 \ Make members compile their offset, for "disposable includes".
 105 : OB.MEMBER  ( #bytes -- , make room in an object at compile time)
 106            ( -- offset , run time for structure )
 107     CREATE ob.make.member immediate
 108     DOES> ob.offset@  ( get offset ) ?literal
 109 ;
 110
 111 : OB.FINDIT  ( <thing> -- pfa , get pfa of thing or error )
 112     find.body not
 113     IF cr count type ."    ???"
 114        true abort" OB.FINDIT - Word not found!"
 115     THEN
 116 ;
 117
 118 : OB.STATS ( member_pfa --  offset #bytes )
 119     dup ob.offset@ swap
 120     ob.size@
 121 ;
 122
 123 : OB.STATS? ( <member> -- offset #bytes )
 124     ob.findit ob.stats
 125 ;
 126
 127 : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
 128     ob.findit @
 129     ?literal
 130 ; immediate
 131
 132 \ Basic word for defining structure members.
 133 : BYTES ( #bytes -- , error check for structure only )
 134     ob-state @ ob_def_struct = not
 135     abort" BYTES - Only valid in :STRUCT definitions."
 136     ob.member
 137 ;
 138
 139 \ Declare various types of structure members.
 140 \ Negative size indicates a signed member.
 141 : BYTE ( <name> -- , declare space for a byte )
 142     -1 bytes ;
 143
 144 : SHORT ( <name> -- , declare space for a 16 bit value )
 145     -2 bytes ;
 146
 147 : LONG ( <name> -- )
 148     cell bytes ;
 149
 150 : UBYTE ( <name> -- , declare space for signed  byte )
 151     1 bytes ;
 152
 153 : USHORT ( <name> -- , declare space for signed 16 bit value )
 154     2 bytes ;
 155
 156
 157 \ Aliases
 158 : APTR    ( <name> -- ) long ;
 159 : RPTR    ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001
 160 : ULONG   ( <name> -- ) long ;
 161
 162 : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
 163     [compile] sizeof() bytes
 164 ;