/hmsl/fth/exmember.fth

https://github.com/philburk/hmsl · Forth · 148 lines · 124 code · 22 blank · 2 comment · 6 complexity · ec25eb48264537d654453e3e955edd0e MD5 · raw file

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