275 lines
8.6 KiB
Scheme
275 lines
8.6 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; A simple `OOPS' package
|
|
|
|
(require 'hack.so)
|
|
|
|
(provide 'oops)
|
|
|
|
(define class-size 5)
|
|
(define instance-size 3)
|
|
|
|
;;; Classes and instances are represented as vectors. The first
|
|
;;; two slots (tag and class-name) are common to classes and instances.
|
|
|
|
(define (tag v) (vector-ref v 0))
|
|
(define (set-tag! v t) (vector-set! v 0 t))
|
|
|
|
(define (class-name v) (vector-ref v 1))
|
|
(define (set-class-name! v n) (vector-set! v 1 n))
|
|
|
|
(define (class-instance-vars c) (vector-ref c 2))
|
|
(define (set-class-instance-vars! c v) (vector-set! c 2 v))
|
|
|
|
(define (class-env c) (vector-ref c 3))
|
|
(define (set-class-env! c e) (vector-set! c 3 e))
|
|
|
|
(define (class-super c) (vector-ref c 4))
|
|
(define (set-class-super! c s) (vector-set! c 4 s))
|
|
|
|
(define (instance-env i) (vector-ref i 2))
|
|
(define (set-instance-env! i e) (vector-set! i 2 e))
|
|
|
|
;;; Methods are bound in the class environment.
|
|
|
|
(define (method-known? method class)
|
|
(eval `(bound? ',method) (class-env class)))
|
|
|
|
(define (lookup-method method class)
|
|
(eval method (class-env class)))
|
|
|
|
(define (class? c)
|
|
(and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class)))
|
|
|
|
(define (check-class sym c)
|
|
(if (not (class? c))
|
|
(error sym "argument is not a class")))
|
|
|
|
(define (instance? i)
|
|
(and (vector? i) (= (vector-length i) instance-size)
|
|
(eq? (tag i) 'instance)))
|
|
|
|
(define (check-instance sym i)
|
|
(if (not (instance? i))
|
|
(error sym "argument is not an instance")))
|
|
|
|
;;; Evaluate `body' within the scope of instance `i'.
|
|
|
|
(define-macro (with-instance i . body)
|
|
`(eval '(begin ,@body) (instance-env ,i)))
|
|
|
|
;;; Set a variable in an instance.
|
|
|
|
(define (instance-set! instance var val)
|
|
(eval `(set! ,var ',val) (instance-env instance)))
|
|
|
|
;;; Set a class variable when no instance is available.
|
|
|
|
(define (class-set! class var val)
|
|
(eval `(set! ,var ',val) (class-env class)))
|
|
|
|
;;; Convert a class variable spec into a binding suitable for a `let'.
|
|
|
|
(define (make-binding var)
|
|
(if (symbol? var)
|
|
(list var '()) ; No initializer given; use ()
|
|
var)) ; Initializer has been specified; leave alone
|
|
|
|
;;; Check whether the elements of `vars' are either a symbol or
|
|
;;; of the form (symbol initializer).
|
|
|
|
(define (check-vars vars)
|
|
(if (not (null? vars))
|
|
(if (not (or (symbol? (car vars))
|
|
(and (pair? (car vars)) (= (length (car vars)) 2)
|
|
(symbol? (caar vars)))))
|
|
(error 'define-class "bad variable spec: ~s" (car vars))
|
|
(check-vars (cdr vars)))))
|
|
|
|
;;; Check whether the class var spec `v' is already a member of
|
|
;;; the list `l'. If this is the case, check whether the initializers
|
|
;;; are identical.
|
|
|
|
(define (find-matching-var l v)
|
|
(cond
|
|
((null? l) #f)
|
|
((eq? (caar l) (car v))
|
|
(if (not (equal? (cdar l) (cdr v)))
|
|
(error 'define-class "initializer mismatch: ~s and ~s"
|
|
(car l) v)
|
|
#t))
|
|
(else (find-matching-var (cdr l) v))))
|
|
|
|
;;; Same as above, but don't check initializer.
|
|
|
|
(define (find-var l v)
|
|
(cond
|
|
((null? l) #f)
|
|
((eq? (caar l) (car v)) #t)
|
|
(else (find-var (cdr l) v))))
|
|
|
|
;;; Create a new list of class var specs by discarding all variables
|
|
;;; from `b' that are already a member of `a' (with identical initializers).
|
|
|
|
(define (join-vars a b)
|
|
(cond
|
|
((null? b) a)
|
|
((find-matching-var a (car b)) (join-vars a (cdr b)))
|
|
(else (join-vars (cons (car b) a) (cdr b)))))
|
|
|
|
;;; The syntax is as follows:
|
|
;;; (define-class class-name . options)
|
|
;;; options are: (super-class class-name)
|
|
;;; (class-vars . var-specs)
|
|
;;; (instance-vars . var-specs)
|
|
;;; each var-spec is either a symbol or (symbol initializer).
|
|
|
|
(define-macro (define-class name . args)
|
|
(let ((class-vars) (instance-vars (list (make-binding 'self)))
|
|
(super) (super-class-env))
|
|
(do ((a args (cdr a))) ((null? a))
|
|
(cond
|
|
((not (pair? (car a)))
|
|
(error 'define-class "bad argument: ~s" (car a)))
|
|
((eq? (caar a) 'class-vars)
|
|
(check-vars (cdar a))
|
|
(set! class-vars (cdar a)))
|
|
((eq? (caar a) 'instance-vars)
|
|
(check-vars (cdar a))
|
|
(set! instance-vars (append instance-vars
|
|
(map make-binding (cdar a)))))
|
|
((eq? (caar a) 'super-class)
|
|
(if (> (length (cdar a)) 1)
|
|
(error 'define-class "only one super-class allowed"))
|
|
(set! super (cadar a)))
|
|
(else
|
|
(error 'define-class "bad keyword: ~s" (caar a)))))
|
|
(if (not (null? super))
|
|
(let ((class (eval super)))
|
|
(set! super-class-env (class-env class))
|
|
(set! instance-vars (join-vars (class-instance-vars class)
|
|
instance-vars)))
|
|
(set! super-class-env (the-environment)))
|
|
`(define ,name
|
|
(let ((c (make-vector class-size '())))
|
|
(set-tag! c 'class)
|
|
(set-class-name! c ',name)
|
|
(set-class-instance-vars! c ',instance-vars)
|
|
(set-class-env! c (eval `(let* ,(map make-binding ',class-vars)
|
|
(the-environment))
|
|
,super-class-env))
|
|
(set-class-super! c ',super)
|
|
c))))
|
|
|
|
(define-macro (define-method class lambda-list . body)
|
|
(if (not (pair? lambda-list))
|
|
(error 'define-method "bad lambda list"))
|
|
`(begin
|
|
(check-class 'define-method ,class)
|
|
(let ((env (class-env ,class))
|
|
(method (car ',lambda-list))
|
|
(args (cdr ',lambda-list))
|
|
(forms ',body))
|
|
(eval `(define ,method (lambda ,args ,@forms)) env)
|
|
#v)))
|
|
|
|
;;; All arguments of the form (instance-var init-value) are used
|
|
;;; to initialize the specified instance variable; then an
|
|
;;; initialize-instance message is sent with all remaining
|
|
;;; arguments.
|
|
|
|
(define-macro (make-instance class . args)
|
|
`(begin
|
|
(check-class 'make-instance ,class)
|
|
(let* ((e (the-environment))
|
|
(i (make-vector instance-size #f))
|
|
(class-env (class-env ,class))
|
|
(instance-vars (class-instance-vars ,class)))
|
|
(set-tag! i 'instance)
|
|
(set-class-name! i ',class)
|
|
(set-instance-env! i (eval `(let* ,instance-vars (the-environment))
|
|
class-env))
|
|
(eval `(set! self ',i) (instance-env i))
|
|
(init-instance ',args ,class i e)
|
|
i)))
|
|
|
|
(define (init-instance args class instance env)
|
|
(let ((other-args))
|
|
(do ((a args (cdr a))) ((null? a))
|
|
(if (and (pair? (car a)) (= (length (car a)) 2)
|
|
(find-var (class-instance-vars class) (car a)))
|
|
(instance-set! instance (caar a) (eval (cadar a) env))
|
|
(set! other-args (cons (eval (car a) env) other-args))))
|
|
(call-init-methods class instance (reverse! other-args))))
|
|
|
|
;;; Call all initialize-instance methods in super-class to sub-class
|
|
;;; order in the environment of `instance' with arguments `args'.
|
|
|
|
(define (call-init-methods class instance args)
|
|
(let ((called '()))
|
|
(let loop ((class class))
|
|
(if (not (null? (class-super class)))
|
|
(loop (eval (class-super class))))
|
|
(if (method-known? 'initialize-instance class)
|
|
(let ((method (lookup-method 'initialize-instance class)))
|
|
(if (not (memq method called))
|
|
(begin
|
|
(apply (hack-procedure-environment!
|
|
method (instance-env instance))
|
|
args)
|
|
(set! called (cons method called)))))))))
|
|
|
|
(define (send instance msg . args)
|
|
(check-instance 'send instance)
|
|
(let ((class (eval (class-name instance))))
|
|
(if (not (method-known? msg class))
|
|
(error 'send "message not understood: ~s" `(,msg ,@args))
|
|
(apply (hack-procedure-environment! (lookup-method msg class)
|
|
(instance-env instance))
|
|
args))))
|
|
|
|
;;; If the message is not understood, return #f. Otherwise return
|
|
;;; a list of one element, the result of the method.
|
|
|
|
(define (send-if-handles instance msg . args)
|
|
(check-instance 'send-if-handles instance)
|
|
(let ((class (eval (class-name instance))))
|
|
(if (not (method-known? msg class))
|
|
#f
|
|
(list (apply (hack-procedure-environment! (lookup-method msg class)
|
|
(instance-env instance))
|
|
args)))))
|
|
|
|
(define (describe-class c)
|
|
(check-class 'describe-class c)
|
|
(format #t "Class name: ~s~%" (class-name c))
|
|
(format #t "Superclass: ~s~%"
|
|
(if (not (null? (class-super c)))
|
|
(class-super c)
|
|
'None))
|
|
(format #t "Instancevars: ")
|
|
(do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v))
|
|
(if space
|
|
(format #t " "))
|
|
(print (cons (caar v) (cadar v))))
|
|
(format #t "Classvars/Methods: ")
|
|
(define v (car (environment->list (class-env c))))
|
|
(if (not (null? v))
|
|
(do ((f v (cdr f)) (space #f #t)) ((null? f))
|
|
(if space
|
|
(format #t " "))
|
|
(print (car f)))
|
|
(print 'None))
|
|
#v)
|
|
|
|
(define (describe-instance i)
|
|
(check-instance 'describe-instance i)
|
|
(format #t "Instance of: ~s~%" (class-name i))
|
|
(format #t "Instancevars: ")
|
|
(do ((f (car (environment->list (instance-env i))) (cdr f))
|
|
(space #f #t)) ((null? f))
|
|
(if space
|
|
(format #t " "))
|
|
(print (car f)))
|
|
#v)
|