-
Notifications
You must be signed in to change notification settings - Fork 0
/
defcombin.lisp
403 lines (371 loc) · 14.3 KB
/
defcombin.lisp
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
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; This software is derived from software originally released by Xerox
;;;; Corporation. Copyright and release statements follow. Later modifications
;;;; to the software are in the public domain and are provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for more
;;;; information.
;;;; copyright information from original PCL sources:
;;;;
;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;;; All rights reserved.
;;;;
;;;; Use and copying of this software and preparation of derivative works based
;;;; upon this software are permitted. Any distribution of this software or
;;;; derivative works must comply with all applicable United States export
;;;; control laws.
;;;;
;;;; This software is made available AS IS, and Xerox Corporation makes no
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
(in-package "SB-PCL")
(defmacro define-method-combination (&whole form &rest args)
(declare (ignore args))
(if (and (cddr form)
(listp (caddr form)))
(expand-long-defcombin form)
(expand-short-defcombin form)))
;;;; standard method combination
;;; The STANDARD method combination type is implemented directly by
;;; the class STANDARD-METHOD-COMBINATION. The method on
;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
;;; and is defined by hand in the file combin.lisp. The method for
;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
;;; reasons.
(defmethod find-method-combination ((generic-function generic-function)
(type (eql 'standard))
options)
(when options
(method-combination-error
"The method combination type STANDARD accepts no options."))
*standard-method-combination*)
;;;; short method combinations
;;;;
;;;; Short method combinations all follow the same rule for computing the
;;;; effective method. So, we just implement that rule once. Each short
;;;; method combination object just reads the parameters out of the object
;;;; and runs the same rule.
(defclass short-method-combination (standard-method-combination)
((operator
:reader short-combination-operator
:initarg :operator)
(identity-with-one-argument
:reader short-combination-identity-with-one-argument
:initarg :identity-with-one-argument))
(:predicate-name short-method-combination-p))
(defun expand-short-defcombin (whole)
(let* ((type (cadr whole))
(documentation
(getf (cddr whole) :documentation ""))
(identity-with-one-arg
(getf (cddr whole) :identity-with-one-argument nil))
(operator
(getf (cddr whole) :operator type)))
`(load-short-defcombin
',type ',operator ',identity-with-one-arg ',documentation)))
(defun load-short-defcombin (type operator ioa doc)
(let* ((truename *load-truename*)
(specializers
(list (find-class 'generic-function)
(intern-eql-specializer type)
*the-class-t*))
(old-method
(get-method #'find-method-combination () specializers nil))
(new-method nil))
(setq new-method
(make-instance 'standard-method
:qualifiers ()
:specializers specializers
:lambda-list '(generic-function type options)
:function (lambda (args nms &rest cm-args)
(declare (ignore nms cm-args))
(apply
(lambda (gf type options)
(declare (ignore gf))
(short-combine-methods
type options operator ioa new-method doc))
args))
:definition-source `((define-method-combination ,type) ,truename)))
(when old-method
(remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)))
(defun short-combine-methods (type options operator ioa method doc)
(cond ((null options) (setq options '(:most-specific-first)))
((equal options '(:most-specific-first)))
((equal options '(:most-specific-last)))
(t
(method-combination-error
"Illegal options to a short method combination type.~%~
The method combination type ~S accepts one option which~%~
must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
type)))
(make-instance 'short-method-combination
:type type
:options options
:operator operator
:identity-with-one-argument ioa
:definition-source method
:documentation doc))
(defmethod compute-effective-method ((generic-function generic-function)
(combin short-method-combination)
applicable-methods)
(let ((type (method-combination-type combin))
(operator (short-combination-operator combin))
(ioa (short-combination-identity-with-one-argument combin))
(order (car (method-combination-options combin)))
(around ())
(primary ()))
(dolist (m applicable-methods)
(let ((qualifiers (method-qualifiers m)))
(flet ((lose (method why)
(invalid-method-error
method
"The method ~S ~A.~%~
The method combination type ~S was defined with the~%~
short form of DEFINE-METHOD-COMBINATION and so requires~%~
all methods have either the single qualifier ~S or the~%~
single qualifier :AROUND."
method why type type)))
(cond ((null qualifiers)
(lose m "has no qualifiers"))
((cdr qualifiers)
(lose m "has more than one qualifier"))
((eq (car qualifiers) :around)
(push m around))
((eq (car qualifiers) type)
(push m primary))
(t
(lose m "has an illegal qualifier"))))))
(setq around (nreverse around))
(ecase order
(:most-specific-last) ; nothing to be done, already in correct order
(:most-specific-first
(setq primary (nreverse primary))))
(let ((main-method
(if (and (null (cdr primary))
(not (null ioa)))
`(call-method ,(car primary) ())
`(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
primary)))))
(cond ((null primary)
`(error "No ~S methods for the generic function ~S."
',type ',generic-function))
((null around) main-method)
(t
`(call-method ,(car around)
(,@(cdr around) (make-method ,main-method))))))))
;;;; long method combinations
(defclass long-method-combination (standard-method-combination)
((function :initarg :function
:reader long-method-combination-function)))
(defun expand-long-defcombin (form)
(let ((type (cadr form))
(lambda-list (caddr form))
(method-group-specifiers (cadddr form))
(body (cddddr form))
(args-option ())
(gf-var nil))
(when (and (consp (car body)) (eq (caar body) :arguments))
(setq args-option (cdr (pop body))))
(when (and (consp (car body)) (eq (caar body) :generic-function))
(setq gf-var (cadr (pop body))))
(multiple-value-bind (documentation function)
(make-long-method-combination-function
type lambda-list method-group-specifiers args-option gf-var
body)
`(load-long-defcombin ',type ',documentation #',function))))
(defvar *long-method-combination-functions* (make-hash-table :test 'eq))
(defun load-long-defcombin (type doc function)
(let* ((specializers
(list (find-class 'generic-function)
(intern-eql-specializer type)
*the-class-t*))
(old-method
(get-method #'find-method-combination () specializers nil))
(new-method
(make-instance 'standard-method
:qualifiers ()
:specializers specializers
:lambda-list '(generic-function type options)
:function (lambda (args nms &rest cm-args)
(declare (ignore nms cm-args))
(apply
(lambda (generic-function type options)
(declare (ignore generic-function options))
(make-instance 'long-method-combination
:type type
:documentation doc))
args))
:definition-source `((define-method-combination ,type)
,*load-truename*))))
(setf (gethash type *long-method-combination-functions*) function)
(when old-method (remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)))
(defmethod compute-effective-method ((generic-function generic-function)
(combin long-method-combination)
applicable-methods)
(funcall (gethash (method-combination-type combin)
*long-method-combination-functions*)
generic-function
combin
applicable-methods))
(defun make-long-method-combination-function
(type ll method-group-specifiers args-option gf-var body)
;;(declare (values documentation function))
(declare (ignore type))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations body)
(let ((wrapped-body
(wrap-method-group-specifier-bindings method-group-specifiers
declarations
real-body)))
(when gf-var
(push `(,gf-var .generic-function.) (cadr wrapped-body)))
(when args-option
(setq wrapped-body (deal-with-args-option wrapped-body args-option)))
(when ll
(setq wrapped-body
`(apply #'(lambda ,ll ,wrapped-body)
(method-combination-options .method-combination.))))
(values
documentation
`(lambda (.generic-function. .method-combination. .applicable-methods.)
(progn .generic-function. .method-combination. .applicable-methods.)
(block .long-method-combination-function. ,wrapped-body))))))
;; parse-method-group-specifiers parse the method-group-specifiers
(defun wrap-method-group-specifier-bindings
(method-group-specifiers declarations real-body)
(let (names
specializer-caches
cond-clauses
required-checks
order-cleanups)
(dolist (method-group-specifier method-group-specifiers)
(multiple-value-bind (name tests description order required)
(parse-method-group-specifier method-group-specifier)
(declare (ignore description))
(let ((specializer-cache (gensym)))
(push name names)
(push specializer-cache specializer-caches)
(push `((or ,@tests)
(if (equal ,specializer-cache .specializers.)
(return-from .long-method-combination-function.
'(error "More than one method of type ~S ~
with the same specializers."
',name))
(setq ,specializer-cache .specializers.))
(push .method. ,name))
cond-clauses)
(when required
(push `(when (null ,name)
(return-from .long-method-combination-function.
'(error "No ~S methods." ',name)))
required-checks))
(loop (unless (and (constantp order)
(neq order (setq order (eval order))))
(return t)))
(push (cond ((eq order :most-specific-first)
`(setq ,name (nreverse ,name)))
((eq order :most-specific-last) ())
(t
`(ecase ,order
(:most-specific-first
(setq ,name (nreverse ,name)))
(:most-specific-last))))
order-cleanups))))
`(let (,@(nreverse names) ,@(nreverse specializer-caches))
,@declarations
(dolist (.method. .applicable-methods.)
(let ((.qualifiers. (method-qualifiers .method.))
(.specializers. (method-specializers .method.)))
(progn .qualifiers. .specializers.)
(cond ,@(nreverse cond-clauses))))
,@(nreverse required-checks)
,@(nreverse order-cleanups)
,@real-body)))
(defun parse-method-group-specifier (method-group-specifier)
;;(declare (values name tests description order required))
(let* ((name (pop method-group-specifier))
(patterns ())
(tests
(let (collect)
(block collect-tests
(loop
(if (or (null method-group-specifier)
(memq (car method-group-specifier)
'(:description :order :required)))
(return-from collect-tests t)
(let ((pattern (pop method-group-specifier)))
(push pattern patterns)
(push (parse-qualifier-pattern name pattern)
collect)))))
(nreverse collect))))
(values name
tests
(getf method-group-specifier :description
(make-default-method-group-description patterns))
(getf method-group-specifier :order :most-specific-first)
(getf method-group-specifier :required nil))))
(defun parse-qualifier-pattern (name pattern)
(cond ((eq pattern '()) `(null .qualifiers.))
((eq pattern '*) t)
((symbolp pattern) `(,pattern .qualifiers.))
((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
(t (error "In the method group specifier ~S,~%~
~S isn't a valid qualifier pattern."
name pattern))))
(defun qualifier-check-runtime (pattern qualifiers)
(loop (cond ((and (null pattern) (null qualifiers))
(return t))
((eq pattern '*) (return t))
((and pattern qualifiers (eq (car pattern) (car qualifiers)))
(pop pattern)
(pop qualifiers))
(t (return nil)))))
(defun make-default-method-group-description (patterns)
(if (cdr patterns)
(format nil
"methods matching one of the patterns: ~{~S, ~} ~S"
(butlast patterns) (car (last patterns)))
(format nil
"methods matching the pattern: ~S"
(car patterns))))
;;; This baby is a complete mess. I can't believe we put it in this
;;; way. No doubt this is a large part of what drives MLY crazy.
;;;
;;; At runtime (when the effective-method is run), we bind an intercept
;;; lambda-list to the arguments to the generic function.
;;;
;;; At compute-effective-method time, the symbols in the :arguments
;;; option are bound to the symbols in the intercept lambda list.
(defun deal-with-args-option (wrapped-body args-option)
(let* ((intercept-lambda-list
(let (collect)
(dolist (arg args-option)
(if (memq arg lambda-list-keywords)
(push arg collect)
(push (gensym) collect)))
(nreverse collect)))
(intercept-rebindings
(loop for arg in args-option
for int in intercept-lambda-list
unless (memq arg lambda-list-keywords)
collect `(,arg ',int))))
(setf (cadr wrapped-body)
(append intercept-rebindings (cadr wrapped-body)))
;; Be sure to fill out the intercept lambda list so that it can
;; be too short if it wants to.
(cond ((memq '&rest intercept-lambda-list))
((memq '&allow-other-keys intercept-lambda-list))
((memq '&key intercept-lambda-list)
(setq intercept-lambda-list
(append intercept-lambda-list '(&allow-other-keys))))
(t
(setq intercept-lambda-list
(append intercept-lambda-list '(&rest .ignore.)))))
`(let ((inner-result. ,wrapped-body))
`(apply #'(lambda ,',intercept-lambda-list
,,(when (memq '.ignore. intercept-lambda-list)
''(declare (ignore .ignore.)))
,inner-result.)
.combined-method-args.))))