21e886f2c8b8dc668690d8ca3142c93308106585
[sbcl.git] / src / pcl / defcombin.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (defmacro define-method-combination (&whole form &rest args)
27   (declare (ignore args))
28   `(progn
29      (with-single-package-locked-error
30          (:symbol ',(second form) "defining ~A as a method combination"))
31      ,(if (and (cddr form)
32                (listp (caddr form)))
33           (expand-long-defcombin form)
34           (expand-short-defcombin form))))
35 \f
36 ;;;; standard method combination
37
38 ;;; The STANDARD method combination type is implemented directly by
39 ;;; the class STANDARD-METHOD-COMBINATION. The method on
40 ;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
41 ;;; and is defined by hand in the file combin.lisp. The method for
42 ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
43 ;;; reasons.
44 (defmethod find-method-combination ((generic-function generic-function)
45                                     (type (eql 'standard))
46                                     options)
47   (when options
48     (method-combination-error
49       "The method combination type STANDARD accepts no options."))
50   *standard-method-combination*)
51 \f
52 ;;;; short method combinations
53 ;;;;
54 ;;;; Short method combinations all follow the same rule for computing the
55 ;;;; effective method. So, we just implement that rule once. Each short
56 ;;;; method combination object just reads the parameters out of the object
57 ;;;; and runs the same rule.
58
59 (defclass short-method-combination (standard-method-combination)
60   ((operator
61     :reader short-combination-operator
62     :initarg :operator)
63    (identity-with-one-argument
64     :reader short-combination-identity-with-one-argument
65     :initarg :identity-with-one-argument))
66   (:predicate-name short-method-combination-p))
67
68 (defun expand-short-defcombin (whole)
69   (let* ((type (cadr whole))
70          (documentation
71            (getf (cddr whole) :documentation))
72          (identity-with-one-arg
73            (getf (cddr whole) :identity-with-one-argument nil))
74          (operator
75            (getf (cddr whole) :operator type)))
76     `(load-short-defcombin
77      ',type ',operator ',identity-with-one-arg ',documentation
78       (sb-c:source-location))))
79
80 (defun load-short-defcombin (type operator ioa doc source-location)
81   (let* ((specializers
82            (list (find-class 'generic-function)
83                  (intern-eql-specializer type)
84                  *the-class-t*))
85          (old-method
86            (get-method #'find-method-combination () specializers nil))
87          (new-method nil))
88     (setq new-method
89           (make-instance 'standard-method
90             :qualifiers ()
91             :specializers specializers
92             :lambda-list '(generic-function type options)
93             :function (lambda (args nms &rest cm-args)
94                         (declare (ignore nms cm-args))
95                         (apply
96                          (lambda (gf type options)
97                            (declare (ignore gf))
98                            (short-combine-methods
99                             type options operator ioa new-method doc))
100                          args))
101             :definition-source source-location))
102     (when old-method
103       (remove-method #'find-method-combination old-method))
104     (add-method #'find-method-combination new-method)
105     (setf (random-documentation type 'method-combination) doc)
106     type))
107
108 (defun short-combine-methods (type options operator ioa method doc)
109   (cond ((null options) (setq options '(:most-specific-first)))
110         ((equal options '(:most-specific-first)))
111         ((equal options '(:most-specific-last)))
112         (t
113          (method-combination-error
114           "Illegal options to a short method combination type.~%~
115            The method combination type ~S accepts one option which~%~
116            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
117           type)))
118   (make-instance 'short-method-combination
119                  :type type
120                  :options options
121                  :operator operator
122                  :identity-with-one-argument ioa
123                  :definition-source method
124                  :documentation doc))
125
126 (defmethod compute-effective-method ((generic-function generic-function)
127                                      (combin short-method-combination)
128                                      applicable-methods)
129   (let ((type (method-combination-type combin))
130         (operator (short-combination-operator combin))
131         (ioa (short-combination-identity-with-one-argument combin))
132         (order (car (method-combination-options combin)))
133         (around ())
134         (primary ()))
135     (flet ((invalid (gf combin m)
136              (return-from compute-effective-method
137                `(%invalid-qualifiers ',gf ',combin ',m))))
138       (dolist (m applicable-methods)
139         (let ((qualifiers (method-qualifiers m)))
140           (cond ((null qualifiers) (invalid generic-function combin m))
141                 ((cdr qualifiers) (invalid generic-function combin m))
142                 ((eq (car qualifiers) :around)
143                  (push m around))
144                 ((eq (car qualifiers) type)
145                  (push m primary))
146                 (t (invalid generic-function combin m))))))
147     (setq around (nreverse around))
148     (ecase order
149       (:most-specific-last) ; nothing to be done, already in correct order
150       (:most-specific-first
151        (setq primary (nreverse primary))))
152     (let ((main-method
153             (if (and (null (cdr primary))
154                      (not (null ioa)))
155                 `(call-method ,(car primary) ())
156                 `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
157                                       primary)))))
158       (cond ((null primary)
159              ;; As of sbcl-0.8.0.80 we don't seem to need to need
160              ;; to do anything messy like
161              ;;        `(APPLY (FUNCTION (IF AROUND
162              ;;                              'NO-PRIMARY-METHOD
163              ;;                              'NO-APPLICABLE-METHOD)
164              ;;                           ',GENERIC-FUNCTION
165              ;;                           .ARGS.)
166              ;; here because (for reasons I don't understand at the
167              ;; moment -- WHN) control will never reach here if there
168              ;; are no applicable methods, but instead end up
169              ;; in NO-APPLICABLE-METHODS first.
170              ;;
171              ;; FIXME: The way that we arrange for .ARGS. to be bound
172              ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
173              ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
174              ;; as magical, and carefully surrounding it with a
175              ;; LAMBDA form which binds .ARGS. But...
176              ;;   1. That seems fragile, because the magicalness of
177              ;;      %NO-PRIMARY-METHOD forms is scattered around
178              ;;      the system. So it could easily be broken by
179              ;;      locally-plausible maintenance changes like,
180              ;;      e.g., using the APPLY expression above.
181              ;;   2. That seems buggy w.r.t. to MOPpish tricks in
182              ;;      user code, e.g.
183              ;;         (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
184              ;;           `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
185              `(%no-primary-method ',generic-function .args.))
186             ((null around) main-method)
187             (t
188              `(call-method ,(car around)
189                            (,@(cdr around) (make-method ,main-method))))))))
190
191 (defmethod invalid-qualifiers ((gf generic-function)
192                                (combin short-method-combination)
193                                method)
194   (let ((qualifiers (method-qualifiers method))
195         (type (method-combination-type combin)))
196     (let ((why (cond
197                  ((null qualifiers) "has no qualifiers")
198                  ((cdr qualifiers) "has too many qualifiers")
199                  (t (aver (and (neq (car qualifiers) type)
200                                (neq (car qualifiers) :around)))
201                     "has an invalid qualifier"))))
202       (invalid-method-error
203        method
204        "The method ~S on ~S ~A.~%~
205         The method combination type ~S was defined with the~%~
206         short form of DEFINE-METHOD-COMBINATION and so requires~%~
207         all methods have either the single qualifier ~S or the~%~
208         single qualifier :AROUND."
209        method gf why type type))))
210 \f
211 ;;;; long method combinations
212
213 (defun expand-long-defcombin (form)
214   (let ((type (cadr form))
215         (lambda-list (caddr form))
216         (method-group-specifiers (cadddr form))
217         (body (cddddr form))
218         (args-option ())
219         (gf-var nil))
220     (when (and (consp (car body)) (eq (caar body) :arguments))
221       (setq args-option (cdr (pop body))))
222     (when (and (consp (car body)) (eq (caar body) :generic-function))
223       (setq gf-var (cadr (pop body))))
224     (multiple-value-bind (documentation function)
225         (make-long-method-combination-function
226           type lambda-list method-group-specifiers args-option gf-var
227           body)
228       `(load-long-defcombin ',type ',documentation #',function
229                             ',args-option (sb-c:source-location)))))
230
231 (defvar *long-method-combination-functions* (make-hash-table :test 'eq))
232
233 (defun load-long-defcombin (type doc function args-lambda-list source-location)
234   (let* ((specializers
235            (list (find-class 'generic-function)
236                  (intern-eql-specializer type)
237                  *the-class-t*))
238          (old-method
239            (get-method #'find-method-combination () specializers nil))
240          (new-method
241            (make-instance 'standard-method
242              :qualifiers ()
243              :specializers specializers
244              :lambda-list '(generic-function type options)
245              :function (lambda (args nms &rest cm-args)
246                          (declare (ignore nms cm-args))
247                          (apply
248                           (lambda (generic-function type options)
249                             (declare (ignore generic-function))
250                             (make-instance 'long-method-combination
251                                            :type type
252                                            :options options
253                                            :args-lambda-list args-lambda-list
254                                            :documentation doc))
255                           args))
256              :definition-source source-location)))
257     (setf (gethash type *long-method-combination-functions*) function)
258     (when old-method (remove-method #'find-method-combination old-method))
259     (add-method #'find-method-combination new-method)
260     (setf (random-documentation type 'method-combination) doc)
261     type))
262
263 (defmethod compute-effective-method ((generic-function generic-function)
264                                      (combin long-method-combination)
265                                      applicable-methods)
266   (funcall (gethash (method-combination-type combin)
267                     *long-method-combination-functions*)
268            generic-function
269            combin
270            applicable-methods))
271
272 (defun make-long-method-combination-function
273        (type ll method-group-specifiers args-option gf-var body)
274   (declare (ignore type))
275   (multiple-value-bind (real-body declarations documentation)
276       (parse-body body)
277     (let ((wrapped-body
278             (wrap-method-group-specifier-bindings method-group-specifiers
279                                                   declarations
280                                                   real-body)))
281       (when gf-var
282         (push `(,gf-var .generic-function.) (cadr wrapped-body)))
283
284       (when args-option
285         (setq wrapped-body (deal-with-args-option wrapped-body args-option)))
286
287       (when ll
288         (setq wrapped-body
289               `(apply #'(lambda ,ll ,wrapped-body)
290                       (method-combination-options .method-combination.))))
291
292       (values
293         documentation
294         `(lambda (.generic-function. .method-combination. .applicable-methods.)
295            (declare (ignorable .generic-function.
296                      .method-combination. .applicable-methods.))
297            (block .long-method-combination-function. ,wrapped-body))))))
298
299 (define-condition long-method-combination-error
300     (reference-condition simple-error)
301   ()
302   (:default-initargs
303       :references (list '(:ansi-cl :macro define-method-combination))))
304
305 ;;; NOTE:
306 ;;;
307 ;;; The semantics of long form method combination in the presence of
308 ;;; multiple methods with the same specializers in the same method
309 ;;; group are unclear by the spec: a portion of the standard implies
310 ;;; that an error should be signalled, and another is more lenient.
311 ;;;
312 ;;; It is reasonable to allow a single method group of * to bypass all
313 ;;; rules, as this is explicitly stated in the standard.
314
315 (defun group-cond-clause (name tests specializer-cache star-only)
316   (let ((maybe-error-clause
317          (if star-only
318              `(setq ,specializer-cache .specializers.)
319              `(if (and (equal ,specializer-cache .specializers.)
320                        (not (null .specializers.)))
321                   (return-from .long-method-combination-function.
322                     '(error 'long-method-combination-error
323                       :format-control "More than one method of type ~S ~
324                                        with the same specializers."
325                       :format-arguments (list ',name)))
326                   (setq ,specializer-cache .specializers.)))))
327     `((or ,@tests)
328       ,maybe-error-clause
329       (push .method. ,name))))
330
331 (defun wrap-method-group-specifier-bindings
332     (method-group-specifiers declarations real-body)
333   (let (names specializer-caches cond-clauses required-checks order-cleanups)
334     (let ((nspecifiers (length method-group-specifiers)))
335       (dolist (method-group-specifier method-group-specifiers)
336         (multiple-value-bind (name tests description order required)
337             (parse-method-group-specifier method-group-specifier)
338           (declare (ignore description))
339           (let ((specializer-cache (gensym)))
340             (push name names)
341             (push specializer-cache specializer-caches)
342             (push (group-cond-clause name tests specializer-cache
343                                      (and (eq (cadr method-group-specifier) '*)
344                                           (= nspecifiers 1)))
345                   cond-clauses)
346             (when required
347               (push `(when (null ,name)
348                       (return-from .long-method-combination-function.
349                         '(error 'long-method-combination-error
350                           :format-control "No ~S methods."
351                           :format-arguments (list ',name))))
352                     required-checks))
353             (loop (unless (and (constantp order)
354                                (neq order (setq order (eval order))))
355                     (return t)))
356             (push (cond ((eq order :most-specific-first)
357                          `(setq ,name (nreverse ,name)))
358                         ((eq order :most-specific-last) ())
359                         (t
360                          `(ecase ,order
361                            (:most-specific-first
362                             (setq ,name (nreverse ,name)))
363                            (:most-specific-last))))
364                   order-cleanups))))
365       `(let (,@(nreverse names) ,@(nreverse specializer-caches))
366         ,@declarations
367         (dolist (.method. .applicable-methods.)
368           (let ((.qualifiers. (method-qualifiers .method.))
369                 (.specializers. (method-specializers .method.)))
370             (declare (ignorable .qualifiers. .specializers.))
371             (cond ,@(nreverse cond-clauses))))
372         ,@(nreverse required-checks)
373         ,@(nreverse order-cleanups)
374         ,@real-body))))
375
376 (defun parse-method-group-specifier (method-group-specifier)
377   ;;(declare (values name tests description order required))
378   (let* ((name (pop method-group-specifier))
379          (patterns ())
380          (tests
381            (let (collect)
382              (block collect-tests
383                (loop
384                  (if (or (null method-group-specifier)
385                          (memq (car method-group-specifier)
386                                '(:description :order :required)))
387                      (return-from collect-tests t)
388                      (let ((pattern (pop method-group-specifier)))
389                        (push pattern patterns)
390                        (push (parse-qualifier-pattern name pattern)
391                              collect)))))
392              (nreverse collect))))
393     (values name
394             tests
395             (getf method-group-specifier :description
396                   (make-default-method-group-description patterns))
397             (getf method-group-specifier :order :most-specific-first)
398             (getf method-group-specifier :required nil))))
399
400 (defun parse-qualifier-pattern (name pattern)
401   (cond ((eq pattern '()) `(null .qualifiers.))
402         ((eq pattern '*) t)
403         ((symbolp pattern) `(,pattern .qualifiers.))
404         ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
405         (t (error "In the method group specifier ~S,~%~
406                    ~S isn't a valid qualifier pattern."
407                   name pattern))))
408
409 (defun qualifier-check-runtime (pattern qualifiers)
410   (loop (cond ((and (null pattern) (null qualifiers))
411                (return t))
412               ((eq pattern '*) (return t))
413               ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
414                (pop pattern)
415                (pop qualifiers))
416               (t (return nil)))))
417
418 (defun make-default-method-group-description (patterns)
419   (if (cdr patterns)
420       (format nil
421               "methods matching one of the patterns: ~{~S, ~} ~S"
422               (butlast patterns) (car (last patterns)))
423       (format nil
424               "methods matching the pattern: ~S"
425               (car patterns))))
426
427 ;;; This baby is a complete mess. I can't believe we put it in this
428 ;;; way. No doubt this is a large part of what drives MLY crazy.
429 ;;;
430 ;;; At runtime (when the effective-method is run), we bind an intercept
431 ;;; lambda-list to the arguments to the generic function.
432 ;;;
433 ;;; At compute-effective-method time, the symbols in the :arguments
434 ;;; option are bound to the symbols in the intercept lambda list.
435 ;;;
436 ;;; FIXME: in here we have not one but two mini-copies of a weird
437 ;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST.
438 (defun deal-with-args-option (wrapped-body args-lambda-list)
439   (let ((intercept-rebindings
440          (let (rebindings)
441            (dolist (arg args-lambda-list (nreverse rebindings))
442              (unless (member arg lambda-list-keywords)
443                (typecase arg
444                  (symbol (push `(,arg ',arg) rebindings))
445                  (cons
446                   (unless (symbolp (car arg))
447                     (error "invalid lambda-list specifier: ~S." arg))
448                   (push `(,(car arg) ',(car arg)) rebindings))
449                  (t (error "invalid lambda-list-specifier: ~S." arg)))))))
450         (nreq 0)
451         (nopt 0)
452         (whole nil))
453     ;; Count the number of required and optional parameters in
454     ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
455     ;; name of a &WHOLE parameter, if any.
456     (when (member '&whole (rest args-lambda-list))
457       (error 'simple-program-error
458              :format-control "~@<The value of the :ARGUMENTS option of ~
459                 DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
460                 only appear first in the lambda list.~:>"
461              :format-arguments (list args-lambda-list)))
462     (loop with state = 'required
463           for arg in args-lambda-list do
464             (if (memq arg lambda-list-keywords)
465                 (setq state arg)
466                 (case state
467                   (required (incf nreq))
468                   (&optional (incf nopt))
469                   (&whole (setq whole arg state 'required)))))
470     ;; This assumes that the head of WRAPPED-BODY is a let, and it
471     ;; injects let-bindings of the form (ARG 'SYM) for all variables
472     ;; of the argument-lambda-list; SYM is a gensym.
473     (aver (memq (first wrapped-body) '(let let*)))
474     (setf (second wrapped-body)
475           (append intercept-rebindings (second wrapped-body)))
476     ;; Be sure to fill out the args lambda list so that it can be too
477     ;; short if it wants to.
478     (unless (or (memq '&rest args-lambda-list)
479                 (memq '&allow-other-keys args-lambda-list))
480       (let ((aux (memq '&aux args-lambda-list)))
481         (setq args-lambda-list
482               (append (ldiff args-lambda-list aux)
483                       (if (memq '&key args-lambda-list)
484                           '(&allow-other-keys)
485                           '(&rest .ignore.))
486                       aux))))
487     ;; .GENERIC-FUNCTION. is bound to the generic function in the
488     ;; method combination function, and .GF-ARGS* is bound to the
489     ;; generic function arguments in effective method functions
490     ;; created for generic functions having a method combination that
491     ;; uses :ARGUMENTS.
492     ;;
493     ;; The DESTRUCTURING-BIND binds the parameters of the
494     ;; ARGS-LAMBDA-LIST to actual generic function arguments.  Because
495     ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic
496     ;; function's lambda list, which is only known at run time, this
497     ;; destructuring has to be done on a slighly modified list of
498     ;; actual arguments, from which values might be stripped or added.
499     ;;
500     ;; Using one of the variable names in the body inserts a symbol
501     ;; into the effective method, and running the effective method
502     ;; produces the value of actual argument that is bound to the
503     ;; symbol.
504     `(let ((inner-result. ,wrapped-body)
505            (gf-lambda-list (generic-function-lambda-list .generic-function.)))
506        `(destructuring-bind ,',args-lambda-list
507             (frob-combined-method-args
508              .gf-args. ',gf-lambda-list
509              ,',nreq ,',nopt)
510           ,,(when (memq '.ignore. args-lambda-list)
511               ''(declare (ignore .ignore.)))
512           ;; If there is a &WHOLE in the args-lambda-list, let
513           ;; it result in the actual arguments of the generic-function
514           ;; not the frobbed list.
515           ,,(when whole
516               ``(setq ,',whole .gf-args.))
517           ,inner-result.))))
518
519 ;;; Partition VALUES into three sections: required, optional, and the
520 ;;; rest, according to required, optional, and other parameters in
521 ;;; LAMBDA-LIST.  Make the required and optional sections NREQ and
522 ;;; NOPT elements long by discarding values or adding NILs.  Value is
523 ;;; the concatenated list of required and optional sections, and what
524 ;;; is left as rest from VALUES.
525 (defun frob-combined-method-args (values lambda-list nreq nopt)
526   (loop with section = 'required
527         for arg in lambda-list
528         if (memq arg lambda-list-keywords) do
529           (setq section arg)
530           (unless (eq section '&optional)
531             (loop-finish))
532         else if (eq section 'required)
533           count t into nr
534           and collect (pop values) into required
535         else if (eq section '&optional)
536           count t into no
537           and collect (pop values) into optional
538         finally
539           (flet ((frob (list n m)
540                    (cond ((> n m) (butlast list (- n m)))
541                          ((< n m) (nconc list (make-list (- m n))))
542                          (t list))))
543             (return (nconc (frob required nr nreq)
544                            (frob optional no nopt)
545                            values)))))
546