home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / scoops-6.1.scm < prev    next >
Encoding:
Text File  |  1993-07-16  |  37.9 KB  |  1,166 lines
  1. ;;;
  2. ;;;    Copyright (c) 1986 Texas Instruments Incorporated
  3. ;;;
  4. ;;;    Permission to copy this software, to redistribute it, and
  5. ;;;     to use it for any purpose is granted, subject to the
  6. ;;;     following restrictions and understandings.
  7. ;;;
  8. ;;;    1. Any copy made of this software must include this copyright
  9. ;;;    notice in full.
  10. ;;;
  11. ;;;    2.  All materials developed as a consequence of the use of
  12. ;;;    this software shall duly acknowledge such use, in accordance
  13. ;;;    with the usual standards of acknowledging credit in academic
  14. ;;;    research.
  15. ;;;
  16. ;;;    3. TI has made no warranty or representation that the
  17. ;;;    operation of this software will be error-free, and TI is
  18. ;;;    under no obligation to provide any services, by way of
  19. ;;;    maintenance, update, or otherwise.
  20. ;;;
  21. ;;;    4.  In conjunction with products arising from the use
  22. ;;;    of this material, there shall be no use of the name of
  23. ;;;     Texas Instruments (except for the above copyright credit)
  24. ;;;    nor of any adaptation thereof in any advertising, promotional,
  25. ;;;     or sales literature without prior written consent from TI in
  26. ;;;     each case.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31. ;;;                                                                 ;;;
  32. ;;;                     S c o o p s                                 ;;;
  33. ;;;                                                                 ;;;
  34. ;;;               File updated : 5/23/86                            ;;;
  35. ;;;                                                                 ;;;
  36. ;;;                   File : class.scm                              ;;;
  37. ;;;                                                                 ;;;
  38. ;;;                 Amitabh Srivastava                              ;;;
  39. ;;;                                                                 ;;;
  40. ;;;         This file handles class creation.                       ;;;
  41. ;;;                                                                 ;;;
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43.  
  44. (declare (usual-integrations))
  45.  
  46. (define ALL-CLASSVARS)
  47. (define ALL-INSTVARS)
  48. (define ALL-METHODS)
  49. (define CLASS-COMPILED?)
  50. (define CLASSVARS)
  51. (define DESCRIBE)
  52. (define INSTVARS)
  53. (define METHODS)
  54. (define MIXINS)
  55.  
  56. ;;;
  57. (define scoops-package
  58.   (make-environment
  59.  
  60. (define %%class-tag (make-interned-symbol "#!CLASS"))
  61.  
  62. (set! (access named-objects parser-package) 
  63.       (cons (cons 'CLASS %%class-tag) (access named-objects parser-package)))
  64.  
  65.  
  66. ((access add-unparser-special-object! unparser-package) %%class-tag
  67.  (lambda (class)
  68.    ((access unparse-with-brackets unparser-package)
  69.     (lambda ()
  70.       (write-string "SCOOPS Class ")
  71.       (write (hash class))))))
  72.  
  73.  
  74. (define %sc-make-class
  75.   (lambda (name cv allivs mixins method-values)
  76.     (let ((method-structure
  77.                   (mapcar (lambda (a) (list (car a) (cons name name)))
  78.                           method-values))
  79.           (class (make-vector 15)))
  80.        (vector-set! class 0 %%class-tag)
  81.        (vector-set! class 1 name)
  82.        (vector-set! class 2 cv)
  83.        (vector-set! class 3 cv)
  84.        (vector-set! class 4 allivs)
  85.        (vector-set! class 5 mixins)
  86.        (vector-set! class 6 (%uncompiled-make-instance class))
  87.        (vector-set! class 9 method-structure)
  88.        (vector-set! class 13 method-values)
  89.        (vector-set! class 14 allivs)
  90.        (putprop name class '%class)
  91.        class)))
  92.  
  93. (define %scoops-chk-class
  94.   (lambda (class)
  95.     (and (not (and (vector? class)
  96.                    (> (vector-length class) 0)
  97.                    (equal? %%class-tag (vector-ref class 0))))
  98.          (error-handler class 6 #!TRUE))))
  99.  
  100.  
  101. ;;; %sc-name
  102. (define-integrable (%sc-name class)
  103.     (vector-ref class 1))
  104.  
  105. ;;; %sc-cv
  106. (define-integrable (%sc-cv class)
  107.     (vector-ref class 2))
  108.  
  109. ;;; %sc-allcvs
  110. (define-integrable (%sc-allcvs class)
  111.     (vector-ref class 3))
  112.  
  113. ;;; %sc-allivs
  114. (define-integrable (%sc-allivs class)
  115.     (vector-ref class 4))
  116.  
  117. ;;; %sc-mixins
  118. (define-integrable (%sc-mixins class)
  119.     (vector-ref class 5))
  120.  
  121. ;;; %sc-inst-template
  122. (define-integrable (%sc-inst-template class)
  123.     (vector-ref class 6))
  124.  
  125. ;;; %sc-method-env
  126. (define-integrable (%sc-method-env class)
  127.     (vector-ref class 7))
  128.  
  129. ;;; %sc-class-env
  130. (define-integrable (%sc-class-env class)
  131.     (vector-ref class 8))
  132.  
  133.  
  134. ;;; %sc-method-structure
  135. (define-integrable (%sc-method-structure class)
  136.     (vector-ref class 9))
  137.  
  138. ;;; %sc-subclasses
  139. (define-integrable (%sc-subclasses class)
  140.     (vector-ref class 10))
  141.  
  142. ;;; %sc-class-compiled
  143. (define-integrable (%sc-class-compiled class)
  144.     (vector-ref class 11))
  145.  
  146. ;;; %sc-class-inherited
  147. (define-integrable (%sc-class-inherited class)
  148.     (vector-ref class 12))
  149.  
  150. ;;; %sc-method-values
  151. (define-integrable (%sc-method-values class)
  152.     (vector-ref class 13))
  153.  
  154. (define-integrable (%sc-iv class)
  155.     (vector-ref class 14))
  156.  
  157. ;;; %sc-set-name
  158. (define-integrable (%sc-set-name class val)
  159.     (vector-set! class 1 val))
  160.  
  161. ;;; %sc-set-cv
  162. (define-integrable (%sc-set-cv class val)
  163.     (vector-set! class 2 val))
  164.  
  165.  
  166. ;;; %sc-set-allcvs
  167. (define-integrable (%sc-set-allcvs class val)
  168.     (vector-set! class 3 val))
  169.  
  170. ;;; %sc-set-allivs
  171. (define-integrable (%sc-set-allivs class val)
  172.     (vector-set! class 4 val))
  173.  
  174. ;;; %sc-set-mixins
  175. (define-integrable (%sc-set-mixins class val)
  176.     (vector-set! class 5 val))
  177.  
  178. ;;; %sc-set-inst-template
  179. (define-integrable (%sc-set-inst-template class val)
  180.     (vector-set! class 6 val))
  181.  
  182. ;;; %sc-set-method-env
  183. (define-integrable (%sc-set-method-env class val)
  184.     (vector-set! class 7 val))
  185.  
  186. ;;; %sc-set-class-env
  187. (define-integrable (%sc-set-class-env class val)
  188.     (vector-set! class 8 val))
  189.  
  190. ;;; %sc-set-method-structure
  191. (define-integrable (%sc-set-method-structure class val)
  192.     (vector-set! class 9 val))
  193.  
  194. ;;; %sc-set-subclasses
  195. (define-integrable (%sc-set-subclasses class val)
  196.     (vector-set! class 10 val))
  197.  
  198.  
  199. ;;; %sc-set-class-compiled
  200. (define-integrable (%sc-set-class-compiled class val)
  201.     (vector-set! class 11 val))
  202.  
  203. ;;; %sc-set-class-inherited
  204. (define-integrable (%sc-set-class-inherited class val)
  205.     (vector-set! class 12 val))
  206.  
  207. ;;; %sc-set-method-values
  208. (define-integrable (%sc-set-method-values class val)
  209.     (vector-set! class 13 val))
  210.  
  211. ;;; %sc-set-iv
  212. (define-integrable (%sc-set-iv class val)
  213.     (vector-set! class 14 val))
  214.  
  215.  
  216. ;;;
  217. (define %sc-name->class
  218.   (lambda (name)
  219.     (apply-if (getprop name '%class)
  220.               (lambda (a) a)
  221.               (error-handler name 2 #!TRUE))))
  222.  
  223. ;;; %sc-get-meth-value
  224. (define-integrable (%sc-get-meth-value meth-name class)
  225.     (cdr (assq meth-name (%sc-method-values class))))
  226.  
  227. ;;; %sc-get-cv-value
  228. (define-integrable (%sc-get-cv-value var class)
  229.     (cadr (assq var (%sc-cv class))))
  230.  
  231. ;;; %sc-concat
  232. (define-integrable (%sc-concat str sym)
  233.     (string->symbol (string-append str (symbol->string sym))))
  234.  
  235.  
  236. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  237. ;;;                                                                 ;;;
  238. ;;;                     S c o o p s                                 ;;;
  239. ;;;                                                                 ;;;
  240. ;;;                                                                 ;;;
  241. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  242. ;;;        by Steve Sherin--U of P                    ;;;
  243. ;;;                   File : methods.scm                            ;;;
  244. ;;;                                                                 ;;;
  245. ;;;                 Amitabh Srivastava                              ;;;
  246. ;;;                                                                 ;;;
  247. ;;;    This file handles the addition/redefinition of methods.      ;;;
  248. ;;;                                                                 ;;;
  249. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  250.  
  251.  
  252. ;;; is class1 before class2 in class ?
  253. ;;; class1  is not equal to class2
  254.  
  255. (define %before
  256.   (lambda (class1 class2 class)
  257.     (or (eq? class1 class)
  258.         (memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
  259.  
  260. ;;; DEFINE-METHOD
  261. (syntax-table-define system-global-syntax-table 'DEFINE-METHOD
  262.   (macro e
  263.     (let ((class-name (caar e))
  264.           (method-name (cadar e))
  265.           (formal-list (cadr e))
  266.           (body (cddr e)))
  267.       `(%sc-class-add-method
  268.     ',class-name
  269.     ',method-name
  270.     ',class-name
  271.     ',class-name
  272.     (append (list 'lambda ',formal-list) ',body)
  273.     (lambda (env quoted-val)
  274.       (let* ((method-name ',method-name)
  275.          (temp `(in-package ,env 
  276.               (define ,method-name
  277.                 ,quoted-val))))
  278.         (eval temp (the-environment)))
  279.       )))))
  280. ;;;
  281.  
  282. (define %sc-class-add-method
  283.   (lambda (class-name
  284.        method-name
  285.        method-class
  286.        mixin-class
  287.        method
  288.        assigner)
  289.     (let ((class (%sc-name->class class-name)))
  290.       (begin
  291.     (let ((temp (assq method-name (%sc-method-values class))))
  292.       (if temp
  293.           (set-cdr! temp method)
  294.           (%sc-set-method-values 
  295.            class
  296.            (cons (cons method-name method) (%sc-method-values class))))))
  297.       (%compiled-add-method class-name method-name method-class mixin-class
  298.                 method assigner))))
  299. ;;;
  300.  
  301. (define %inform-subclasses
  302.   (lambda (class-name method-name method-class mixin-class method assigner)
  303.     ((rec loop
  304.        (lambda (class-name method-name method-class mixin-class
  305.                                        method assigner subclass)
  306.          (if subclass
  307.              (begin
  308.                 (%compiled-add-method
  309.                   (car subclass) method-name method-class class-name
  310.                   method assigner)
  311.                 (loop class-name method-name method-class mixin-class
  312.                       method assigner
  313.                       (cdr subclass))))))
  314.      class-name method-name method-class mixin-class method assigner
  315.      (%sc-subclasses (%sc-name->class class-name)))))
  316. ;;;
  317.  
  318. (define %compiled-add-method
  319.   (lambda (class-name
  320.        method-name
  321.        method-class
  322.        mixin-class
  323.        method
  324.        assigner)
  325.     (letrec
  326.       ((class (%sc-name->class class-name))
  327.  
  328.        (insert-entry
  329.          (lambda (previous current)
  330.            (cond ((null? current)
  331.                   (set-cdr! previous
  332.                      (cons (cons method-class mixin-class) '())))
  333.                  ((eq? mixin-class (cdar current))
  334.                   (set-car! (car current) method-class))
  335.                  ((%before mixin-class (cdar current)
  336.                            class-name)
  337.                   (set-cdr! previous
  338.                      (cons (cons method-class mixin-class) current)))
  339.                  (else '()))))
  340.  
  341.  
  342.        (loop-insert
  343.          (lambda (previous current)
  344.            (if (not (insert-entry previous current))
  345.                (loop-insert (current) (cdr current)))))
  346.  
  347.        (insert
  348.          (lambda (entry)
  349.            (if (insert-entry entry (cdr entry))  ;;; insert at head
  350.                (add-to-environment)
  351.                (loop-insert (cdr entry) (cddr entry)))))
  352.  
  353.        (add-to-environment
  354.          (lambda ()
  355.      (begin
  356.            (if (%sc-class-compiled class)
  357.                 (assigner (%sc-method-env class) method))
  358.            (if (%sc-subclasses class)
  359.                (%inform-subclasses class-name method-name method-class
  360.                                   mixin-class method assigner)))))
  361.  
  362.        (add-entry
  363.          (lambda ()
  364.      (begin
  365.            (%sc-set-method-structure class
  366.              (cons (list method-name (cons method-class mixin-class))
  367.                    (%sc-method-structure class)))
  368.            (add-to-environment))))
  369.       )
  370.  
  371.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  372.         (if method-entry
  373.             (insert method-entry)
  374.             (add-entry))
  375.         method-name))))
  376. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  377. ;;;                                                                 ;;;
  378. ;;;                     S c o o p s                                 ;;;
  379. ;;;                                                                 ;;;
  380. ;;;                                                                 ;;;
  381. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  382. ;;;        by Steve Sherin--U of P                    ;;;
  383. ;;;                   File : meth2.scm                              ;;;
  384. ;;;                                                                 ;;;
  385. ;;;                 Amitabh Srivastava                              ;;;
  386. ;;;                                                                 ;;;
  387. ;;;    This file handles the deletion of a method from a class.     ;;;
  388. ;;;                                                                 ;;;
  389. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  390.  
  391. ;;; DELETE-METHOD 
  392. (syntax-table-define system-global-syntax-table 'DELETE-METHOD 
  393.   (macro e
  394.     (let ((class-name (caar e))
  395.           (method-name (cadar e)))
  396.       `(%sc-class-del-method
  397.     ',class-name
  398.     ',method-name
  399.     ',class-name
  400.     ',class-name
  401.     (LAMBDA (ENV VAL)
  402.       (SET! (ACCESS ,method-name ENV) VAL))
  403.     #!false))))
  404. ;;;
  405.  
  406. (define %deleted-method
  407.   (lambda (name)
  408.     (lambda args
  409.       (error-handler name 3 #!TRUE))))
  410. ;;;
  411.  
  412. (define %sc-class-del-method
  413.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  414.     (let ((class (%sc-name->class class-name)))
  415.       (let ((temp (assq method-name (%sc-method-values class))))
  416.     (if temp
  417.      (begin
  418.           (%sc-set-method-values class
  419.                (delq! temp (%sc-method-values class)))
  420.           (%compiled-del-method class-name method-name method-class mixin-class
  421.                                assigner del-value))
  422.  
  423.     (error-handler method-name 4 #!true))))))
  424. ;;;
  425.  
  426. (define %inform-del-subclasses
  427.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  428.     ((rec loop
  429.        (lambda (class-name method-name method-class mixin-class assigner
  430.                 del-value subclass)
  431.          (if subclass
  432.              (begin
  433.                 (%compiled-del-method (car subclass) method-name
  434.                           method-class class-name assigner del-value)
  435.                 (loop class-name method-name method-class mixin-class assigner
  436.                       del-value (cdr subclass))))))
  437.      class-name method-name method-class mixin-class assigner del-value
  438.      (%sc-subclasses (%sc-name->class class-name)))))
  439. ;;;
  440.  
  441. (define %compiled-del-method
  442.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  443.     (let ((class (%sc-name->class class-name)))
  444.       (letrec
  445.         ((delete-entry
  446.            (lambda (previous current)
  447.              (cond ((eq? mixin-class (cdar current))
  448.                     (set-cdr! previous (cdr current)) #!TRUE)
  449.                    (else #!FALSE))))
  450.  
  451.          (loop-delete
  452.            (lambda (previous current)
  453.              (cond ((or (null? current)
  454.                         (%before mixin-class (cdar previous)
  455.                                  class-name))
  456.                     (error-handler method-name 4 #!TRUE))
  457.                    ((delete-entry previous current) #!TRUE)
  458.                    (else (loop-delete current (cdr current))))))
  459.  
  460.          (delete
  461.            (lambda (entry)
  462.              (if (delete-entry entry (cdr entry))  ;;; delete at head
  463.                  (modify-environment entry)
  464.                  (loop-delete (cdr entry) (cddr entry)))))
  465.  
  466.        (modify-environment
  467.          (lambda (entry)
  468.        (cond ((null? (cdr entry))
  469.           (%sc-set-method-structure class
  470.             (delq! (assq method-name (%sc-method-structure class))
  471.                (%sc-method-structure class)))
  472.                   (if (%sc-class-compiled class)
  473.                       (assigner (%sc-method-env class)
  474.                                 (or del-value
  475.                                     (set! del-value
  476.                                           (%deleted-method method-name)))))
  477.           (if (%sc-subclasses class)
  478.               (%inform-del-subclasses class-name method-name
  479.                    method-class mixin-class assigner del-value)))
  480.          (else
  481.           (let ((meth-value
  482.              (%sc-get-meth-value method-name
  483.                          (%sc-name->class (caadr entry)))))
  484.             (if (%sc-class-compiled class)
  485.             (assigner (%sc-method-env class) meth-value))
  486.             (if (%sc-subclasses class)
  487.             (%inform-subclasses class-name
  488.                         method-name
  489.                         method-class
  490.                         mixin-class
  491.                         meth-value assigner)))))))
  492.       )
  493.  
  494.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  495.         (if method-entry
  496.             (delete method-entry)
  497.             (error-handler method-name 4 #!TRUE))
  498.         method-name)))))
  499. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  500. ;;;                                                                 ;;;
  501. ;;;                     S c o o p s                                 ;;;
  502. ;;;                                                                 ;;;
  503. ;;;                                                                 ;;;
  504. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  505. ;;;        by Steve Sherin--U of P                    ;;;
  506. ;;;                   File : instance.scm                           ;;;
  507. ;;;                                                                 ;;;
  508. ;;;                 Amitabh Srivastava                              ;;;
  509. ;;;                                                                 ;;;
  510. ;;;    This file contains compiling and making of an instance.      ;;;
  511. ;;;                                                                 ;;;
  512. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  513.  
  514. ;;; COMPILE-CLASS
  515. (syntax-table-define system-global-syntax-table 'COMPILE-CLASS
  516.   (macro e
  517.     `(let* ((class ,(car e))
  518.         (name (%sc-name class)))
  519.        (if (%sc-class-compiled class)
  520.        name
  521.        (begin
  522.          (%inherit-method-vars class)
  523.          (eval (%make-template name class) (the-environment)))))))
  524. ;;;
  525.  
  526. (define (%sc-compile-class class)
  527.   (begin
  528.     (%inherit-method-vars class)
  529.     (eval (%make-template (%sc-name class) class)
  530.         user-initial-environment)))
  531.  
  532. ;;; MAKE-INSTANCE
  533. (syntax-table-define system-global-syntax-table 'MAKE-INSTANCE 
  534.   (macro e
  535.     (cons (list '%sc-inst-template (car e)) (cdr e))))
  536. ;;;
  537.  
  538. (define %uncompiled-make-instance
  539.   (lambda (class)
  540.     (lambda init-msg
  541.       (%sc-compile-class class)
  542.       (apply (%sc-inst-template class) init-msg))))
  543. ;;;
  544.  
  545. (define %make-template
  546.   (lambda (name class)
  547.     `(begin
  548. ;;; do some work to make compile-file work
  549.        (%sc-set-allcvs ,name ',(%sc-allcvs class))
  550.        (%sc-set-allivs ,name ',(%sc-allivs class))
  551.        (%sc-set-method-structure ,name
  552.             ',(%sc-method-structure class))
  553. ;;; prepare make-instance template
  554.        (%sc-set-inst-template ,name
  555.           ,(%make-inst-template (%sc-allcvs class)
  556.                                (%sc-allivs class)
  557.                                (%sc-method-structure class)
  558.                                name class))
  559.        (%sc-method-thrust ,name)
  560.        (%sc-set-class-compiled ,name #!TRUE)
  561.        (%sc-set-class-inherited ,name #!TRUE)
  562.        (%sign-on ',name ,name)
  563.        ',name)))
  564. ;;;
  565.  
  566. (define %make-inst-template
  567.   (lambda (cvs ivs method-structure name class)
  568.     (let ((methods '((%*methods*% '-)))
  569.           (classvar (append cvs '((%*classvars*% '-))))
  570.           (instvar  (append ivs '((%*instvars*% '-)))))
  571. ;;; dummy variables are added to methods, cvs, and ivs to prevent the
  572. ;;; compiler from folding them away.
  573.          `(let ,classvar
  574.            (%sc-set-class-env ,name (the-environment))
  575.             (let ,methods
  576.               (%sc-set-method-env ,name (the-environment))
  577.           (let ((%sc-class ,name))
  578.               (lambda %sc-init-vals
  579.                 (let ,instvar
  580.                   (the-environment)))))))))
  581.  
  582.  
  583.  
  584. ;;; %sc-method-thrust evaluates each method in the method-environment
  585. ;;; for the class, enabling methods to grab free variables from the
  586. ;;; class-environment without a special code-replacement call.
  587.  
  588. (define (%sc-method-thrust class)
  589.   (define (iter binding-pair)
  590.     (let* ((method-name (car binding-pair))
  591.        (quoted-val (cdr binding-pair))
  592.        (temp `(in-package (%sc-method-env class)
  593.             (define ,method-name ,quoted-val))))
  594.       (eval temp (the-environment))))
  595. (mapcar iter (%sc-method-values class)))
  596.  
  597.  
  598.  
  599. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  600. ;;;                                                                 ;;;
  601. ;;;                     S c o o p s                                 ;;;
  602. ;;;                                                                 ;;;
  603. ;;;                                                                 ;;;
  604. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  605. ;;;        by Steve Sherin--U of P                    ;;;
  606. ;;;                   File : inht.scm                               ;;;
  607. ;;;                                                                 ;;;
  608. ;;;                 Amitabh Srivastava                              ;;;
  609. ;;;                                                                 ;;;
  610. ;;;    This file contains routines to handle inheritance.           ;;;
  611. ;;;                                                                 ;;;
  612. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  613.  
  614. ;;;
  615.  
  616. (define %inherit-method-vars
  617.   (lambda (class)
  618.     (or (%sc-class-inherited class)
  619.     (%inherit-from-mixins
  620.      (%sc-allcvs class)
  621.      (%sc-allivs class)
  622.      (%sc-method-structure class)
  623.      (%sc-mixins class)
  624.      class
  625.      (lambda (class cvs ivs methods)
  626.        (%sc-set-allcvs class cvs)
  627.        (%sc-set-allivs class ivs)
  628.        (%sc-set-method-structure class methods)
  629.            (%sc-set-class-inherited class #!true)
  630.            (%sign-on (%sc-name class) class)
  631.        class)))))
  632. ;;;
  633.  
  634. (define %sign-on
  635.   (lambda (name class)
  636.     (mapcar
  637.       (lambda (mixin)
  638.         (let* ((mixin-class (%sc-name->class mixin))
  639.                (subc (%sc-subclasses mixin-class)))
  640.           (if (not (%sc-class-inherited mixin-class))
  641.               (%inherit-method-vars mixin-class))
  642.           (or (memq name subc)
  643.               (%sc-set-subclasses mixin-class (cons name subc)))))
  644.       (%sc-mixins class))))
  645. ;;;
  646.  
  647. (define %inherit-from-mixins
  648.   (letrec
  649.     ((insert-entry
  650.       (lambda (entry class1 method-entry name2 previous current)
  651.         (cond ((null? current)
  652.                (set-cdr! previous
  653.                          (cons (cons (caadr method-entry) name2) '())))
  654.               ((%before name2 (cdar current) (%sc-name class1))
  655.                (set-cdr! previous
  656.                          (cons (cons (caadr method-entry) name2) current)))
  657.               (else '()))))
  658.  
  659.     (insert
  660.       (lambda (struct1 entry class1 struct2 name2)
  661.         ((rec loop-insert
  662.            (lambda (struct1 entry class1 struct2 name2 previous current)
  663.              (if (insert-entry entry class1 struct2 name2 previous current)
  664.                  struct1
  665.                  (loop-insert struct1 entry class1 struct2 name2
  666.                               current (cdr current)))))
  667.          struct1 entry class1 struct2 name2 entry (cdr entry))))
  668.  
  669.     (add-entry
  670.       (lambda (struct1 class1 method-entry name2)
  671.         (cons (list (car method-entry) (cons (caadr method-entry) name2))
  672.               struct1)))
  673.  
  674.     (combine-methods
  675.       (lambda (struct1 class1 struct2 name2)
  676.     (if struct2
  677.         (combine-methods
  678.          (let ((entry (assq (caar struct2) struct1)))
  679.            (if entry
  680.            (insert struct1 entry class1 (car struct2) name2)
  681.            (add-entry struct1 class1 (car struct2) name2)))
  682.          class1
  683.          (cdr struct2)
  684.          name2)
  685.         struct1)))
  686.  
  687.      (combine-vars
  688.        (lambda (list1 list2)
  689.      (if list2
  690.          (combine-vars
  691.           (if (assq (caar list2) list1)
  692.           list1
  693.           (cons (car list2) list1))
  694.           (cdr list2))
  695.          list1)))
  696.      )
  697.  
  698.   (lambda (cvs ivs methods mixins class receiver)
  699.     ((rec loop-mixins
  700.        (lambda (cvs ivs methods mixins class receiver)
  701.          (if mixins
  702.              (let ((mixin-class (%sc-name->class (car mixins))))
  703.                (%inherit-method-vars mixin-class)
  704.                (loop-mixins
  705.                  (combine-vars cvs (%sc-allcvs mixin-class))
  706.                  (combine-vars ivs (%sc-allivs mixin-class))
  707.                  (combine-methods methods class
  708.                           (%sc-method-structure mixin-class) (car mixins))
  709.                  (cdr mixins)
  710.                  class
  711.                  receiver))
  712.              (receiver class cvs ivs methods ))))
  713.      cvs ivs methods mixins class receiver))))
  714.  
  715. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  716. ;;;                                                                 ;;;
  717. ;;;                     S c o o p s                                 ;;;
  718. ;;;                                                                 ;;;
  719. ;;;                                                                 ;;;
  720. ;;;        Rewritten 5/20/87 for cscheme                            ;;;
  721. ;;;        by Steve Sherin--U of P                                  ;;;
  722. ;;;                   File : interf.scm                             ;;;
  723. ;;;                                                                 ;;;
  724. ;;;                 Amitabh Srivastava                              ;;;
  725. ;;;                                                                 ;;;
  726. ;;;    This file contains class definition and processing of        ;;;
  727. ;;;    define-class.                                                ;;;
  728. ;;;                                                                 ;;;
  729. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  730.  
  731. ;;; DEFINE-CLASS
  732. (syntax-table-define system-global-syntax-table 'DEFINE-CLASS
  733.   (macro e
  734.     (let ((name (car e)) 
  735.       (classvars '()) 
  736.       (instvars '()) (mixins '())
  737.           (options '())
  738.       (allvars '())
  739.       (method-values '())(inits '()))
  740.       (letrec
  741.       ((chk-class-def
  742.         (lambda (deflist)
  743.           (if deflist
  744.           (begin
  745.             (cond ((eq? (caar deflist) 'classvars)
  746.                (set! classvars (cdar deflist)))
  747.               ((eq? (caar deflist) 'instvars)
  748.                (set! instvars (cdar deflist)))
  749.               ((eq? (caar deflist) 'mixins)
  750.                (set! mixins (cdar deflist)))
  751.               ((eq? (caar deflist) 'options)
  752.                (set! options (cdar deflist)))
  753.               (else (error-handler (caar deflist) 0 '())))
  754.             (chk-class-def (cdr deflist)))
  755.           (update-allvars))))
  756.  
  757.        (update-allvars
  758.         (lambda ()
  759.           (set! allvars
  760.             (append (mapcar (lambda (a) (if (symbol? a) a (car a)))
  761.                     classvars)
  762.                 (mapcar (lambda (a) (if (symbol? a) a (car a)))
  763.                     instvars)))))
  764.  
  765.  
  766.        (chk-option
  767.         (lambda (opt-list)
  768.           (let loop ((opl opt-list)(meths '()))
  769.         (if opl
  770.             (loop
  771.              (cdr opl)
  772.              (cond ((eq? (caar opl) 'gettable-variables)
  773.                 (append (generate-get (cdar opl)) meths))
  774.                ((eq? (caar opl) 'settable-variables)
  775.                 (append (generate-set (cdar opl)) meths))
  776.                ((eq? (caar opl) 'inittable-variables)
  777.                 (set! inits (cdar opl)) meths)
  778.                (else (error-handler (car opl) 1 '()))))
  779.             meths))))
  780.  
  781.        (chk-cvs
  782.         (lambda (list-var)
  783.           (mapcar
  784.            (lambda (a)
  785.          (if (symbol? a)
  786.              (list a #!false)
  787.              a))
  788.            list-var)))
  789.  
  790.        (chk-init
  791.         (lambda (v-form)
  792.           (if (memq (car v-form) inits)
  793.           `(,(car v-form)
  794.             (let ((temp (memq ',(car v-form) %sc-init-vals)))
  795.                     ;was '%sc-init-vals
  796.               (if temp (cadr temp)
  797.               ,(cadr v-form))))
  798.           v-form)))
  799.  
  800.        (chk-ivs
  801.         (lambda (list-var)
  802.           (mapcar
  803.            (lambda (var)
  804.          (chk-init
  805.           (cond ((symbol? var) (list var #!false))
  806.                         ((not-active? (cadr var)) var)
  807.                         (else (active-val (car var) (cadr var))))))
  808.            list-var)))
  809.  
  810.        (not-active?
  811.         (lambda (a)
  812.           (or (not (pair? a))
  813.           (not (eq? (car a) 'active)))))
  814.  
  815.        (empty-slot?
  816.         (lambda (form)
  817.           (cond
  818.            ((symbol? form) #f)
  819.            ((eq? form #f) #t)
  820.            (else #f))))
  821.  
  822.        (active-val
  823.         (lambda (var active-form)
  824.           (let loop ((var var)(active-form active-form)
  825.                   (getfns '())(setfns '%sc-val))
  826.         (if (not-active? (cadr active-form))
  827.             (create-active
  828.              var
  829.              (if (empty-slot? (caddr active-form))
  830.              getfns
  831.              (cons (caddr active-form) getfns))
  832.              (list 'set! var
  833.                (if (empty-slot? (cadddr active-form))
  834.                    setfns
  835.                    (list (cadddr active-form) setfns)))
  836.              (cadr active-form))
  837.             (loop
  838.              var
  839.              (cadr active-form)
  840.              (if (empty-slot? (caddr active-form))
  841.              getfns
  842.              (cons (caddr active-form) getfns))
  843.              (if (empty-slot? (cadddr active-form))
  844.              setfns
  845.              (list (cadddr active-form) setfns)))))))
  846.  
  847.        (create-active
  848.         (lambda (var getfns setfns localstate)
  849.           (begin
  850.         (set! method-values
  851.               (cons `(CONS ',(concat "GET-" var)
  852.                    (list 'lambda '() ',(expand-getfns var getfns)))
  853.                 (cons `(CONS ',(concat "SET-" var)
  854.                      (list 'lambda (list '%sc-val)
  855.                            ',setfns))
  856.                   method-values)))
  857.         (list var localstate))))
  858.  
  859.        (expand-getfns
  860.         (lambda (var getfns)
  861.           (let loop ((var var)(gets getfns)(exp-form var))
  862.         (if gets
  863.             (loop
  864.              var
  865.              (cdr gets)
  866.              (list (car gets) exp-form))
  867.             exp-form))))
  868.        (concat
  869.         (lambda (str sym)
  870.           (string->symbol (string-append str (symbol->string sym)))))
  871.  
  872.        (generate-get
  873.         (lambda (getlist)
  874.           (mapcar
  875.            (lambda (a)
  876.          `(CONS ',(concat "GET-" a)
  877.             (list 'lambda '()
  878.                   ',a)))
  879.            getlist)))
  880.  
  881.        (generate-set
  882.         (lambda (setlist)
  883.           (mapcar
  884.            (lambda (a)
  885.          `(CONS ',(concat "SET-" a)
  886.             (list 'lambda (list '%sc-val)
  887.                   (list 'set! ',a '%sc-val))))
  888.            setlist)))
  889.  
  890.        )
  891.  
  892. ;; define-class begins here.
  893.  
  894.     (begin
  895.       (chk-class-def (cdr e))
  896.       (set! method-values
  897.         (chk-option
  898.          (mapcar (lambda (a) (if (symbol? a) (cons a allvars) a))
  899.              options)))
  900.       (set! instvars (if instvars (chk-ivs instvars)))
  901. ;; Evaluate here so that active-value functions are generated properly.
  902. ;; --Steve Sherin
  903.       (set! classvars (if classvars (chk-cvs classvars)))
  904.  
  905.       (eval
  906.        `(DEFINE ,name
  907.           (%SC-MAKE-CLASS
  908.            ',name
  909.            ',classvars
  910.            ',instvars
  911.            ',mixins
  912.            ,(if method-values (cons 'list method-values))
  913.            ))
  914.        user-initial-environment)
  915.       )))))
  916. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  917. ;;;                                                                 ;;;
  918. ;;;                     S c o o p s                                 ;;;
  919. ;;;                                                                 ;;;
  920. ;;;                                                                 ;;;
  921. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  922. ;;;        by Steve Sherin--U of P                    ;;;
  923. ;;;                   File : send.scm                               ;;;
  924. ;;;                                                                 ;;;
  925. ;;;                 Amitabh Srivastava                              ;;;
  926. ;;;                                                                 ;;;
  927. ;;;-----------------------------------------------------------------;;;
  928. ;;;    One does not have to use the SEND form to invoke methods     ;;;
  929. ;;;    in the same class; they can be invoked as Scheme functions.  ;;;
  930. ;;;                                                                 ;;;
  931. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  932.  
  933. ;;; SEND
  934. (syntax-table-define system-global-syntax-table 'SEND
  935.   (macro e
  936.  
  937.     (let ((args (cddr e))
  938.       (msg (cadr e))
  939.       (obj (car e)))
  940.       `(let* ((set-parent! (access system-environment-set-parent!
  941.                    environment-package))
  942.           (ep environment-parent)
  943.           (ibot ,obj)
  944.           (itop (ep (ep ibot)))
  945.           (ipar (ep itop))
  946.           (class (access %sc-class ibot))
  947.           (ctop (%sc-class-env class))
  948.           (cpar (ep ctop))
  949.           (cbot (%sc-method-env class))
  950.           (instance-safe? (eq? ipar cbot)))
  951.  
  952.      (without-interrupts
  953.       (lambda ()
  954.         (dynamic-wind
  955.          (lambda ()
  956.            (set-parent! ctop ibot)
  957.            (if instance-safe?
  958.            (set-parent! itop cpar)))
  959.  
  960.  
  961.          (lambda ()
  962.            (in-package cbot (,msg ,@args)))
  963.  
  964.          (lambda ()
  965.            (set-parent! ctop cpar)
  966.            (set-parent! itop cbot))
  967.          )))))))
  968.  
  969.  
  970. ;;; SEND-IF-HANDLES
  971. (syntax-table-define system-global-syntax-table 'SEND-IF-HANDLES
  972.   (macro e
  973.     (let ((obj (car e))
  974.       (msg (cadr e))
  975.       (args (cddr e)))
  976.       `(let
  977.        ((self ,obj))
  978.  
  979.      (if (assq ',msg (%sc-method-structure (access %sc-class self)))
  980.          (send self ,msg ,@args)
  981.          #!false)))))
  982.  
  983.  
  984.  
  985. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  986. ;;;                                                                 ;;;
  987. ;;;                     S c o o p s                                 ;;;
  988. ;;;                                                                 ;;;
  989. ;;;                                                                 ;;;
  990. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  991. ;;;        by Steve Sherin--U of P                    ;;;
  992. ;;;                   File : utl.scm                                ;;;
  993. ;;;                                                                 ;;;
  994. ;;;                 Amitabh Srivastava                              ;;;
  995. ;;;                                                                 ;;;
  996. ;;;    This file contains misc. routines                            ;;;
  997. ;;;                                                                 ;;;
  998. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  999.  
  1000.  
  1001. ;;;   Error handler. Looks up the error message in the table and
  1002. ;;;   prints it.
  1003.  
  1004. (define error-handler
  1005.   (let ((error-table
  1006.      (let ((table (make-vector 8)))
  1007.        (vector-set! table 0 " Invalid class definition ")
  1008.        (vector-set! table 1 " Invalid option ")
  1009.        (vector-set! table 2 " Class not defined ")
  1010.        (vector-set! table 3 " Method has been deleted ")
  1011.        (vector-set! table 4 " Method is not present ")
  1012.        (vector-set! table 5 " Variable is not present")
  1013.        (vector-set! table 6 " Not a Scoops Class")
  1014.        (vector-set! table 7 " Class not compiled ")
  1015.        table)))
  1016.     (lambda (msg number flag)
  1017.       (if flag
  1018.           (error (vector-ref error-table number) msg)
  1019.           (breakpoint (vector-ref error-table number) msg)))))
  1020.  
  1021.  
  1022. ;;;   some functions defined globally which will be moved locally later
  1023.  
  1024.         (define %sc-class-description
  1025.            (lambda (class)
  1026.               (writeln " ")
  1027.               (writeln "    CLASS DESCRIPTION    ")
  1028.               (writeln "    ==================    ")
  1029.               (writeln " ")
  1030.               (writeln " NAME            : " (%sc-name class))
  1031.               (writeln " CLASS VARS      : "
  1032.                        (mapcar car (%sc-allcvs class)))
  1033.               (writeln " INSTANCE VARS   : "
  1034.                        (mapcar car (%sc-allivs class)))
  1035.               (writeln " METHODS         : "
  1036.                        (mapcar car (%sc-method-structure class)))
  1037.               (writeln " MIXINS          : " (%sc-mixins class))
  1038.               (writeln " CLASS COMPILED  : " (%sc-class-compiled class))
  1039.               (writeln " CLASS INHERITED : " (%sc-class-inherited class))
  1040.            ))
  1041. ;;;
  1042.  
  1043.     (define %sc-inst-desc
  1044.        (lambda (inst)
  1045.          (letrec ((class (access %sc-class inst))
  1046.                   (printvars
  1047.                     (lambda (f1 f2)
  1048.               (if f1            ; another var
  1049.               (begin
  1050.                (writeln "   " (caar f1) " : "
  1051.                 (cadr (assq (caar f1) f2)))
  1052. ;; environment bindings in list form vs. pair form.  Steve Sherin
  1053.                (printvars (cdr f1) f2))
  1054.                 *the-non-printing-object*))))
  1055.             (writeln " ")
  1056.         (writeln "  INSTANCE DESCRIPTION      ")
  1057.         (writeln "  ====================      ")
  1058.         (writeln " ")
  1059.          (writeln "  Instance of Class :  " (%sc-name class))
  1060.         (writeln " ")
  1061.         (writeln "  Class Variables : ")
  1062.             (printvars (%sc-allcvs class)
  1063.                (environment-bindings (%sc-class-env class)))
  1064.             (writeln " ")
  1065.         (writeln "  Instance Variables :")
  1066.             (printvars (%sc-allivs class) (environment-bindings inst))
  1067.            )))
  1068.  
  1069. ;;;
  1070. (define %scoops-chk-class-compiled
  1071.   (lambda (name class)
  1072.     (or (%sc-class-compiled class)
  1073.         (error-handler name 7 #!true))))
  1074.  
  1075. ;;;
  1076. (define %sc-class-info
  1077.   (lambda (fn)
  1078.     (lambda (class)
  1079.       (%scoops-chk-class class)
  1080.       (mapcar car (fn class)))))
  1081.  
  1082. ;;; ALL-CLASSVARS
  1083. (set! all-classvars (%sc-class-info %sc-allcvs))
  1084.  
  1085. ;;; ALL-INSTVARS
  1086. (set! all-instvars (%sc-class-info %sc-allivs))
  1087.  
  1088. ;;; ALL-METHODS
  1089. (set! all-methods (%sc-class-info %sc-method-structure))
  1090.  
  1091. ;;; (CLASS-COMPILED? CLASS)
  1092. (set! class-compiled?
  1093.   (lambda (class)
  1094.     (%scoops-chk-class class)
  1095.     (%sc-class-compiled class)))
  1096.  
  1097. ;;; (CLASS-OF-OBJECT OBJECT)
  1098. (syntax-table-define system-global-syntax-table 'CLASS-OF-OBJECT
  1099.   (macro e
  1100.     `(%sc-name (access %sc-class ,(car e)))))
  1101.  
  1102. ;;; CLASSVARS
  1103. (set! classvars (%sc-class-info %sc-cv))
  1104.  
  1105. ;;; DESCRIBE
  1106. (set! describe
  1107.   (lambda (class-inst)
  1108.     (if (vector? class-inst)
  1109.         (begin
  1110.           (%scoops-chk-class class-inst)
  1111.           (%sc-class-description class-inst))
  1112.         (%sc-inst-desc class-inst))))
  1113.  
  1114. ;;; (GETCV CLASS VAR)
  1115. (syntax-table-define system-global-syntax-table 'GETCV 
  1116.   (macro e
  1117.     (let ((class (car e))
  1118.       (var (cadr e)))
  1119.       `(begin
  1120.          (and (%sc-name->class ',class)
  1121.               (%scoops-chk-class-compiled ',class ,class))
  1122.      ((access ,(%sc-concat "GET-" var) (%sc-method-env ,class)))))))
  1123.  
  1124. ;;; INSTVARS
  1125. (set! instvars (%sc-class-info %sc-iv))
  1126.  
  1127. ;;; METHODS
  1128. (set! methods (%sc-class-info %sc-method-values))
  1129.  
  1130. ;;; MIXINS
  1131. (set! mixins
  1132.   (lambda (class)
  1133.     (%scoops-chk-class class)
  1134.     (%sc-mixins class)))
  1135.  
  1136. ;;; (NAME->CLASS NAME)
  1137. (syntax-table-define system-global-syntax-table 'NAME->CLASS
  1138.   (macro e
  1139.     `(%sc-name->class ,(car e))))
  1140.  
  1141. ;;; (RENAME-CLASS (CLASS NEW-NAME))
  1142. (syntax-table-define system-global-syntax-table 'RENAME-CLASS
  1143.   (macro e
  1144.     (let ((class (caar e))
  1145.       (new-name (cadar e)))
  1146.       `(begin
  1147.      (%sc-name->class ',class)
  1148.      (%sc-set-name ,class ',new-name)
  1149.      (eval (define ,new-name ,class) user-initial-environment)
  1150.      ',new-name))))
  1151.  
  1152. ;;; (SETCV CLASS VAR VAL)
  1153. (syntax-table-define system-global-syntax-table 'SETCV
  1154.   (macro e
  1155.     (let ((class (car e))
  1156.       (var (cadr e))
  1157.       (val (caddr e)))
  1158.       `(begin
  1159.          (and (%sc-name->class ',class)
  1160.               (%scoops-chk-class-compiled ',class ,class))
  1161.      ((access ,(%sc-concat "SET-" var) (%sc-method-env ,class)) ,val)))))
  1162.  
  1163. ;; end scoops-package environment
  1164. ))
  1165.  
  1166.