home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / tile-forth-2.1-bin.lha / lib / tile-forth / structures.f83 < prev   
Text File  |  1996-10-12  |  4KB  |  144 lines
  1. \
  2. \  STRUCTURE DEFINITIONS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 3 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth
  20. \
  21. \  Description:
  22. \       Allows aggregates of data to be described as structures. General-
  23. \       ization of structures in traditional programming languages. Allows
  24. \       definition, initialization and action part. Basic object based
  25. \       action may be defined in a style similar to the "does" section of
  26. \       a creating word.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Structures definitions...) cr
  44.  
  45. vocabulary structures ( -- )
  46.  
  47. structures definitions 
  48.  
  49. 0 field +size ( struct.type -- addr) private
  50. cell field +initiate ( struct.type -- addr) private
  51.  
  52. : as ( -- struct.type)  
  53.   ' >body                 ( Quote next symbol and access body)
  54.   [compile] literal            ( If compiling generate a literal)
  55. ; immediate                
  56.  
  57. : this ( -- addr)
  58.   last >body                 ( Access the body of the last symbol)
  59. ;
  60.  
  61. : initiate ( addr struct.type -- )  
  62.   +initiate @ ?dup            ( Access initiate. code pointer)
  63.   if >r else drop then            ( If available perform initialization)
  64. ;
  65.  
  66. : make-struct ( struct.type -- addr)
  67.   here dup >r                 ( Save pointer to instance)
  68.   over +size @ allot             ( Access size and allocate memory)
  69.   swap initiate r>             ( Perform initialization)
  70. ; private
  71.  
  72. : new-struct ( -- addr)
  73.   [compile] as                 ( Take the next symbol, "as")
  74.   ?compile make-struct            ( And "make" an instance)
  75. ; immediate                
  76.  
  77. : sizeof ( -- num)
  78.   ' >body +size @             ( Access size of structure)
  79.   [compile] literal            ( And make literal if compiling)
  80. ; immediate
  81.  
  82. : assign ( a b -- )  
  83.   [compile] sizeof ?compile cmove    ( Access size and assign instance)
  84. ; immediate
  85.  
  86. : not-equal ( a b -- bool)
  87.   [compile] sizeof ?compile -match    ( Access size and match the blocks)
  88. ; immediate
  89.  
  90. : struct.type ( -- struct.type offset0)  
  91.   create here 0 0 , 0 ,         ( Allocate initial struct information)
  92. does> ( struct.type -- )
  93.   create make-struct drop        ( Create a new instance)
  94. ;
  95.  
  96. : bytes ( offset1 n -- offset2)  
  97.   over dup                ( Check for zero offset)
  98.   if field +                ( Create an access field of "n" bytes)
  99.   else
  100.     create , + immediate        ( Create an efficient field)
  101.     does> ( field -- )
  102.       drop                ( Does nothing at runtime )
  103.   then
  104. ;
  105.  
  106. : align ( offset1 -- offset2)  
  107.   dup 1 and +                 ( Align field offset to even address)
  108. ;
  109.  
  110. : struct.field ( bytes -- )  
  111.   create , nil ,            ( Create a predefined field type)
  112. does> ( struct.field -- )
  113.   @ bytes                ( At run-time create field names)
  114. ; private
  115.  
  116. : struct ( -- )  
  117.   [compile] sizeof bytes         ( Create a structure sized field name)
  118. ;
  119.  
  120. ( Initial set of field names)
  121. 1 struct.field byte ( -- )
  122. 2 struct.field word ( -- )
  123. 4 struct.field long ( -- )
  124. 4 struct.field ptr  ( -- )
  125. 4 struct.field enum ( -- )
  126.  
  127. : struct.init ( struct.type offset3 -- )
  128.   align over +size !              ( Assign size of structure type)
  129.   here swap +initiate ! ]         ( And pointer to initialization code)
  130. ;
  131.  
  132. : struct.does ( -- ) 
  133.   [compile] does>             ( Do what does-does)
  134. ; immediate compilation
  135.  
  136. : struct.end ( [] or [struct.type offset3] -- )  
  137.   compiling                 ( Check compilation status)
  138.   if [compile] ;             ( If compiling then end definition)
  139.   else swap +size ! then        ( Else assign size of structure type)
  140. ; immediate
  141.  
  142. forth only
  143.  
  144.