137 lines
5.0 KiB
Scheme
137 lines
5.0 KiB
Scheme
|
||
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; ;;;
|
||
;;; S c o o p s ;;;
|
||
;;; ;;;
|
||
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
|
||
;;; All Rights Reserved ;;;
|
||
;;; ;;;
|
||
;;; File updated : 8/29/85 ;;;
|
||
;;; ;;;
|
||
;;; File : methods.scm ;;;
|
||
;;; ;;;
|
||
;;; Amitabh Srivastava ;;;
|
||
;;; ;;;
|
||
;;; This file contains the adding of methods to classes ;;;
|
||
;;; ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
|
||
;;; is class1 before class2 in class ?
|
||
;;; class1 is not equal to class2
|
||
|
||
|
||
(define %before
|
||
(lambda (class1 class2 class)
|
||
(or (eq? class1 class)
|
||
(memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
|
||
|
||
;;;
|
||
|
||
(macro define-method
|
||
(lambda (e)
|
||
(let ((class-name (caadr e))
|
||
(method-name (cadr (cadr e)))
|
||
(formal-list (caddr e))
|
||
(body (cdddr e)))
|
||
(list '%sc-class-add-method
|
||
(list 'quote class-name)
|
||
(list 'quote method-name)
|
||
(list 'quote class-name)
|
||
(list 'quote class-name)
|
||
(%sc-expand
|
||
(cons 'lambda (cons formal-list body)))
|
||
(list 'lambda '(env val)
|
||
(list 'set! (list 'access method-name 'env) 'val))))))
|
||
|
||
|
||
|
||
;;;
|
||
|
||
(define %sc-class-add-method
|
||
(lambda (class-name method-name method-class mixin-class method assigner)
|
||
(let ((class (%sc-name->class class-name)))
|
||
(apply-if (assq method-name (%sc-method-values class))
|
||
(lambda (entry)
|
||
(set-cdr! entry method))
|
||
(%sc-set-method-values class
|
||
(cons (cons method-name method) (%sc-method-values class)))))
|
||
(%compiled-add-method class-name method-name method-class mixin-class
|
||
method assigner)))
|
||
|
||
|
||
;;;
|
||
|
||
(define %inform-subclasses
|
||
(lambda (class-name method-name method-class mixin-class method assigner)
|
||
((rec loop
|
||
(lambda (class-name method-name method-class mixin-class
|
||
method assigner subclass)
|
||
(if subclass
|
||
(begin
|
||
(%compiled-add-method
|
||
(car subclass) method-name method-class class-name
|
||
method assigner)
|
||
(loop class-name method-name method-class mixin-class
|
||
method assigner
|
||
(cdr subclass))))))
|
||
class-name method-name method-class mixin-class method assigner
|
||
(%sc-subclasses (%sc-name->class class-name)))))
|
||
|
||
|
||
;;;
|
||
|
||
(define %compiled-add-method
|
||
(lambda (class-name method-name method-class mixin-class method assigner)
|
||
(letrec
|
||
((class (%sc-name->class class-name))
|
||
|
||
(insert-entry
|
||
(lambda (previous current)
|
||
(cond ((null? current)
|
||
(set-cdr! previous
|
||
(cons (cons method-class mixin-class) '())))
|
||
((eq? mixin-class (cdar current))
|
||
(set-car! (car current) method-class))
|
||
((%before mixin-class (cdar current)
|
||
class-name)
|
||
(set-cdr! previous
|
||
(cons (cons method-class mixin-class) current)))
|
||
(else '()))))
|
||
|
||
|
||
(loop-insert
|
||
(lambda (previous current)
|
||
(if (not (insert-entry previous current))
|
||
(loop-insert (current) (cdr current)))))
|
||
|
||
(insert
|
||
(lambda (entry)
|
||
(if (insert-entry entry (cdr entry)) ;;; insert at head
|
||
(add-to-environment)
|
||
(loop-insert (cdr entry) (cddr entry)))))
|
||
|
||
(add-to-environment
|
||
(lambda ()
|
||
(if (%sc-class-compiled class)
|
||
(assigner (%sc-method-env class) method))
|
||
(if (%sc-subclasses class)
|
||
(%inform-subclasses class-name method-name method-class
|
||
mixin-class method assigner))))
|
||
|
||
(add-entry
|
||
(lambda ()
|
||
(%sc-set-method-structure class
|
||
(cons (list method-name (cons method-class mixin-class))
|
||
(%sc-method-structure class)))
|
||
(add-to-environment)))
|
||
)
|
||
|
||
(let ((method-entry (assq method-name (%sc-method-structure class))))
|
||
(if method-entry
|
||
(insert method-entry)
|
||
(add-entry))
|
||
method-name))))
|