home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Contributed / SCOOPS / examples.sch next >
Encoding:
Text File  |  1989-01-10  |  4.3 KB  |  119 lines  |  [TEXT/EDIT]
  1. ; ............ A SCOOPS OBJECT SYSTEM IN MACSCHEME: README.DOC ............
  2. ;
  3. ;
  4. ;The included code was prepared by John Ulrich and is distributed by Semantic
  5. ;Microsystems as a service to the Scheme community.  You may copy, modify, 
  6. ;and distribute it provided you include this notice in any copy or modified 
  7. ;copy. This code should not be regarded as any sort of endorsement of SCOOPS 
  8. ;as an object system for Scheme.  Semantic intends to support a Scheme 
  9. ;object system standard if and when one is adopted by the Scheme committee.
  10. ;
  11. ;SCOOPS was originally specified and implemented by Texas Instruments for
  12. ;PCScheme. By implementing SCOOPS in MacScheme I hope to help those who 
  13. ;are porting code between the two Scheme dialects. I have attempted to
  14. ;follow the specification as given in the PCScheme manual; however, there
  15. ;will likely be some subtle differences. Any discovered differences between
  16. ;the PCScheme and the MacScheme implementations should be brought to my
  17. ;attention.
  18.  
  19. ;For those familiar with SCOOPS, files readme.doc and examples.sch
  20. ;will get you started.  Those unfamiliar with SCOOPS should also read 
  21. ;the TI documentation found in scoops.doc.part1 and scoops.doc.part2.
  22. ;
  23. ;
  24. ;
  25. ;                                    John Ulrich
  26. ;                                    P.O. 1636
  27. ;                                    Beaverton
  28. ;                                    OR 97075
  29. ;
  30. ;                                    November,1987
  31. ;
  32. ;
  33. ;the first example illustrates classvars, instvars, set and get methods.
  34. (define-class location
  35.   (classvars (w 'baker)(u 'able))
  36.   (instvars (x 400) 
  37.             (y (active 500 (lambda (x)(display "get method ") x)
  38.                            (lambda (x)(display "set method ") x))))
  39.   (options gettable-variables settable-variables inittable-variables))
  40.  
  41. ;the next example illustrates inheritance. Order is important. Location
  42. ;must be defined before support since support inherits from location.
  43. ;Location may be later redefined and support will be automatically
  44. ;updated. 
  45.  
  46. (define-class support
  47.   (instvars (price 0)(material 'wood))
  48.   (mixins location)
  49.   (options gettable-variables settable-variables inittable-variables))
  50.  
  51.  
  52. ;The next two examples illustrate two classes with a common
  53. ;lexical environment. Because chairs mixin furniture and support methods
  54. ;and a furniture method refers to the bound variable lex, chairs must
  55. ;be defined in the same environment as furniture. No error will be detected
  56. ;it this is violated, but in this case, the variable lex refered to in 
  57. ;chair will be distinct from the variable lex refered to in furniture.
  58.  
  59. (let ((lex 'baz))
  60.   ;This example shows how to define instance methods.
  61.   (define-class furniture
  62.     (instvars (price 0) (purpose 'sitting))
  63.     (methods (print-lex (lambda ()(display lex)(newline)))
  64.              (move (lambda (deltax deltay)
  65.                      (set! x (+ x deltax))
  66.                      (set! y (+ y deltay))
  67.                      ))
  68.              (set-lex (lambda(x)(set! lex x))))
  69.     (mixins location)
  70.     (options gettable-variables settable-variables inittable-variables))
  71.   
  72.   ;In the following, the important point is that material is not settable
  73.   ;in a chair even though it is settable in support and chair 
  74.   ;inherits from support. The reason is that material in chair shadows
  75.   ;material in support and material is excluded from the settable variables
  76.   ;in the definition of chair.
  77.   
  78.   
  79.   (define-class chair
  80.     (instvars (number-of-legs 4)(material 'metal))
  81.     (mixins furniture support)
  82.     (options gettable-variables 
  83.              (settable-variables number-of-legs)
  84.              inittable-variables)))
  85.  
  86.  
  87. ;sanity checks
  88. (all-classvars chair)
  89. (all-instvars chair)
  90. (all-methods chair)
  91. (class-compiled? chair)
  92. (set! ch1 (make-instance chair 'x 500 'y 500))
  93. (class-of-object ch1)
  94. (classvars chair)
  95. (compile-class chair)
  96. (describe chair)
  97. (getcv chair u)
  98. (setcv chair u 'able)
  99. (getcv chair u)
  100. (instvars chair)
  101. (methods chair)
  102. (mixins chair)
  103. (name->class 'chair)
  104. (rename-class (chair newchair))
  105. (name->class 'newchair)
  106. (send-if-handles ch1 foo)
  107. (send ch1 set-y 500)
  108. (define-method (location row)
  109.   (z)(+ x y z))
  110. (all-methods chair)
  111. ;there will be a long pause while chair is recompiled
  112. (set! ch2 (make-instance chair))
  113. (send ch2 row 5)
  114. (send ch2 set-x 40)
  115. (send ch2 set-y 50)
  116. (send ch2 row 10)
  117. (compile-class  chair)
  118.  
  119.