home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / tile-forth-2.1-bin.lha / lib / tile-forth / prototypes.f83 < prev    next >
Text File  |  1996-10-12  |  4KB  |  156 lines
  1. \
  2. \  PROTOTYPE ORIENTED PROGRAMMING LIBRARY
  3. \
  4. \  Copyright (C) 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: 9 August 1990
  15. \
  16. \  Last updated on: 20 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, relations
  20. \
  21. \  Description:
  22. \       Prototypes are general objects without dividing the world into classes
  23. \       and instances. A prototype may have slots for values and  methods for
  24. \       answering messages. If a prototype lacks the slot or method it may
  25. \       delegate it by an inheritance relation to another prototype.
  26. \
  27. \       This simple model allows code and data sharing on any level compared
  28. \       to the traditional class-instance model found in most other
  29. \       programming languages for Object Oriented Programming. The relations
  30. \       extension is used to implement this library. One predefined relation
  31. \       is required.
  32. \
  33. \  Copying:
  34. \       This program is free software; you can redistribute it and\or modify
  35. \       it under the terms of the GNU General Public License as published by
  36. \       the Free Software Foundation; either version 1, or (at your option)
  37. \       any later version.
  38. \
  39. \       This program is distributed in the hope that it will be useful,
  40. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  41. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  42. \       GNU General Public License for more details.
  43. \
  44. \       You should have received a copy of the GNU General Public License
  45. \       along with this program; see the file COPYING.  If not, write to
  46. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  47.  
  48. .( Loading Prototypes definitions...) cr
  49.  
  50. #include relations.f83
  51.  
  52. vocabulary prototypes ( -- )
  53.  
  54. relations prototypes definitions
  55.  
  56. \ Inheritance relation and delagation function
  57.  
  58. item inherits ( -- relation) private
  59.  
  60. : delegate ( relation prototype -- [relation prototype false] or [value true])
  61.   dup >r
  62.   begin
  63.     ?get-relation if r> drop true exit then
  64.     inherits swap get-relation dup 0=
  65.   until
  66.   drop r> false
  67. ; 
  68.  
  69. : this-prototype ( -- prototype)
  70.   this-item
  71. ;
  72.  
  73. : new-prototype ( parent -- prototype)
  74.   nil new-item inherits swap put-relation
  75. ;
  76.  
  77. : prototype ( parent -- )
  78.   item inherits this-prototype put-relation
  79. ;
  80.  
  81. : parent ( prototype -- addr)
  82.   inherits swap get-relation
  83. ;
  84.  
  85. : prototype>entry ( prototype -- entry)
  86.   item>entry
  87. ;
  88.  
  89. : .prototype ( prototype -- )
  90.   dup item>entry ?dup if .name drop else ." prototype#" 0 .r then
  91. ;
  92.  
  93. : .relations ( prototype -- )
  94.   dup .relations
  95.   begin
  96.     inherits swap get-relation ?dup
  97.   while
  98.     dup cr .relations
  99.   repeat
  100. ;
  101.   
  102. \ Message and method definition function
  103.  
  104. forward unknown-message ( message prototype -- )
  105.  
  106. : message ( -- )
  107.   item
  108. does> ( prototype message -- )
  109.   over delegate if >r else drop swap unknown-message then
  110. ;
  111.  
  112. : .message ( message -- )
  113.   .item
  114. ;
  115.  
  116. variable the-prototype ( -- addr) private
  117.  
  118. : method ( prototype -- )
  119.   dup the-prototype !
  120.   ' >body swap 2dup
  121.   nil -rot put-relation
  122.   here -rot put-relation ]
  123. ;
  124.  
  125. : (inherited) ( prototype message -- )
  126.   over parent dup
  127.   if delegate
  128.     if >r exit then
  129.   then 
  130.   unknown-message
  131. ; private
  132.  
  133. : inherited ( -- )
  134.   the-prototype @ [compile] literal ' >body [compile] literal compile (inherited)
  135. ; immediate compilation 
  136.  
  137. \ Slot definition and assignment function
  138.  
  139. forward unknown-slot ( slot prototype -- )
  140.  
  141. : slot ( -- )
  142.   item
  143. does> ( prototype slot -- value)
  144.   swap delegate not if unknown-slot then
  145. ;
  146.  
  147. : -> ( value prototype -- )
  148.   ' >body [compile] literal ?compile swap ?compile put-relation
  149. ; immediate
  150.  
  151. : .slot ( slot -- )
  152.   .item
  153. ;
  154.  
  155. forth only
  156.