3
;;; A simple `OOPS' package
10
(define instance-size 3)
12
;;; Classes and instances are represented as vectors. The first
13
;;; two slots (tag and class-name) are common to classes and instances.
15
(define (tag v) (vector-ref v 0))
16
(define (set-tag! v t) (vector-set! v 0 t))
18
(define (class-name v) (vector-ref v 1))
19
(define (set-class-name! v n) (vector-set! v 1 n))
21
(define (class-instance-vars c) (vector-ref c 2))
22
(define (set-class-instance-vars! c v) (vector-set! c 2 v))
24
(define (class-env c) (vector-ref c 3))
25
(define (set-class-env! c e) (vector-set! c 3 e))
27
(define (class-super c) (vector-ref c 4))
28
(define (set-class-super! c s) (vector-set! c 4 s))
30
(define (instance-env i) (vector-ref i 2))
31
(define (set-instance-env! i e) (vector-set! i 2 e))
33
;;; Methods are bound in the class environment.
35
(define (method-known? method class)
36
(eval `(bound? ',method) (class-env class)))
38
(define (lookup-method method class)
39
(eval method (class-env class)))
42
(and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class)))
44
(define (check-class sym c)
46
(error sym "argument is not a class")))
49
(and (vector? i) (= (vector-length i) instance-size)
50
(eq? (tag i) 'instance)))
52
(define (check-instance sym i)
53
(if (not (instance? i))
54
(error sym "argument is not an instance")))
56
;;; Evaluate `body' within the scope of instance `i'.
58
(define-macro (with-instance i . body)
59
`(eval '(begin ,@body) (instance-env ,i)))
61
;;; Set a variable in an instance.
63
(define (instance-set! instance var val)
64
(eval `(set! ,var ',val) (instance-env instance)))
66
;;; Set a class variable when no instance is available.
68
(define (class-set! class var val)
69
(eval `(set! ,var ',val) (class-env class)))
71
;;; Convert a class variable spec into a binding suitable for a `let'.
73
(define (make-binding var)
75
(list var '()) ; No initializer given; use ()
76
var)) ; Initializer has been specified; leave alone
78
;;; Check whether the elements of `vars' are either a symbol or
79
;;; of the form (symbol initializer).
81
(define (check-vars vars)
82
(if (not (null? vars))
83
(if (not (or (symbol? (car vars))
84
(and (pair? (car vars)) (= (length (car vars)) 2)
85
(symbol? (caar vars)))))
86
(error 'define-class "bad variable spec: ~s" (car vars))
87
(check-vars (cdr vars)))))
89
;;; Check whether the class var spec `v' is already a member of
90
;;; the list `l'. If this is the case, check whether the initializers
93
(define (find-matching-var l v)
96
((eq? (caar l) (car v))
97
(if (not (equal? (cdar l) (cdr v)))
98
(error 'define-class "initializer mismatch: ~s and ~s"
101
(else (find-matching-var (cdr l) v))))
103
;;; Same as above, but don't check initializer.
105
(define (find-var l v)
108
((eq? (caar l) (car v)) #t)
109
(else (find-var (cdr l) v))))
111
;;; Create a new list of class var specs by discarding all variables
112
;;; from `b' that are already a member of `a' (with identical initializers).
114
(define (join-vars a b)
117
((find-matching-var a (car b)) (join-vars a (cdr b)))
118
(else (join-vars (cons (car b) a) (cdr b)))))
120
;;; The syntax is as follows:
121
;;; (define-class class-name . options)
122
;;; options are: (super-class class-name)
123
;;; (class-vars . var-specs)
124
;;; (instance-vars . var-specs)
125
;;; each var-spec is either a symbol or (symbol initializer).
127
(define-macro (define-class name . args)
128
(let ((class-vars) (instance-vars (list (make-binding 'self)))
129
(super) (super-class-env))
130
(do ((a args (cdr a))) ((null? a))
132
((not (pair? (car a)))
133
(error 'define-class "bad argument: ~s" (car a)))
134
((eq? (caar a) 'class-vars)
135
(check-vars (cdar a))
136
(set! class-vars (cdar a)))
137
((eq? (caar a) 'instance-vars)
138
(check-vars (cdar a))
139
(set! instance-vars (append instance-vars
140
(map make-binding (cdar a)))))
141
((eq? (caar a) 'super-class)
142
(if (> (length (cdar a)) 1)
143
(error 'define-class "only one super-class allowed"))
144
(set! super (cadar a)))
146
(error 'define-class "bad keyword: ~s" (caar a)))))
147
(if (not (null? super))
148
(let ((class (eval super)))
149
(set! super-class-env (class-env class))
150
(set! instance-vars (join-vars (class-instance-vars class)
152
(set! super-class-env (the-environment)))
154
(let ((c (make-vector class-size '())))
156
(set-class-name! c ',name)
157
(set-class-instance-vars! c ',instance-vars)
158
(set-class-env! c (eval `(let* ,(map make-binding ',class-vars)
161
(set-class-super! c ',super)
164
(define-macro (define-method class lambda-list . body)
165
(if (not (pair? lambda-list))
166
(error 'define-method "bad lambda list"))
168
(check-class 'define-method ,class)
169
(let ((env (class-env ,class))
170
(method (car ',lambda-list))
171
(args (cdr ',lambda-list))
173
(eval `(define ,method (lambda ,args ,@forms)) env)
176
;;; All arguments of the form (instance-var init-value) are used
177
;;; to initialize the specified instance variable; then an
178
;;; initialize-instance message is sent with all remaining
181
(define-macro (make-instance class . args)
183
(check-class 'make-instance ,class)
184
(let* ((e (the-environment))
185
(i (make-vector instance-size #f))
186
(class-env (class-env ,class))
187
(instance-vars (class-instance-vars ,class)))
188
(set-tag! i 'instance)
189
(set-class-name! i ',class)
190
(set-instance-env! i (eval `(let* ,instance-vars (the-environment))
192
(eval `(set! self ',i) (instance-env i))
193
(init-instance ',args ,class i e)
196
(define (init-instance args class instance env)
198
(do ((a args (cdr a))) ((null? a))
199
(if (and (pair? (car a)) (= (length (car a)) 2)
200
(find-var (class-instance-vars class) (car a)))
201
(instance-set! instance (caar a) (eval (cadar a) env))
202
(set! other-args (cons (eval (car a) env) other-args))))
203
(call-init-methods class instance (reverse! other-args))))
205
;;; Call all initialize-instance methods in super-class to sub-class
206
;;; order in the environment of `instance' with arguments `args'.
208
(define (call-init-methods class instance args)
210
(let loop ((class class))
211
(if (not (null? (class-super class)))
212
(loop (eval (class-super class))))
213
(if (method-known? 'initialize-instance class)
214
(let ((method (lookup-method 'initialize-instance class)))
215
(if (not (memq method called))
217
(apply (hack-procedure-environment!
218
method (instance-env instance))
220
(set! called (cons method called)))))))))
222
(define (send instance msg . args)
223
(check-instance 'send instance)
224
(let ((class (eval (class-name instance))))
225
(if (not (method-known? msg class))
226
(error 'send "message not understood: ~s" `(,msg ,@args))
227
(apply (hack-procedure-environment! (lookup-method msg class)
228
(instance-env instance))
231
;;; If the message is not understood, return #f. Otherwise return
232
;;; a list of one element, the result of the method.
234
(define (send-if-handles instance msg . args)
235
(check-instance 'send-if-handles instance)
236
(let ((class (eval (class-name instance))))
237
(if (not (method-known? msg class))
239
(list (apply (hack-procedure-environment! (lookup-method msg class)
240
(instance-env instance))
243
(define (describe-class c)
244
(check-class 'describe-class c)
245
(format #t "Class name: ~s~%" (class-name c))
246
(format #t "Superclass: ~s~%"
247
(if (not (null? (class-super c)))
250
(format #t "Instancevars: ")
251
(do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v))
254
(print (cons (caar v) (cadar v))))
255
(format #t "Classvars/Methods: ")
256
(define v (car (environment->list (class-env c))))
258
(do ((f v (cdr f)) (space #f #t)) ((null? f))
265
(define (describe-instance i)
266
(check-instance 'describe-instance i)
267
(format #t "Instance of: ~s~%" (class-name i))
268
(format #t "Instancevars: ")
269
(do ((f (car (environment->list (instance-env i))) (cdr f))
270
(space #f #t)) ((null? f))
added
removed
lib/lisp/oops.scm
