/fth/member.fth

https://github.com/philburk/pforth · Forth · 164 lines · 138 code · 24 blank · 2 comment · 7 complexity · de3791a6748469c83eb8a269099d8e78 MD5 · raw file

  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. ANEW TASK-MEMBER.FTH
  35. decimal
  36. : FIND.BODY ( -- , pfa true | $name false , look for word in dict. )
  37. \ Return address of parameter data.
  38. bl word find
  39. IF >body true
  40. ELSE false
  41. THEN
  42. ;
  43. \ Variables shared with object oriented code.
  44. VARIABLE OB-STATE ( Compilation state. )
  45. VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class )
  46. 1 constant OB_DEF_CLASS ( defining a class )
  47. 2 constant OB_DEF_STRUCT ( defining a structure )
  48. \ A member contains:
  49. \ cell size of data in bytes (1, 2, cell)
  50. \ cell offset within structure
  51. cell 1- constant CELL_MASK
  52. cell negate constant -CELL
  53. cell constant OB_OFFSET_SIZE
  54. : OB.OFFSET@ ( member_def -- offset ) @ ;
  55. : OB.OFFSET, ( value -- ) , ;
  56. : OB.SIZE@ ( member_def -- offset )
  57. ob_offset_size + @ ;
  58. : OB.SIZE, ( value -- ) , ;
  59. ( Members are associated with an offset from the base of a structure. )
  60. : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
  61. dup >r ( -- +-b , save #bytes )
  62. ABS ( -- |+-b| )
  63. ob-current-class @ ( -- b addr-space)
  64. tuck @ ( as #b c , current space needed )
  65. over CELL_MASK and 0= ( multiple of cell? )
  66. IF
  67. aligned
  68. ELSE
  69. over 1 and 0= ( multiple of two? )
  70. IF
  71. even-up
  72. THEN
  73. THEN
  74. swap over + rot ! ( update space needed )
  75. \ Save data in member definition. %M
  76. ob.offset, ( save old offset for ivar )
  77. r> ob.size, ( store size in bytes for ..! and ..@ )
  78. ;
  79. \ Unions allow one to address the same memory as different members.
  80. \ Unions work by saving the current offset for members on
  81. \ the stack and then reusing it for different members.
  82. : UNION{ ( -- offset , Start union definition. )
  83. ob-current-class @ @
  84. ;
  85. : }UNION{ ( old-offset -- new-offset , Middle of union )
  86. union{ ( Get current for }UNION to compare )
  87. swap ob-current-class @ ! ( Set back to old )
  88. ;
  89. : }UNION ( offset -- , Terminate union definition, check lengths. )
  90. union{ = NOT
  91. abort" }UNION - Two parts of UNION are not the same size!"
  92. ;
  93. \ Make members compile their offset, for "disposable includes".
  94. : OB.MEMBER ( #bytes -- , make room in an object at compile time)
  95. ( -- offset , run time for structure )
  96. CREATE ob.make.member immediate
  97. DOES> ob.offset@ ( get offset ) ?literal
  98. ;
  99. : OB.FINDIT ( <thing> -- pfa , get pfa of thing or error )
  100. find.body not
  101. IF cr count type ." ???"
  102. true abort" OB.FINDIT - Word not found!"
  103. THEN
  104. ;
  105. : OB.STATS ( member_pfa -- offset #bytes )
  106. dup ob.offset@ swap
  107. ob.size@
  108. ;
  109. : OB.STATS? ( <member> -- offset #bytes )
  110. ob.findit ob.stats
  111. ;
  112. : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
  113. ob.findit @
  114. ?literal
  115. ; immediate
  116. \ Basic word for defining structure members.
  117. : BYTES ( #bytes -- , error check for structure only )
  118. ob-state @ ob_def_struct = not
  119. abort" BYTES - Only valid in :STRUCT definitions."
  120. ob.member
  121. ;
  122. \ Declare various types of structure members.
  123. \ Negative size indicates a signed member.
  124. : BYTE ( <name> -- , declare space for a byte )
  125. -1 bytes ;
  126. : SHORT ( <name> -- , declare space for a 16 bit value )
  127. -2 bytes ;
  128. : LONG ( <name> -- )
  129. cell bytes ;
  130. : UBYTE ( <name> -- , declare space for signed byte )
  131. 1 bytes ;
  132. : USHORT ( <name> -- , declare space for signed 16 bit value )
  133. 2 bytes ;
  134. \ Aliases
  135. : APTR ( <name> -- ) long ;
  136. : RPTR ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001
  137. : ULONG ( <name> -- ) long ;
  138. : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
  139. [compile] sizeof() bytes
  140. ;