1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
;;; obj.scm version 4.0 5/18/2000
;;; -- implementation of the object-oriented syntax
;; By Matt Wright, based on a handout from MIT
;; Revised for STk by Brian Gaeke - removed scm and procedure->macro
;;; Utilities
;; MAKNAM: create a new symbol whose name is the concatenation of the
;; names of those in the symbol list SYMBOLS.
(define (maknam . symbols)
(string->symbol (apply string-append (map symbol->string symbols))))
;; ASK: send a message to an object
; The dot in the first line of the definition of ASK, below, makes it
; take a variable number of arguments. The first argument is associated
; with the formal parameter OBJECT; the second with MESSAGE; any extra
; actual arguments are put in a list, and that list is associated with
; the formal parameter ARGS. (If there are only two actual args, then
; ARGS will be the empty list.)
; APPLY takes two arguments, a procedure and a list, and applies the
; procedure to the things in the list, which are used as actual
; argument values.
(define (ask object message . args)
(let ((method (object message)))
(if (method? method)
(apply method args)
(error "No method " message " in class " (cadr method)))))
(define (no-method name)
(list 'no-method name))
(define (no-method? x)
(if (pair? x)
(eq? (car x) 'no-method)
#f))
(define (method? x)
(not (no-method? x)))
;; INSTANTIATE and INSTANTIATE-PARENT: Create an instance of a class
; The difference is that only INSTANTIATE initializes the new object
(define (instantiate class . arguments)
(let ((new-instance (apply (class 'instantiate) arguments)))
(ask new-instance 'initialize new-instance)
new-instance))
(define (instantiate-parent class . arguments)
(apply (class 'instantiate) arguments))
;; GET-METHOD: Send a message to several objects and return the first
;; method found (for multiple inheritance)
(define (get-method give-up-name message . objects)
(if (null? objects)
(no-method give-up-name)
(let ((method ((car objects) message)))
(if (method? method)
method
(apply get-method (cons give-up-name
(cons message (cdr objects)) ))))))
;; USUAL: Invoke a parent's method
;; Note: The 'send-usual-to-parent method is put in automatically by
;; define-class.
(define-macro (usual . args)
`(ask dispatch 'send-usual-to-parent . ,args))
;; DEFINE-CLASS: Create a new class.
; DEFINE-CLASS is a special form. When you type (define-class body...)
; it's as if you typed (make-definitions (quote body...)). In other
; words, the argument to DEFINE-CLASS isn't evaluated. This makes sense
; because the argument isn't Scheme syntax, but rather is the special
; object-oriented programming language we're defining.
; Make-definitions transforms the OOP notation into a standard Scheme
; expression, then uses EVAL to evaluate the result. (You'll see EVAL
; again in chapter 4 with the metacircular evaluator.)
; When you define a class named THING, for example, two global Scheme
; variables are created. The variable THING has as its value the
; procedure that represents the class. This procedure is invoked by
; INSTANTIATE to create instances of the class. A second variable,
; THING-DEFINITION, has as its value the text of the Scheme expression
; that defines THING. This text is used only by SHOW-CLASS, the
; procedure that lets you examine the result of the OOP-to-Scheme
; translation process.
(define-macro (define-class . body) (make-definitions body))
(define (make-definitions form)
(let ((definition (translate form)))
(eval `(define ,(maknam (class-name form) '-definition) ',definition))
(eval definition)
(list 'quote (class-name form))))
(define (show-class name)
(eval (maknam name '-definition)) )
; TRANSLATE does all the work of DEFINE-CLASS.
; The backquote operator (`) works just like regular quote (') except
; that expressions proceeded by a comma are evaluated. Also, expressions
; proceeded by ",@" evaluate to lists; the lists are inserted into the
; text without the outermost level of parentheses.
(define (translate form)
(cond ((null? form) (error "Define-class: empty body"))
((not (null? (obj-filter form (lambda (x) (not (pair? x))))))
(error "Each argument to define-class must be a list"))
((not (null? (extra-clauses form)))
(error "Unrecognized clause in define-class:" (extra-clauses form)))
(else
`(define ,(class-name form)
(let ,(class-var-bindings form)
(lambda (class-message)
(cond
,@(class-variable-methods form)
((eq? class-message 'instantiate)
(lambda ,(instantiation-vars form)
(let ((self '())
,@(parent-let-list form)
,@(instance-vars-let-list form))
(define (dispatch message)
(cond
,(init-clause form)
,(usual-clause form)
,@(method-clauses form)
,@(local-variable-methods form)
,(else-clause form) ))
dispatch )))
(else (error "Bad message to class" class-message)) )))))))
(define *legal-clauses*
'(instance-vars class-vars method default-method parent initialize))
(define (extra-clauses form)
(obj-filter (cdr form)
(lambda (x) (null? (member (car x) *legal-clauses*)))))
(define class-name caar)
(define (class-var-bindings form)
(let ((classvar-clause (find-a-clause 'class-vars form)))
(if (null? classvar-clause)
'()
(cdr classvar-clause) )))
(define instantiation-vars cdar)
(define (parent-let-list form)
(let ((parent-clause (find-a-clause 'parent form)))
(if (null? parent-clause)
'()
(map (lambda (parent-and-args)
(list (maknam 'my- (car parent-and-args))
(cons 'instantiate-parent parent-and-args)))
(cdr parent-clause)))))
(define (instance-vars-let-list form)
(let ((instance-vars-clause (find-a-clause 'instance-vars form)))
(if (null? instance-vars-clause)
'()
(cdr instance-vars-clause))))
(define (init-clause form)
(define (parent-initialization form)
(let ((parent-clause (find-a-clause 'parent form)))
(if (null? parent-clause)
'()
(map
(lambda (parent-and-args)
`(ask ,(maknam 'my- (car parent-and-args)) 'initialize self) )
(cdr parent-clause) ))))
(define (my-initialization form)
(let ((init-clause (find-a-clause 'initialize form)))
(if (null? init-clause) '()
(cdr init-clause))))
(define (init-body form)
(append (parent-initialization form)
(my-initialization form) ))
`((eq? message 'initialize)
(lambda (value-for-self)
(set! self value-for-self)
,@(init-body form) )))
(define (variable-list var-type form)
(let ((clause (find-a-clause var-type form)))
(if (null? clause)
'()
(map car (cdr clause)) )))
(define (class-variable-methods form)
(cons `((eq? class-message 'class-name) (lambda () ',(class-name form)))
(map (lambda (variable)
`((eq? class-message ',variable) (lambda () ,variable)))
(variable-list 'class-vars form))))
(define (local-variable-methods form)
(cons `((eq? message 'class-name) (lambda () ',(class-name form)))
(map (lambda (variable)
`((eq? message ',variable) (lambda () ,variable)))
(append (cdr (car form))
(variable-list 'instance-vars form)
(variable-list 'class-vars form)))))
(define (method-clauses form)
(map
(lambda (method-defn)
(let ((this-message (car (cadr method-defn)))
(args (cdr (cadr method-defn)))
(body (cddr method-defn)))
`((eq? message ',this-message)
(lambda ,args ,@body))))
(obj-filter (cdr form) (lambda (x) (eq? (car x) 'method))) ))
(define (parent-list form)
(let ((parent-clause (find-a-clause 'parent form)))
(if (null? parent-clause)
'()
(map (lambda (class) (maknam 'my- class))
(map car (cdr parent-clause))))))
(define (usual-clause form)
(let ((parent-clause (find-a-clause 'parent form)))
(if (null? parent-clause)
`((eq? message 'send-usual-to-parent)
(error "Can't use USUAL without a parent." ',(class-name form)))
`((eq? message 'send-usual-to-parent)
(lambda (message . args)
(let ((method (get-method ',(class-name form)
message
,@(parent-list form))))
(if (method? method)
(apply method args)
(error "No USUAL method" message ',(class-name form)) )))))))
(define (else-clause form)
(let ((parent-clause (find-a-clause 'parent form))
(default-method (find-a-clause 'default-method form)))
(cond
((and (null? parent-clause) (null? default-method))
`(else (no-method ',(class-name form))))
((null? parent-clause)
`(else (lambda args ,@(cdr default-method))))
((null? default-method)
`(else (get-method ',(class-name form) message ,@(parent-list form))) )
(else
`(else (let ((method (get-method ',(class-name form)
message
,@(parent-list form))))
(if (method? method)
method
(lambda args ,@(cdr default-method)) )))))))
(define (find-a-clause clause-name form)
(let ((clauses (obj-filter (cdr form)
(lambda (x) (eq? (car x) clause-name)))))
(cond ((null? clauses) '())
((null? (cdr clauses)) (car clauses))
(else (error "Error in define-class: too many "
clause-name "clauses.")) )))
(define (obj-filter l pred)
(cond ((null? l) '())
((pred (car l))
(cons (car l) (obj-filter (cdr l) pred)))
(else (obj-filter (cdr l) pred))))
(provide "obj")
|