0.7.7.10:
[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 (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 (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 (intern (format nil
161                                  "EFFECTIVE-METHOD-GENSYM-~D"
162                                  (length *global-effective-method-gensyms*))
163                          *pcl-package*)))
164         (setq *global-effective-method-gensyms*
165               (append *global-effective-method-gensyms* (list new)))
166         new)))
167
168 (let ((*rebound-effective-method-gensyms* ()))
169   (dotimes-fixnum (i 10) (get-effective-method-gensym)))
170
171 (defun expand-effective-method-function (gf effective-method &optional env)
172   (declare (ignore env))
173   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
174       (get-generic-fun-info gf)
175     (declare (ignore nreq nkeys arg-info))
176     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
177           ;; When there are no primary methods and a next-method call occurs
178           ;; effective-method is (error "No mumble..") and the defined
179           ;; args are not used giving a compiler warning.
180           (error-p (eq (first effective-method) 'error)))
181       `(lambda ,ll
182         (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
183         ,effective-method))))
184
185 (defun expand-emf-call-method (gf form metatypes applyp env)
186   (declare (ignore gf metatypes applyp env))
187   `(call-method ,(cdr form)))
188
189 (defmacro call-method (&rest args)
190   (declare (ignore args))
191   `(error "~S outside of a effective method form" 'call-method))
192
193 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
194   (cond ((and (consp form) (eq (car form) 'call-method))
195          (case (make-effective-method-fun-type
196                 generic-function form method-alist-p wrappers-p)
197            (fast-method-call
198             '.fast-call-method.)
199            (t
200             '.call-method.)))
201         ((and (consp form) (eq (car form) 'call-method-list))
202          (case (if (every (lambda (form)
203                             (eq 'fast-method-call
204                                 (make-effective-method-fun-type
205                                  generic-function form
206                                  method-alist-p wrappers-p)))
207                           (cdr form))
208                    'fast-method-call
209                    t)
210            (fast-method-call
211             '.fast-call-method-list.)
212            (t
213             '.call-method-list.)))
214         (t
215          (default-test-converter form))))
216
217 (defun memf-code-converter
218     (form generic-function metatypes applyp method-alist-p wrappers-p)
219   (cond ((and (consp form) (eq (car form) 'call-method))
220          (let ((gensym (get-effective-method-gensym)))
221            (values (make-emf-call metatypes applyp gensym
222                                   (make-effective-method-fun-type
223                                    generic-function form method-alist-p wrappers-p))
224                    (list gensym))))
225         ((and (consp form) (eq (car form) 'call-method-list))
226          (let ((gensym (get-effective-method-gensym))
227                (type (if (every (lambda (form)
228                                   (eq 'fast-method-call
229                                       (make-effective-method-fun-type
230                                        generic-function form
231                                        method-alist-p wrappers-p)))
232                                 (cdr form))
233                          'fast-method-call
234                          t)))
235            (values `(dolist (emf ,gensym nil)
236                       ,(make-emf-call metatypes applyp 'emf type))
237                    (list gensym))))
238         (t
239          (default-code-converter form))))
240
241 (defun memf-constant-converter (form generic-function)
242   (cond ((and (consp form) (eq (car form) 'call-method))
243          (list (cons '.meth.
244                      (make-effective-method-function-simple
245                       generic-function form))))
246         ((and (consp form) (eq (car form) 'call-method-list))
247          (list (cons '.meth-list.
248                      (mapcar (lambda (form)
249                                (make-effective-method-function-simple
250                                 generic-function form))
251                              (cdr form)))))
252         (t
253          (default-constant-converter form))))
254
255 (defun make-effective-method-function-internal
256     (generic-function effective-method method-alist-p wrappers-p)
257   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
258       (get-generic-fun-info generic-function)
259     (declare (ignore nkeys arg-info))
260     (let* ((*rebound-effective-method-gensyms*
261             *global-effective-method-gensyms*)
262            (name (if (early-gf-p generic-function)
263                      (!early-gf-name generic-function)
264                      (generic-function-name generic-function)))
265            (arg-info (cons nreq applyp))
266            (effective-method-lambda (expand-effective-method-function
267                                      generic-function effective-method)))
268       (multiple-value-bind (cfunction constants)
269           (get-fun1 effective-method-lambda
270                     (lambda (form)
271                       (memf-test-converter form generic-function
272                                            method-alist-p wrappers-p))
273                     (lambda (form)
274                       (memf-code-converter form generic-function
275                                            metatypes applyp
276                                            method-alist-p wrappers-p))
277                     (lambda (form)
278                       (memf-constant-converter form generic-function)))
279         (lambda (method-alist wrappers)
280           (let* ((constants
281                   (mapcar (lambda (constant)
282                             (if (consp constant)
283                                 (case (car constant)
284                                   (.meth.
285                                    (funcall (cdr constant)
286                                             method-alist wrappers))
287                                   (.meth-list.
288                                    (mapcar (lambda (fn)
289                                              (funcall fn
290                                                       method-alist
291                                                       wrappers))
292                                            (cdr constant)))
293                                   (t constant))
294                                 constant))
295                           constants))
296                  (function (set-fun-name
297                             (apply cfunction constants)
298                             `(combined-method ,name))))
299             (make-fast-method-call :function function
300                                    :arg-info arg-info)))))))
301
302 (defmacro call-method-list (&rest calls)
303   `(progn ,@calls))
304
305 (defun make-call-methods (methods)
306   `(call-method-list
307     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
308
309 (defun standard-compute-effective-method (generic-function combin applicable-methods)
310   (declare (ignore combin))
311   (let ((before ())
312         (primary ())
313         (after ())
314         (around ()))
315     (flet ((lose (method why)
316              (invalid-method-error
317               method
318               "The method ~S ~A.~%~
319                Standard method combination requires all methods to have one~%~
320                of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
321                have no qualifier at all."
322               method why)))
323       (dolist (m applicable-methods)
324         (let ((qualifiers (if (listp m)
325                             (early-method-qualifiers m)
326                             (method-qualifiers m))))
327           (cond
328             ((null qualifiers) (push m primary))
329             ((cdr qualifiers)
330               (lose m "has more than one qualifier"))
331             ((eq (car qualifiers) :around)
332               (push m around))
333             ((eq (car qualifiers) :before)
334               (push m before))
335             ((eq (car qualifiers) :after)
336               (push m after))
337             (t
338               (lose m "has an illegal qualifier"))))))
339     (setq before  (reverse before)
340           after   (reverse after)
341           primary (reverse primary)
342           around  (reverse around))
343     (cond ((null primary)
344            `(error "There is no primary method for the generic function ~S."
345                    ',generic-function))
346           ((and (null before) (null after) (null around))
347            ;; By returning a single call-method `form' here we enable
348            ;; an important implementation-specific optimization.
349            `(call-method ,(first primary) ,(rest primary)))
350           (t
351            (let ((main-effective-method
352                    (if (or before after)
353                        `(multiple-value-prog1
354                           (progn
355                             ,(make-call-methods before)
356                             (call-method ,(first primary)
357                                          ,(rest primary)))
358                           ,(make-call-methods (reverse after)))
359                        `(call-method ,(first primary) ,(rest primary)))))
360              (if around
361                  `(call-method ,(first around)
362                                (,@(rest around)
363                                   (make-method ,main-effective-method)))
364                  main-effective-method))))))
365 \f
366 ;;;; the STANDARD method combination type. This is coded by hand
367 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
368 ;;;; and efficiency reasons. Note that the definition of the
369 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
370 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
371 ;;;; bootstrap.
372 ;;;;
373 ;;;; The DEFCLASS for the METHOD-COMBINATION and
374 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
375 ;;;; reason. This code must conform to the code in the file
376 ;;;; defcombin.lisp, look there for more details.
377
378 (defun compute-effective-method (generic-function combin applicable-methods)
379   (standard-compute-effective-method generic-function
380                                      combin
381                                      applicable-methods))
382
383 (defun invalid-method-error (method format-control &rest format-arguments)
384   (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
385          method
386          format-control
387          format-arguments))
388
389 (defun method-combination-error (format-control &rest format-arguments)
390   (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
391          format-control
392          format-arguments))