0.9.10.30
[sbcl.git] / src / pcl / combin.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 (defun get-method-function (method &optional method-alist wrappers)
27   (let ((fn (cadr (assoc method method-alist))))
28     (if fn
29         (values fn nil nil nil)
30         (multiple-value-bind (mf fmf)
31             (if (listp method)
32                 (early-method-function method)
33                 (values nil (safe-method-fast-function method)))
34           (let* ((pv-table (and fmf (method-function-pv-table fmf))))
35             (if (and fmf (or (null pv-table) wrappers))
36                 (let* ((pv-wrappers (when pv-table
37                                       (pv-wrappers-from-all-wrappers
38                                        pv-table wrappers)))
39                        (pv-cell (when (and pv-table pv-wrappers)
40                                   (pv-table-lookup pv-table pv-wrappers))))
41                   (values mf t fmf pv-cell))
42                 (values
43                  (or mf (if (listp method)
44                             (setf (cadr method)
45                                   (method-function-from-fast-function fmf))
46                             (method-function method)))
47                  t nil nil)))))))
48
49 (defun make-effective-method-function (generic-function form &optional
50                                        method-alist wrappers)
51   (funcall (make-effective-method-function1 generic-function form
52                                             (not (null method-alist))
53                                             (not (null wrappers)))
54            method-alist wrappers))
55
56 (defun make-effective-method-function1 (generic-function form
57                                         method-alist-p wrappers-p)
58   (if (and (listp form)
59            (eq (car form) 'call-method))
60       (make-effective-method-function-simple generic-function form)
61       ;; We have some sort of `real' effective method. Go off and get a
62       ;; compiled function for it. Most of the real hair here is done by
63       ;; the GET-FUN mechanism.
64       (make-effective-method-function-internal generic-function form
65                                                method-alist-p wrappers-p)))
66
67 (defun make-effective-method-fun-type (generic-function
68                                        form
69                                        method-alist-p
70                                        wrappers-p)
71   (if (and (listp form)
72            (eq (car form) 'call-method))
73       (let* ((cm-args (cdr form))
74              (method (car cm-args)))
75         (when method
76           (if (if (listp method)
77                   (eq (car method) :early-method)
78                   (method-p method))
79               (if method-alist-p
80                   t
81                   (multiple-value-bind (mf fmf)
82                       (if (listp method)
83                           (early-method-function method)
84                           (values nil (safe-method-fast-function method)))
85                     (declare (ignore mf))
86                     (let* ((pv-table (and fmf (method-function-pv-table fmf))))
87                       (if (and fmf (or (null pv-table) wrappers-p))
88                           'fast-method-call
89                           'method-call))))
90               (if (and (consp method) (eq (car method) 'make-method))
91                   (make-effective-method-fun-type
92                    generic-function (cadr method) method-alist-p wrappers-p)
93                   (type-of method)))))
94       'fast-method-call))
95
96 (defun make-effective-method-function-simple
97     (generic-function form &optional no-fmf-p)
98   ;; The effective method is just a call to CALL-METHOD. This opens up
99   ;; the possibility of just using the method function of the method as
100   ;; the effective method function.
101   ;;
102   ;; But we have to be careful. If that method function will ask for
103   ;; the next methods we have to provide them. We do not look to see
104   ;; if there are next methods, we look at whether the method function
105   ;; asks about them. If it does, we must tell it whether there are
106   ;; or aren't to prevent the leaky next methods bug.
107   (let* ((cm-args (cdr form))
108          (fmf-p (and (null no-fmf-p)
109                      (or (not (eq *boot-state* 'complete))
110                          (gf-fast-method-function-p generic-function))
111                      (null (cddr cm-args))))
112          (method (car cm-args))
113          (cm-args1 (cdr cm-args)))
114     (lambda (method-alist wrappers)
115       (make-effective-method-function-simple1 generic-function
116                                               method
117                                               cm-args1
118                                               fmf-p
119                                               method-alist
120                                               wrappers))))
121
122 (defun make-emf-from-method
123     (method cm-args &optional gf fmf-p method-alist wrappers)
124   (multiple-value-bind (mf real-mf-p fmf pv-cell)
125       (get-method-function method method-alist wrappers)
126     (if fmf
127         (let* ((next-methods (car cm-args))
128                (next (make-effective-method-function-simple1
129                       gf (car next-methods)
130                       (list* (cdr next-methods) (cdr cm-args))
131                       fmf-p method-alist wrappers))
132                (arg-info (method-function-get fmf :arg-info)))
133           (make-fast-method-call :function fmf
134                                  :pv-cell pv-cell
135                                  :next-method-call next
136                                  :arg-info arg-info))
137         (if real-mf-p
138             (make-method-call :function mf
139                               :call-method-args cm-args)
140             mf))))
141
142 (defun make-effective-method-function-simple1
143     (gf method cm-args fmf-p &optional method-alist wrappers)
144   (when method
145     (if (if (listp method)
146             (eq (car method) :early-method)
147             (method-p method))
148         (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
149         (if (and (consp method) (eq (car method) 'make-method))
150             (make-effective-method-function gf
151                                             (cadr method)
152                                             method-alist wrappers)
153             method))))
154
155 (defvar *global-effective-method-gensyms* ())
156 (defvar *rebound-effective-method-gensyms*)
157
158 (defun get-effective-method-gensym ()
159   (or (pop *rebound-effective-method-gensyms*)
160       (let ((new (format-symbol *pcl-package*
161                                 "EFFECTIVE-METHOD-GENSYM-~D"
162                                 (length *global-effective-method-gensyms*))))
163         (setq *global-effective-method-gensyms*
164               (append *global-effective-method-gensyms* (list new)))
165         new)))
166
167 (let ((*rebound-effective-method-gensyms* ()))
168   (dotimes-fixnum (i 10) (get-effective-method-gensym)))
169
170 (defun expand-effective-method-function (gf effective-method &optional env)
171   (declare (ignore env))
172   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
173       (get-generic-fun-info gf)
174     (declare (ignore nreq nkeys arg-info))
175     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
176           (check-applicable-keywords
177            (when (and applyp (gf-requires-emf-keyword-checks gf))
178              '((check-applicable-keywords))))
179           (error-p (or (eq (first effective-method) '%no-primary-method)
180                        (eq (first effective-method) '%invalid-qualifiers)))
181           (mc-args-p
182            (when (eq *boot-state* 'complete)
183              ;; Otherwise the METHOD-COMBINATION slot is not bound.
184              (let ((combin (generic-function-method-combination gf)))
185                (and (long-method-combination-p combin)
186                     (long-method-combination-args-lambda-list combin))))))
187       (cond
188         (error-p
189          `(lambda (.pv-cell. .next-method-call. &rest .args.)
190            (declare (ignore .pv-cell. .next-method-call.))
191            (declare (ignorable .args.))
192            (flet ((%no-primary-method (gf args)
193                     (apply #'no-primary-method gf args))
194                   (%invalid-qualifiers (gf combin method)
195                     (invalid-qualifiers gf combin method)))
196              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
197              ,effective-method)))
198         (mc-args-p
199          (let* ((required
200                  ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
201                  (let (req)
202                    (dotimes (i (length metatypes) (nreverse req))
203                      (push (dfun-arg-symbol i) req))))
204                 (gf-args (if applyp
205                              `(list* ,@required .dfun-rest-arg.)
206                              `(list ,@required))))
207            `(lambda ,ll
208              (declare (ignore .pv-cell. .next-method-call.))
209              (let ((.gf-args. ,gf-args))
210                (declare (ignorable .gf-args.))
211                ,@check-applicable-keywords
212                ,effective-method))))
213         (t
214          `(lambda ,ll
215            (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
216            ,@check-applicable-keywords
217            ,effective-method))))))
218
219 (defun expand-emf-call-method (gf form metatypes applyp env)
220   (declare (ignore gf metatypes applyp env))
221   `(call-method ,(cdr form)))
222
223 (defmacro call-method (&rest args)
224   (declare (ignore args))
225   ;; the PROGN is here to defend against premature macroexpansion by
226   ;; RESTART-CASE.
227   `(progn (error "~S outside of a effective method form" 'call-method)))
228
229 (defun make-effective-method-list-fun-type
230     (generic-function form method-alist-p wrappers-p)
231   (if (every (lambda (form)
232                (eq 'fast-method-call
233                    (make-effective-method-fun-type
234                     generic-function form method-alist-p wrappers-p)))
235              (cdr form))
236       'fast-method-call
237       t))
238
239 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
240   (case (and (consp form) (car form))
241     (call-method
242      (case (make-effective-method-fun-type
243             generic-function form method-alist-p wrappers-p)
244        (fast-method-call '.fast-call-method.)
245        (t '.call-method.)))
246     (call-method-list
247      (case (make-effective-method-list-fun-type
248             generic-function form method-alist-p wrappers-p)
249        (fast-method-call '.fast-call-method-list.)
250        (t '.call-method-list.)))
251     (check-applicable-keywords 'check-applicable-keywords)
252     (t (default-test-converter form))))
253
254 ;;; CMUCL comment (2003-10-15):
255 ;;;
256 ;;;   This function is called via the GET-FUNCTION mechanism on forms
257 ;;;   of an emf lambda.  First value returned replaces FORM in the emf
258 ;;;   lambda.  Second value is a list of variable names that become
259 ;;;   closure variables.
260 (defun memf-code-converter
261     (form generic-function metatypes applyp method-alist-p wrappers-p)
262   (case (and (consp form) (car form))
263     (call-method
264      (let ((gensym (get-effective-method-gensym)))
265        (values (make-emf-call
266                 metatypes applyp gensym
267                 (make-effective-method-fun-type
268                  generic-function form method-alist-p wrappers-p))
269                (list gensym))))
270     (call-method-list
271      (let ((gensym (get-effective-method-gensym))
272            (type (make-effective-method-list-fun-type
273                   generic-function form method-alist-p wrappers-p)))
274        (values `(dolist (emf ,gensym nil)
275                  ,(make-emf-call metatypes applyp 'emf type))
276                (list gensym))))
277     (check-applicable-keywords
278      (values `(check-applicable-keywords
279                .dfun-rest-arg. .keyargs-start. .valid-keys.)
280              '(.keyargs-start. .valid-keys.)))
281
282     (t
283      (default-code-converter form))))
284
285 (defun memf-constant-converter (form generic-function)
286   (case (and (consp form) (car form))
287     (call-method
288      (list (cons '.meth.
289                  (make-effective-method-function-simple
290                   generic-function form))))
291     (call-method-list
292      (list (cons '.meth-list.
293                  (mapcar (lambda (form)
294                            (make-effective-method-function-simple
295                             generic-function form))
296                          (cdr form)))))
297     (check-applicable-keywords
298      '(.keyargs-start. .valid-keys.))
299     (t
300      (default-constant-converter form))))
301
302 (defvar *applicable-methods*)
303 (defun make-effective-method-function-internal
304     (generic-function effective-method method-alist-p wrappers-p)
305   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
306       (get-generic-fun-info generic-function)
307     (declare (ignore nkeys arg-info))
308     (let* ((*rebound-effective-method-gensyms*
309             *global-effective-method-gensyms*)
310            (name (if (early-gf-p generic-function)
311                      (!early-gf-name generic-function)
312                      (generic-function-name generic-function)))
313            (arg-info (cons nreq applyp))
314            (effective-method-lambda (expand-effective-method-function
315                                      generic-function effective-method)))
316       (multiple-value-bind (cfunction constants)
317           (get-fun1 effective-method-lambda
318                     (lambda (form)
319                       (memf-test-converter form generic-function
320                                            method-alist-p wrappers-p))
321                     (lambda (form)
322                       (memf-code-converter form generic-function
323                                            metatypes applyp
324                                            method-alist-p wrappers-p))
325                     (lambda (form)
326                       (memf-constant-converter form generic-function)))
327         (lambda (method-alist wrappers)
328           (multiple-value-bind (valid-keys keyargs-start)
329               (when (memq '.valid-keys. constants)
330                 (compute-applicable-keywords
331                  generic-function *applicable-methods*))
332             (flet ((compute-constant (constant)
333                      (if (consp constant)
334                          (case (car constant)
335                            (.meth.
336                             (funcall (cdr constant) method-alist wrappers))
337                            (.meth-list.
338                             (mapcar (lambda (fn)
339                                       (funcall fn method-alist wrappers))
340                                     (cdr constant)))
341                            (t constant))
342                          (case constant
343                            (.keyargs-start. keyargs-start)
344                            (.valid-keys. valid-keys)
345                            (t constant)))))
346               (let ((fun (apply cfunction
347                                 (mapcar #'compute-constant constants))))
348                 (set-fun-name fun `(combined-method ,name))
349                 (make-fast-method-call :function fun
350                                        :arg-info arg-info)))))))))
351
352 (defmacro call-method-list (&rest calls)
353   `(progn ,@calls))
354
355 (defun make-call-methods (methods)
356   `(call-method-list
357     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
358
359 (defun gf-requires-emf-keyword-checks (generic-function)
360   (member '&key (gf-lambda-list generic-function)))
361
362 (defvar *in-precompute-effective-methods-p* nil)
363
364 (defun standard-compute-effective-method
365     (generic-function combin applicable-methods)
366   (collect ((before) (primary) (after) (around))
367     (flet ((invalid (gf combin m)
368              (if *in-precompute-effective-methods-p*
369                  (return-from standard-compute-effective-method
370                    `(%invalid-qualifiers ',gf ',combin ',m))
371                  (invalid-qualifiers gf combin m))))
372       (dolist (m applicable-methods)
373         (let ((qualifiers (if (listp m)
374                               (early-method-qualifiers m)
375                               (method-qualifiers m))))
376           (cond
377             ((null qualifiers) (primary m))
378             ((cdr qualifiers) (invalid generic-function combin m))
379             ((eq (car qualifiers) :around) (around m))
380             ((eq (car qualifiers) :before) (before m))
381             ((eq (car qualifiers) :after) (after m))
382             (t (invalid generic-function combin m))))))
383     (cond ((null (primary))
384            `(%no-primary-method ',generic-function .args.))
385           ((and (null (before)) (null (after)) (null (around)))
386            ;; By returning a single call-method `form' here we enable
387            ;; an important implementation-specific optimization; that
388            ;; is, we can use the fast method function directly as the
389            ;; effective method function.
390            ;;
391            ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
392            ;; function argument checking inhibits this, as we don't
393            ;; perform this checking in fast-method-functions given
394            ;; that they are not solely used for effective method
395            ;; functions, but also in combination, when they should not
396            ;; perform argument checks.
397            (let ((call-method
398                   `(call-method ,(first (primary)) ,(rest (primary)))))
399              (if (gf-requires-emf-keyword-checks generic-function)
400                  ;; the PROGN inhibits the above optimization
401                  `(progn ,call-method)
402                  call-method)))
403           (t
404            (let ((main-effective-method
405                    (if (or (before) (after))
406                        `(multiple-value-prog1
407                           (progn
408                             ,(make-call-methods (before))
409                             (call-method ,(first (primary))
410                                          ,(rest (primary))))
411                           ,(make-call-methods (reverse (after))))
412                        `(call-method ,(first (primary)) ,(rest (primary))))))
413              (if (around)
414                  `(call-method ,(first (around))
415                                (,@(rest (around))
416                                   (make-method ,main-effective-method)))
417                  main-effective-method))))))
418 \f
419 ;;; helper code for checking keywords in generic function calls.
420 (defun compute-applicable-keywords (gf methods)
421   (let ((any-keyp nil))
422     (flet ((analyze (lambda-list)
423              (multiple-value-bind (nreq nopt keyp restp allowp keys)
424                  (analyze-lambda-list lambda-list)
425                (declare (ignore nreq restp))
426                (when keyp
427                  (setq any-keyp t))
428                (values nopt allowp keys))))
429       (multiple-value-bind (nopt allowp keys)
430           (analyze (generic-function-lambda-list gf))
431         (dolist (method methods)
432           (let ((ll (if (consp method)
433                         (early-method-lambda-list method)
434                         (method-lambda-list method))))
435             (multiple-value-bind (n allowp method-keys)
436                 (analyze ll)
437               (declare (ignore n))
438               (when allowp
439                 (return-from compute-applicable-keywords (values t nopt)))
440               (setq keys (union method-keys keys)))))
441         (aver any-keyp)
442         (values (if allowp t keys) nopt)))))
443
444 (defun check-applicable-keywords (args start valid-keys)
445   (let ((allow-other-keys-seen nil)
446         (allow-other-keys nil)
447         (args (nthcdr start args)))
448     (collect ((invalid))
449       (loop
450        (when (null args)
451          (when (and (invalid) (not allow-other-keys))
452            (error 'simple-program-error
453                   :format-control "~@<invalid keyword argument~P: ~
454                                    ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
455                   :format-arguments (list (length (invalid)) (invalid) valid-keys)))
456          (return))
457        (let ((key (pop args)))
458          (cond
459            ((not (symbolp key))
460             (error 'simple-program-error
461                    :format-control "~@<keyword argument not a symbol: ~S.~@:>"
462                    :format-arguments (list key)))
463            ((null args) (sb-c::%odd-key-args-error))
464            ((eq key :allow-other-keys)
465             ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
466             (unless allow-other-keys-seen
467               (setq allow-other-keys-seen t
468                     allow-other-keys (car args))))
469            ((eq t valid-keys))
470            ((not (memq key valid-keys)) (invalid key))))
471        (pop args)))))
472 \f
473 ;;;; the STANDARD method combination type. This is coded by hand
474 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
475 ;;;; and efficiency reasons. Note that the definition of the
476 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
477 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
478 ;;;; bootstrap.
479 ;;;;
480 ;;;; The DEFCLASS for the METHOD-COMBINATION and
481 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
482 ;;;; reason. This code must conform to the code in the file
483 ;;;; defcombin.lisp, look there for more details.
484
485 (defun compute-effective-method (generic-function combin applicable-methods)
486   (standard-compute-effective-method generic-function
487                                      combin
488                                      applicable-methods))
489
490 (defun invalid-method-error (method format-control &rest format-arguments)
491   (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
492     (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
493            method
494            format-control
495            format-arguments)))
496
497 (defun method-combination-error (format-control &rest format-arguments)
498   (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
499     (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
500            format-control
501            format-arguments)))