pcs/methods.scm

137 lines
5.0 KiB
Scheme
Raw Normal View History

2023-05-20 05:57:04 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; 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))))