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

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