source: trunk/ccl/level-1/l1-dcode.lisp @ 7319

Last change on this file since 7319 was 7319, checked in by wws, 13 years ago

Fix an obscure method combination bug in l1-dcode.lisp that's been
there since Gail and I first implemented CLOS for MCL in 1990 or
thereabouts.

compute-method-list takes a list of possibly applicable methods,
separates it up into before, after, around, and primary methods, and
trims the tail of the around/primary methods at the point where
there's no more call-next-method. Thing is, unless we're computing the
methods for the last specialized argument, those methods are only
POSSIBLY applicable. Some of them might not be. Hence, except for the
final specialized argument, when sub-dispatch? is false, only if no
around method does call-next-method will it be impossible to reach the
primary methods, and we can't trim the primary methods at all.

This fixes Gary Palter's no-applicable-method bug in the application
conversion he's working on.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 74.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(in-package "CCL")
19
20
21
22
23
24
25(defun %make-gf-instance (class &key
26                                name
27                                (method-combination *standard-method-combination* mcomb-p)
28                                (method-class *standard-method-class* mclass-p)
29                                declarations
30                                (lambda-list nil ll-p)
31                                (argument-precedence-order nil apo-p)
32                                &allow-other-keys)
33  (when mcomb-p
34    (unless (typep method-combination 'method-combination)
35      (report-bad-arg method-combination 'method-combination)))
36  (when mclass-p
37    (if (symbolp method-class)
38      (setq method-class (find-class method-class)))
39    (unless (subtypep method-class *method-class*)
40      (error "~s is not a subtype of ~s." method-class *method-class*)))
41  (when declarations
42    (unless (list-length declarations)
43      (error "~s is not a proper list" declarations)))
44  ;; Fix APO, lambda-list
45  (if apo-p
46    (if (not ll-p)
47      (error "Cannot specify ~s without specifying ~s" :argument-precedence-order
48             :lambda-list)))
49  (let* ((gf (%allocate-gf-instance class)))
50    (setf (sgf.name gf) name
51          (sgf.method-combination gf) method-combination
52          (sgf.methods gf) nil
53          (sgf.method-class gf) method-class
54          (sgf.decls gf) declarations
55          (sgf.%lambda-list gf) :unspecified
56          (sgf.dependents gf) nil)
57    (when ll-p
58      (if apo-p
59        (set-gf-arg-info gf :lambda-list lambda-list
60                         :argument-precedence-order argument-precedence-order)
61        (set-gf-arg-info gf :lambda-list lambda-list)))
62    gf))
63
64(defun gf-arg-info-valid-p (gf)
65  (let* ((bits (lfun-bits gf)))
66    (declare (fixnum bits))
67    (not (and (logbitp $lfbits-aok-bit bits)
68              (not (logbitp $lfbits-keys-bit bits))))))
69
70;;; Derive a GF lambda list from the method's lambda list.
71(defun flatten-method-lambda-list (lambda-list)
72  (collect ((ll))
73    (dolist (x lambda-list (ll))
74      (if (atom x)
75        (if (eq x '&aux)
76          (return (ll))
77          (ll x))
78        (ll (car x))))))
79         
80(defun %maybe-compute-gf-lambda-list (gf method)
81  (let* ((gf-ll (sgf.%lambda-list gf)))
82    (if (eq gf-ll :unspecified)
83      (and method
84           (let* ((method-lambda-list (%method-lambda-list method))
85                  (method-has-&key (member '&key method-lambda-list))
86                  (method-has-&allow-other-keys
87                   (member '&allow-other-keys method-lambda-list)))
88             (if method-has-&key
89               (nconc (ldiff method-lambda-list (cdr method-has-&key))
90                      (if method-has-&allow-other-keys
91                        '(&allow-other-keys)))
92               (flatten-method-lambda-list method-lambda-list))))
93      gf-ll)))
94             
95             
96;;; Borrowed from PCL, sort of.  We can encode required/optional/restp/keyp
97;;; information in the gf's lfun-bits
98(defun set-gf-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
99                           (argument-precedence-order nil apo-p))
100  (let* ((methods (%gf-methods gf))
101         (dt (%gf-dispatch-table gf))
102         (gf-lfun-bits (lfun-bits gf))
103         (first-method-p (and new-method (null methods))))
104    (declare (fixnum gf-lfun-bits))
105    (unless lambda-list-p
106      (setq lambda-list
107            (%maybe-compute-gf-lambda-list gf (or (car (last methods))
108                                                  new-method))))
109    (when (or lambda-list-p
110              (and first-method-p
111                   (eq (%gf-%lambda-list gf) :unspecified)))
112      (multiple-value-bind (newbits keyvect)
113          (encode-lambda-list lambda-list t)
114        (declare (fixnum newbits))
115        (when (and methods (not first-method-p))
116          (unless (and (= (ldb $lfbits-numreq gf-lfun-bits)
117                          (ldb $lfbits-numreq newbits))
118                       (= (ldb $lfbits-numopt gf-lfun-bits)
119                          (ldb $lfbits-numopt newbits))
120                       (eq (or (logbitp $lfbits-keys-bit gf-lfun-bits)
121                               (logbitp $lfbits-rest-bit gf-lfun-bits)
122                               (logbitp $lfbits-restv-bit gf-lfun-bits))
123                           (or (logbitp $lfbits-keys-bit newbits)
124                               (logbitp $lfbits-rest-bit newbits)
125                               (logbitp $lfbits-restv-bit newbits))))
126            (error "New lambda list ~s of generic function ~s is not
127congruent with lambda lists of existing methods." lambda-list gf)))
128        (when lambda-list-p
129          (setf (%gf-%lambda-list gf) lambda-list
130                (%gf-dispatch-table-keyvect dt) keyvect))
131        (when (and apo-p lambda-list-p)
132          (let* ((old-precedence-list (%gf-dispatch-table-precedence-list dt)))
133            (setf (%gf-dispatch-table-precedence-list dt)
134                  (canonicalize-argument-precedence-order
135                   argument-precedence-order
136                   (required-lambda-list-args lambda-list)))
137            (unless (equal old-precedence-list
138                           (%gf-dispatch-table-precedence-list dt))
139              (clear-gf-dispatch-table dt))))
140        (lfun-bits gf (logior (ash 1 $lfbits-gfn-bit)
141                              (logand $lfbits-args-mask newbits)))))
142    (when new-method
143      (check-defmethod-congruency gf new-method))))
144       
145(defun %gf-name (gf &optional (new-name nil new-name-p))
146  (let* ((old-name (%standard-generic-function-instance-location-access
147                    gf sgf.name)))
148    (if new-name-p
149      (setf (sgf.name gf) new-name))
150    (unless (eq old-name (%slot-unbound-marker))
151      old-name)))
152
153
154
155             
156(defun make-n+1th-arg-combined-method (methods gf argnum)
157  (let ((table (make-gf-dispatch-table)))
158    (setf (%gf-dispatch-table-methods table) methods
159          (%gf-dispatch-table-argnum table) (%i+ 1 argnum))
160    (let ((self (%cons-combined-method gf table #'%%nth-arg-dcode))) ; <<
161      (setf (%gf-dispatch-table-gf table) self)
162      self)))
163
164;;; Bring the generic function to the smallest possible size by removing
165;;; any cached recomputable info.  Currently this means clearing out the
166;;; combined methods from the dispatch table.
167
168(defun clear-gf-cache (gf)
169  #-bccl (unless t (typep gf 'standard-generic-function) 
170           (report-bad-arg gf 'standard-generic-function))
171  (let ((dt (%gf-dispatch-table gf)))
172    (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*)
173      (clear-gf-dispatch-table dt)
174      (let ((new (make-gf-dispatch-table)))
175        (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt))
176        (setf (%gf-dispatch-table-precedence-list new)
177              (%gf-dispatch-table-precedence-list dt))
178        (setf (%gf-dispatch-table-gf new) gf)
179        (setf (%gf-dispatch-table-keyvect new)
180              (%gf-dispatch-table-keyvect dt))
181        (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt))
182        (setf (%gf-dispatch-table gf) new)))))
183
184(defun %gf-dispatch-table-store-conditional (dt index new)
185  "Returns T if the new value can be stored in DT at INDEX, replacing a NIL.
186   Returns NIL - without storing anything - if the value already in DT
187   at INDEX is non-NIL at the time of the store."
188  (%store-node-conditional (+ (ash (%i+ index %gf-dispatch-table-first-data)
189                                   target::word-shift)
190                              target::misc-data-offset)
191                           dt nil new))
192
193(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p)
194  ;; Grow the table associated with gf and insert table-entry as the value for
195  ;; wrapper.  Wrapper is a class-wrapper.  Assumes that it is not obsolete.
196  (let* ((dt (if (generic-function-p gf-or-cm)
197               (%gf-dispatch-table gf-or-cm)
198               (%combined-method-methods gf-or-cm)))
199         (size (%gf-dispatch-table-size dt))
200         (new-size (if obsolete-wrappers-p
201                     size
202                     (%i+ size size)))
203         new-dt)
204    (if (> new-size *max-gf-dispatch-table-size*)
205      (progn 
206        (setq new-dt (clear-gf-dispatch-table dt)
207                   *gf-dt-ovf-cnt* (%i+ *gf-dt-ovf-cnt* 1)))
208      (progn
209        (setq new-dt (make-gf-dispatch-table new-size))
210        (setf (%gf-dispatch-table-methods new-dt) (%gf-dispatch-table-methods dt)
211              (%gf-dispatch-table-precedence-list new-dt) (%gf-dispatch-table-precedence-list dt)
212              (%gf-dispatch-table-keyvect new-dt) (%gf-dispatch-table-keyvect dt)
213              (%gf-dispatch-table-gf new-dt) gf-or-cm
214              (%gf-dispatch-table-argnum new-dt) (%gf-dispatch-table-argnum dt))
215        (let ((i 0) index w cm)
216          (dotimes (j (%ilsr 1 (%gf-dispatch-table-size dt)))
217            (declare (fixnum j))
218            (unless (or (null (setq w (%gf-dispatch-table-ref dt i)))
219                        (eql 0 (%wrapper-hash-index w))
220                        (no-applicable-method-cm-p
221                         (setq cm (%gf-dispatch-table-ref dt (%i+ i 1)))))
222              (setq index (find-gf-dispatch-table-index new-dt w t))
223              (setf (%gf-dispatch-table-ref new-dt index) w)
224              (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) cm))
225            (setq i (%i+ i 2))))))
226    (let ((index (find-gf-dispatch-table-index new-dt wrapper t)))
227      (setf (%gf-dispatch-table-ref new-dt index) wrapper)
228      (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) table-entry))
229    (if (generic-function-p gf-or-cm)
230      (setf (%gf-dispatch-table gf-or-cm) new-dt)
231      (setf (%combined-method-methods gf-or-cm) new-dt))))
232
233
234(defun inner-lfun-bits (function &optional value)
235  (lfun-bits (closure-function function) value))
236
237
238
239;;; probably want to use alists vs. hash-tables initially
240
241
242;;; only used if error - well not really
243(defun collect-lexpr-args (args first &optional last) 
244  (if (listp args)
245    (subseq args first (or last (length args)))
246    (let ((res nil))
247      (when (not last)(setq last (%lexpr-count args)))
248      (dotimes (i (- last first))
249        (setq res (push (%lexpr-ref args last (+ first i)) res)))
250      (nreverse res))))
251
252
253
254
255(defmacro with-list-from-lexpr ((list lexpr) &body body)
256  (let ((len (gensym)))
257    `(let* ((,len (%lexpr-count ,lexpr))
258            (,list  (make-list ,len)))
259       (declare (dynamic-extent ,list) (fixnum ,len))       
260       (do* ((i 0 (1+ i))
261             (ls ,list (cdr ls)))
262            ((= i ,len) ,list)
263         (declare (fixnum i) (list ls))
264         (declare (optimize (speed 3)(safety 0)))
265         (%rplaca ls (%lexpr-ref ,lexpr ,len i)))
266       ,@body)))
267
268
269
270(defmacro %standard-instance-p (i)
271  `(eq (typecode ,i) ,(type-keyword-code :instance)))
272
273
274
275(declaim (inline %find-1st-arg-combined-method))
276(declaim (inline %find-nth-arg-combined-method))
277
278
279; for calls from outside - e.g. stream-reader
280(defun find-1st-arg-combined-method (gf arg)
281  (declare (optimize (speed 3)(safety 0)))
282  (%find-1st-arg-combined-method (%gf-dispatch-table gf) arg))
283
284
285(defun %find-1st-arg-combined-method (dt arg)
286  (declare (optimize (speed 3)(safety 0)))
287  (flet ((get-wrapper (arg)
288           (if (not (%standard-instance-p arg))
289             (or (and (typep arg 'macptr)
290                      (foreign-instance-class-wrapper arg))
291                 (and (generic-function-p arg)
292                      (gf.instance.class-wrapper arg))
293                 (let* ((class (class-of arg)))
294                   (or (%class.own-wrapper class)
295                       (progn
296                         (update-class class nil)
297                         (%class.own-wrapper class)))))
298             (instance.class-wrapper arg))))
299    (declare (inline get-wrapper))
300    (let ((wrapper (get-wrapper arg)))
301      (when (eql 0 (%wrapper-hash-index wrapper))
302        (update-obsolete-instance arg)
303        (setq wrapper (get-wrapper arg)))
304      (let* ((mask (%gf-dispatch-table-mask dt))
305             (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
306             table-wrapper flag)
307        (declare (fixnum index mask))
308        (loop 
309          (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
310            (return (%gf-dispatch-table-ref dt  (the fixnum (1+ index))))
311            (progn
312              (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
313                (if (or (neq table-wrapper (%unbound-marker))
314                        (eql 0 flag))
315                  (without-interrupts   ; why?
316                   (return (1st-arg-combined-method-trap (%gf-dispatch-table-gf dt) wrapper arg))) ; the only difference?
317                  (setq flag 0 index -2)))
318              (setq index (+ 2 index)))))))))
319
320;;; more PC - it it possible one needs to go round more than once? -
321;;; seems unlikely
322(defun %find-nth-arg-combined-method (dt arg args) 
323  (declare (optimize (speed 3)(safety 0)))
324  (flet ((get-wrapper (arg)
325           (if (not (%standard-instance-p arg))
326             (or (and (typep arg 'macptr)
327                      (foreign-instance-class-wrapper arg))
328                 (and (generic-function-p arg)
329                      (gf.instance.class-wrapper arg))
330                 (let* ((class (class-of arg)))
331                   (or (%class.own-wrapper class)
332                       (progn
333                         (update-class class nil)
334                         (%class.own-wrapper class)))))
335             (instance.class-wrapper arg))))
336    (declare (inline get-wrapper))
337    (let ((wrapper (get-wrapper arg)))
338      (when (eql 0 (%wrapper-hash-index wrapper))
339        (update-obsolete-instance arg)
340        (setq wrapper (get-wrapper arg)))
341      (let* ((mask (%gf-dispatch-table-mask dt))
342             (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
343             table-wrapper flag)
344        (declare (fixnum index mask))
345        (loop 
346          (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
347            (return (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
348            (progn
349              (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
350                (if (or (neq table-wrapper (%unbound-marker))
351                        (eql 0 flag))
352                  (without-interrupts ; why?
353                   (let ((gf (%gf-dispatch-table-gf dt)))
354                     (if (listp args)
355                       (return (nth-arg-combined-method-trap-0 gf dt wrapper args))
356                       (with-list-from-lexpr (args-list args)
357                         (return (nth-arg-combined-method-trap-0 gf dt wrapper args-list))))))
358                  (setq flag 0 index -2)))
359              (setq index (+ 2 index)))))))))
360
361
362
363
364;;;;;;;;;;;;;;;;;;;;;;;;;;; Generic functions and methods ;;;;;;;;;;;;;;;;;;;;
365(defun %class-cpl (class)
366  (if (%standard-instance-p class)
367    (%class.cpl class)
368    (or
369     (and (typep class 'macptr)
370          (let* ((slots (foreign-slots-vector class)))
371            (and slots (%slot-ref slots %class.cpl))))
372     (error "Can't determine CPL of class ~s" class))))
373
374
375(defun standard-method-p (thing)
376  (when (%standard-instance-p thing)
377    (let* ((cpl (%class-cpl (%wrapper-class (instance.class-wrapper thing))))
378           (smc *standard-method-class*))
379      (dolist (c cpl)
380        (if (eq c smc)(return t))))))
381
382
383
384(defun %method-function-p (thing)
385  (when (functionp thing)
386    (let ((bits (lfun-bits thing)))
387      (declare (fixnum bits))
388      (logbitp $lfbits-method-bit bits))))
389
390
391
392
393(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p)
394(setf (type-predicate 'combined-method) 'combined-method-p)
395
396(setf (type-predicate 'standard-method) 'standard-method-p)
397
398;; Maybe we shouldn't make this a real type...
399(setf (type-predicate 'method-function) '%method-function-p)
400
401
402(defvar %all-gfs% (%cons-population nil))
403
404
405(eval-when (:compile-toplevel :execute)
406(defconstant $lfbits-numinh-mask (logior (dpb -1 $lfbits-numinh 0)
407                                         (%ilsl $lfbits-nonnullenv-bit 1)))
408)
409
410
411#+ppc-target
412(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 0))
413
414
415#+ppc-target
416(defvar *unset-fin-code* (uvref #'unset-fin-trampoline 0))
417
418
419
420#+ppc-target
421(defvar *gf-proto-code* (uvref *gf-proto* 0))
422
423;;; The "early" version of %ALLOCATE-GF-INSTANCE.
424(setf (fdefinition '%allocate-gf-instance)
425      #'(lambda (class)
426          (declare (ignorable class))
427          (setq class *standard-generic-function-class*)
428          (let* ((wrapper (%class.own-wrapper class))
429                 (len (length #.(%wrapper-instance-slots (class-own-wrapper
430                                                          *standard-generic-function-class*))))
431                 (dt (make-gf-dispatch-table))
432                 (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
433                 (fn #+ppc-target
434                   (gvector :function
435                              *gf-proto-code*
436                              wrapper
437                              slots
438                              dt
439                              #'%%0-arg-dcode
440                              0
441                              (%ilogior (%ilsl $lfbits-gfn-bit 1)
442                                        (%ilogand $lfbits-args-mask 0)))
443                   #+x86-target
444                   (%clone-x86-function *gf-proto*
445                                        wrapper
446                                        slots
447                                        dt
448                                        #'%%0-arg-dcode
449                                        0
450                                        (%ilogior (%ilsl $lfbits-gfn-bit 1)
451                                                  (%ilogand $lfbits-args-mask 0)))))
452            (setf (gf.hash fn) (strip-tag-to-fixnum fn)
453                  (slot-vector.instance slots) fn
454                  (%gf-dispatch-table-gf dt) fn)
455            (push fn (population.data %all-gfs%))
456            fn)))
457
458
459
460
461
462
463 
464
465
466(defparameter *gf-proto-one-arg*  #'gag-one-arg)
467(defparameter *gf-proto-two-arg*  #'gag-two-arg)
468
469
470
471
472#+ppc-target
473(defvar *cm-proto-code* (uvref *cm-proto* 0))
474
475(defun %cons-combined-method (gf thing dcode)
476  ;; set bits and name = gf
477  #+ppc-target
478  (gvector :function
479           *cm-proto-code*
480           thing
481           dcode
482           gf
483           (%ilogior (%ilsl $lfbits-cm-bit 1)
484                            (%ilogand $lfbits-args-mask (lfun-bits gf))))
485  #+x86-target
486  (%clone-x86-function *cm-proto*
487                       thing
488                       dcode
489                       gf
490                       (%ilogior (%ilsl $lfbits-cm-bit 1)
491                                 (%ilogand $lfbits-args-mask (lfun-bits gf)))))
492
493(defun %gf-dispatch-table (gf)
494  ;(require-type gf 'standard-generic-function)
495  (gf.dispatch-table gf))
496
497(defun %gf-dcode (gf)
498  ;(require-type gf 'standard-generic-function)
499  (gf.dcode gf))
500
501(defun %set-gf-dcode (gf val)
502  (setf (gf.dcode gf) val))
503
504(defun %set-gf-dispatch-table (gf val)
505  (setf (gf.dispatch-table gf) val))
506
507
508(defun %combined-method-methods  (cm)
509  ;(require-type cm 'combined-method)
510  (combined-method.thing cm))
511
512(defun %combined-method-dcode (cm)
513  ;(require-type cm 'combined-method)
514  (combined-method.dcode cm))
515
516(defun %set-combined-method-methods (cm val)
517  (setf (combined-method.thing cm) val))
518
519(defun %set-combined-method-dcode (cm val)
520  (setf (combined-method.dcode cm) val))
521
522(defun funcallable-instance-p (thing)
523  (when (typep thing 'function)
524    (let ((bits (lfun-bits-known-function thing)))
525      (declare (fixnum bits))
526      (eq (ash 1 $lfbits-gfn-bit)
527          (logand bits (logior (ash 1 $lfbits-gfn-bit)
528                               (ash 1 $lfbits-method-bit)))))))
529
530(defstatic *generic-function-class-wrapper* nil)
531(defstatic *standard-generic-function-class-wrapper* nil)
532
533(defun generic-function-p (thing)
534  (and (typep thing 'function)
535       (let ((bits (lfun-bits-known-function thing)))
536         (declare (fixnum bits))
537         (eq (ash 1 $lfbits-gfn-bit)
538             (logand bits (logior (ash 1 $lfbits-gfn-bit)
539                                  (ash 1 $lfbits-method-bit)))))
540       (let* ((wrapper (gf.instance.class-wrapper thing)))
541         ;; In practice, many generic-functions are standard-generic-functions.
542         (or (eq *standard-generic-function-class-wrapper* wrapper)
543             (eq *generic-function-class-wrapper* wrapper)
544             (memq  *generic-function-class*
545                  (%inited-class-cpl (class-of thing)))))))
546
547
548(defun standard-generic-function-p (thing)
549  (and (typep thing 'function)
550       (let ((bits (lfun-bits-known-function thing)))
551         (declare (fixnum bits))
552         (eq (ash 1 $lfbits-gfn-bit)
553             (logand bits (logior (ash 1 $lfbits-gfn-bit)
554                                  (ash 1 $lfbits-method-bit)))))
555       (or (eq (%class.own-wrapper *standard-generic-function-class*)
556               (gf.instance.class-wrapper thing))
557           (memq  *standard-generic-function-class*
558                  (%inited-class-cpl (class-of thing))))))
559
560
561(defun combined-method-p (thing)
562  (when (functionp thing)
563    (let ((bits (lfun-bits-known-function thing)))
564      (declare (fixnum bits))
565      (eq (ash 1 $lfbits-cm-bit)
566          (logand bits
567                  (logior (ash 1 $lfbits-cm-bit)
568                          (ash 1 $lfbits-method-bit)))))))
569
570(setf (type-predicate 'generic-function) 'generic-function-p)
571
572(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p)
573(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p)
574(setf (type-predicate 'combined-method) 'combined-method-p)
575
576
577
578;;; A generic-function looks like:
579;;;
580;;; header | trampoline |  dispatch-table | dcode | name | bits
581;;; %svref :    0              1              2       3      4
582;;;
583;;; The trampoline is *gf-proto*'s code vector.
584;;; The dispatch-table and dcode are sort of settable closed-over variables.
585
586(defsetf %gf-dispatch-table %set-gf-dispatch-table)
587
588(defun %gf-methods (gf)
589  (sgf.methods gf))
590
591(defun %gf-precedence-list (gf)
592  (%gf-dispatch-table-precedence-list (%gf-dispatch-table gf)))
593
594(defun %gf-%lambda-list (gf)
595  (sgf.%lambda-list gf))
596
597(defun (setf %gf-%lambda-list) (new gf)
598  (setf (sgf.%lambda-list gf) new))
599
600;;; Returns INSTANCE if it is either a standard instance of a
601;;; standard gf, else nil.
602(defun %maybe-gf-instance (instance)
603  (if (or (standard-generic-function-p instance)
604          (%standard-instance-p instance))
605    instance))
606
607(defsetf %gf-dcode %set-gf-dcode)
608
609(defun %gf-method-class (gf)
610  (sgf.method-class gf))
611
612
613(defun %gf-method-combination (gf)
614  (sgf.method-combination gf))
615
616(defun %combined-method-methods  (cm)
617  (combined-method.thing cm))
618
619(defun %combined-method-dcode (cm)
620  ;(require-type cm 'combined-method)
621  (combined-method.dcode cm))
622
623
624; need setters too
625
626(defsetf %combined-method-methods %set-combined-method-methods)
627
628(defparameter *min-gf-dispatch-table-size* 2
629  "The minimum size of a generic-function dispatch table")
630
631(defun make-gf-dispatch-table (&optional (size *min-gf-dispatch-table-size*))
632  (when (<= size 0) (report-bad-arg size '(integer 1)))
633  (setq size (%imax (%ilsl (%i- (integer-length (%i+ size size -1))
634                                1)
635                           1)           ; next power of 2
636                    *min-gf-dispatch-table-size*))
637  (let ((res (%cons-gf-dispatch-table size)))
638    (setf (%gf-dispatch-table-mask res) (%i- (%ilsr 1 size) 1)
639          (%gf-dispatch-table-argnum res) 0
640          (%gf-dispatch-table-ref res size) (%unbound-marker))
641    res))
642
643;;; I wanted this to be faster - I didn't
644(defun clear-gf-dispatch-table (dt)
645  (let ((i %gf-dispatch-table-first-data))
646    (dotimes (j (%gf-dispatch-table-size dt))
647      (declare (fixnum j))
648      (setf (%svref dt i) nil 
649            i (%i+ i 1)))
650    (setf (%svref dt i) (%unbound-marker)) ; paranoia...
651    (setf (svref dt (%i+ 1 i)) nil))
652  dt)
653
654
655; Remove all combined-methods from the world
656(defun clear-all-gf-caches ()
657  (dolist (f (population-data %all-gfs%))
658    (clear-gf-cache f))
659  (clrhash *combined-methods*)
660  nil)
661
662
663;;; Searches for an empty slot in dt at the hash-index for wrapper.
664;;; Returns nil if the table was full.
665(defun find-gf-dispatch-table-index (dt wrapper &optional skip-full-check?)
666  (let ((contains-obsolete-wrappers-p nil)
667        (mask (%gf-dispatch-table-mask dt)))
668    (declare (fixnum mask))
669    (unless skip-full-check?
670      (let* ((size (1+ mask))
671             (max-count (- size (the fixnum (ash (the fixnum (+ size 3)) -2))))
672             (index 0)
673             (count 0))
674        (declare (fixnum size max-count index count))
675        (dotimes (i size)
676          (declare (fixnum i))
677          (let ((wrapper (%gf-dispatch-table-ref dt index)))
678            (if wrapper
679              (if (eql 0 (%wrapper-hash-index wrapper))
680                (setf contains-obsolete-wrappers-p t
681                      (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
682                      (%gf-dispatch-table-ref dt (1+ index))
683                      #'(lambda (&rest rest) 
684                          (declare (ignore rest))
685                          (error "Generic-function dispatch bug.")))
686                (setq count (%i+ count 1)))))
687          (setq index (%i+ index 2)))
688        (when (> count max-count)
689          (return-from find-gf-dispatch-table-index (values nil contains-obsolete-wrappers-p)))))
690    (let* ((index (ash (logand mask (%wrapper-hash-index wrapper)) 1))
691           (flag nil)
692           table-wrapper)     
693      (values
694       (loop
695         (while (and (neq wrapper
696                          (setq table-wrapper (%gf-dispatch-table-ref dt index)))
697                     (%gf-dispatch-table-ref dt (1+ index))
698                     (neq 0 (%wrapper-hash-index table-wrapper)))
699           (setq index (%i+ index 2)))
700         (if (eq (%unbound-marker) table-wrapper)
701           (if flag
702             (return nil)         ; table full
703             (setq flag 1
704                   index 0))
705           (return index)))
706       contains-obsolete-wrappers-p))))
707
708
709(defvar *obsolete-wrapper* #(obsolete-wrapper 0))
710(defvar *gf-dispatch-bug*
711  #'(lambda (&rest rest)
712      (declare (ignore rest))
713      (error "Generic-function dispatch bug!")))
714
715 
716;;; This maximum is necessary because of the 32 bit arithmetic in
717;;; find-gf-dispatch-table-index.
718(defparameter *max-gf-dispatch-table-size* (expt 2 16))
719(defvar *gf-dt-ovf-cnt* 0)              ; overflow count
720
721(defvar *no-applicable-method-hash* nil)
722
723
724(let* ((eql-specializers-lock (make-lock))
725       (eql-specializers-hash (make-hash-table :test #'eql)))
726  (defun intern-eql-specializer (object)
727    (with-lock-grabbed (eql-specializers-lock)
728      (or (gethash object eql-specializers-hash)
729          (setf (gethash object eql-specializers-hash)
730                (make-instance 'eql-specializer :object object))))))
731
732
733(setq *no-applicable-method-hash* (make-hash-table :test 'eq :size 0 :weak :key))
734
735
736(defun make-no-applicable-method-function (gf)
737  (if *no-applicable-method-hash*
738    (progn
739      (or (gethash gf *no-applicable-method-hash*))
740      (setf (gethash gf *no-applicable-method-hash*)
741            (%cons-no-applicable-method gf)))
742    (%cons-no-applicable-method gf)))
743
744(defun %cons-no-applicable-method (gf)
745  (%cons-combined-method gf gf #'%%no-applicable-method))
746
747; Returns true if F is a combined-method that calls no-applicable-method
748(defun no-applicable-method-cm-p (f)
749  (and (typep f 'combined-method)
750       (eq '%%no-applicable-method
751           (function-name (%combined-method-dcode f)))))
752
753
754(defun %%no-applicable-method (gf args)
755  (if (listp args)
756    (apply #'no-applicable-method gf args)
757    (%apply-lexpr #'no-applicable-method gf args )))
758
759;;; if obsolete-wrappers-p is true, will rehash instead of grow.
760;;; It would be better to do the rehash in place, but I'm lazy today.
761
762
763(defun arg-wrapper (arg)
764  (or (standard-object-p arg)
765      (%class.own-wrapper (class-of arg))
766      (error "~a has no wrapper" arg)))
767
768;;;;;;;;;;;;;;;;;;;;;;;;; generic-function dcode ;;;;;;;;;;;;;;;;;;;;;;;;;;;
769
770;;; Simple case for generic-functions with no specializers
771;;; Why anyone would want to do this I can't imagine.
772
773(defun %%0-arg-dcode (dispatch-table args) ; need to get gf from table
774  (let ((method (or (%gf-dispatch-table-ref dispatch-table 1)
775                    (0-arg-combined-method-trap
776                     (%gf-dispatch-table-gf dispatch-table)))))
777    (if (not (listp args))
778      (progn
779        (%apply-lexpr-tail-wise method args))
780      (apply method args))))
781
782(defun dcode-too-few-args (arg-count cm-or-gf)
783  (error (make-condition 'too-few-arguments
784                         :nargs arg-count
785                         :fn (combined-method-gf cm-or-gf))))
786
787
788;;; arg passed is dispatch table - add a slot to it containing gf? -
789;;; later or pass the gf instead of the dispatch table (means adding
790;;; another constant to gf to contain the dispatch table- above is
791;;; clearer)
792
793(defun %%1st-arg-dcode (dt  args)
794  ;(declare (dynamic-extent args))
795  (if (not (listp args))
796    (let* ((args-len (%lexpr-count args)))
797      (if (neq 0 args-len) 
798        (let ((method (%find-1st-arg-combined-method dt (%lexpr-ref args args-len 0))))
799          (%apply-lexpr-tail-wise method args))
800        (dcode-too-few-args 0 (%gf-dispatch-table-gf dt))))
801    (let* ()  ; happens if traced
802      (when (null args) (dcode-too-few-args 0 (%gf-dispatch-table-gf dt)))
803      (let ((method (%find-1st-arg-combined-method dt (%car args))))
804        (apply method args)))))
805
806
807(defun %%one-arg-dcode (dt  arg)
808  (let ((method (%find-1st-arg-combined-method dt arg)))
809    (funcall method arg)))
810
811;;; two args - specialized on first
812(defun %%1st-two-arg-dcode (dt arg1 arg2)
813  (let ((method (%find-1st-arg-combined-method dt arg1)))
814    (funcall method arg1 arg2)))
815
816
817
818;;;  arg is dispatch-table and argnum is in the dispatch table
819(defun %%nth-arg-dcode (dt args)
820  (if (listp args)
821    (let* ((args-len (list-length args))
822           (argnum (%gf-dispatch-table-argnum dt)))
823      (declare (fixnum args-len argnum))
824      (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt)))
825      (let ((method (%find-nth-arg-combined-method dt (nth argnum args) args)))
826        (apply method args)))
827    (let* ((args-len (%lexpr-count args))
828           (argnum (%gf-dispatch-table-argnum dt)))
829      (declare (fixnum args-len argnum))
830      (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt)))
831      (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args)))
832        (%apply-lexpr-tail-wise method args)))))
833
834
835(defun 0-arg-combined-method-trap (gf)
836  (let* ((methods (%gf-methods gf))
837         (mc (%gf-method-combination gf))
838         (cm (if (eq mc *standard-method-combination*)
839               (make-standard-combined-method methods nil gf)
840               (compute-effective-method-function 
841                gf 
842                mc
843                (sort-methods (copy-list methods) nil)))))
844    (setf (%gf-dispatch-table-ref (%gf-dispatch-table gf) 1) cm)
845    cm))
846
847(defun compute-effective-method-function (gf mc methods) 
848  (if methods
849    (compute-effective-method gf mc methods)
850    (make-no-applicable-method-function gf)))
851
852(defun 1st-arg-combined-method-trap (gf wrapper arg)
853  ;; Here when we can't find the method in the dispatch table.
854  ;; Compute it and add it to the table.  This code will remain in Lisp.
855  (let ((table (%gf-dispatch-table gf))
856        (combined-method (compute-1st-arg-combined-method gf arg wrapper)))
857    (multiple-value-bind (index obsolete-wrappers-p)
858                         (find-gf-dispatch-table-index table wrapper)
859      (if index
860        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
861          (setf (%gf-dispatch-table-ref table index) wrapper))
862        (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
863    combined-method))
864
865(defvar *cpl-classes* nil)
866
867(defun %inited-class-cpl (class &optional initialize-can-fail)
868  (or (%class-cpl class)
869      (if (memq class *cpl-classes*)
870        (compute-cpl class)
871        (let ((*cpl-classes* (cons class *cpl-classes*)))
872          (declare (dynamic-extent *cpl-classes*))
873          (update-class class initialize-can-fail)
874          (%class-cpl class)))))
875
876
877(defun compute-1st-arg-combined-method (gf arg &optional 
878                                           (wrapper (arg-wrapper arg)))
879  (let* ((methods (%gf-dispatch-table-methods (%gf-dispatch-table gf)))
880         (cpl (%inited-class-cpl (%wrapper-class wrapper)))
881         (method-combination (%gf-method-combination gf))
882         applicable-methods eql-methods specializer)
883    (dolist (method methods)
884      (setq specializer (%car (%method.specializers method)))
885      (if (typep specializer 'eql-specializer)
886        (when (cpl-memq (%wrapper-class (arg-wrapper (eql-specializer-object specializer))) cpl)
887          (push method eql-methods))
888        (when (cpl-memq specializer cpl)
889          (push method applicable-methods))))
890    (if (null eql-methods)
891      (if (eq method-combination *standard-method-combination*)
892        (make-standard-combined-method applicable-methods (list cpl) gf)
893        (compute-effective-method-function 
894         gf 
895         method-combination
896         (sort-methods applicable-methods
897                       (list cpl)
898                       (%gf-precedence-list gf))))
899      (make-eql-combined-method 
900       eql-methods applicable-methods (list cpl) gf 0 nil method-combination))))
901     
902
903
904(defvar *combined-methods* (make-hash-table  :test 'equal :weak :value))                         
905
906(defun gethash-combined-method (key)
907  (gethash key *combined-methods*))
908
909(defun puthash-combined-method (key value)
910  (setf (gethash key *combined-methods*) value))
911
912;;; Some statistics on the hash table above
913(defvar *returned-combined-methods* 0)
914(defvar *consed-combined-methods* 0)
915
916;;; Assumes methods are already sorted if cpls is nil
917(defun make-standard-combined-method (methods cpls gf &optional
918                                              (ok-if-no-primaries (null methods)))
919  (unless (null cpls)
920    (setq methods (sort-methods 
921                   methods cpls (%gf-precedence-list (combined-method-gf gf)))))
922  (let* ((keywords (compute-allowable-keywords-vector gf methods))
923         (combined-method (make-standard-combined-method-internal
924                           methods gf keywords ok-if-no-primaries)))
925    (if (and keywords methods)
926      (make-keyword-checking-combined-method gf combined-method keywords)
927      combined-method)))
928
929
930;;; Initialized below after the functions exist.
931(defvar *clos-initialization-functions* nil)
932
933;;; Returns NIL if all keywords allowed, or a vector of the allowable ones.
934(defun compute-allowable-keywords-vector (gf methods)
935  (setq gf (combined-method-gf gf))
936  (unless (memq gf *clos-initialization-functions*)
937    (let* ((gbits (inner-lfun-bits gf))
938           (&key-mentioned-p (logbitp $lfbits-keys-bit gbits)))
939      (unless (or (logbitp $lfbits-aok-bit gbits)
940                  (dolist (method methods)
941                    (let ((mbits (lfun-bits (%method.function method))))
942                      (when (logbitp $lfbits-keys-bit mbits)
943                        (setq &key-mentioned-p t)
944                        (if (logbitp $lfbits-aok-bit mbits)
945                          (return t)))))
946                  (not &key-mentioned-p))
947        (let (keys)
948          (flet ((adjoin-keys (keyvect keys)
949                              (when keyvect
950                                (dovector (key keyvect) (pushnew key keys)))
951                              keys))
952            (when (logbitp $lfbits-keys-bit gbits)
953              (setq keys (adjoin-keys (%defgeneric-keys gf) keys)))
954            (dolist (method methods)
955              (let ((f (%inner-method-function method)))
956                (when (logbitp $lfbits-keys-bit (lfun-bits f))
957                  (setq keys (adjoin-keys (lfun-keyvect f) keys))))))
958          (apply #'vector keys))))))
959
960
961(defun make-keyword-checking-combined-method (gf combined-method keyvect)
962  (let* ((bits (inner-lfun-bits gf))
963         (numreq (ldb $lfbits-numreq bits))
964         (key-index (+ numreq (ldb $lfbits-numopt bits))))
965    (%cons-combined-method 
966     gf       
967     (vector key-index keyvect combined-method)
968     #'%%check-keywords)))
969
970
971
972(defun odd-keys-error (varg l) 
973  (let ((gf (combined-method-gf (%svref varg 2))))
974    (signal-program-error "Odd number of keyword args to ~s~%keyargs: ~s" gf l)))
975
976
977(defun bad-key-error (key varg l)
978  (let* ((keys (%svref varg 1))
979         (gf (combined-method-gf (%svref varg 2)))
980         (*print-array* t)
981         (*print-readably* t)
982         (readable-keys (format nil "~s" keys)))
983    (signal-program-error "Bad keyword ~s to ~s.~%keyargs: ~s~%allowable keys are ~a." key gf l readable-keys)))
984
985; vector arg is (vector key-index keyvect combined-method) ; the next combined method
986
987(defun %%check-keywords (vector-arg args)
988  (flet ((do-it (vector-arg args)
989           (let* ((args-len (length args))
990                  (keyvect (%svref vector-arg 1))
991                  (keyvect-len (length keyvect))
992                  (key-index (%svref vector-arg 0)))
993                                        ; vector arg is (vector key-index keyvect combined-method) ; the next combined method
994             (declare (fixnum args-len key-index keyvect-len))
995             (when (>= args-len key-index)
996               (let* ((keys-in (- args-len key-index))) ; actually * 2
997                 (declare (fixnum  key-index keys-in keyvect-len))
998                 (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len)))
999                 (unless (%cadr (%pl-search (nthcdr key-index args) :allow-other-keys))
1000                   (do ((i key-index (+ i 2))
1001                        (kargs (nthcdr key-index args) (cddr kargs)))
1002                       ((eq i args-len))
1003                     (declare (fixnum i))
1004                     (let ((key (car kargs)))
1005                       (when (not (or (eq key :allow-other-keys)
1006                                      (dotimes (i keyvect-len nil)
1007                                        (if (eq key (%svref keyvect i))
1008                                          (return t)))))
1009                         (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len))
1010                         ))))))
1011             (let ((method (%svref vector-arg 2)))
1012                                        ; magic here ?? not needed
1013               (apply method args)))))
1014    (if (listp args)
1015      (do-it vector-arg args)
1016      (with-list-from-lexpr (args-list args)
1017        (do-it vector-arg args-list)))))
1018
1019
1020
1021 
1022
1023
1024;;; called from %%call-next-method-with-args - its the key-or-init-fn
1025;;; called from call-next-method-with-args - just check the blooming keys
1026;;; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil
1027; means dont call any methods - but need the gf or method for error message
1028(defun x-%%check-keywords (vector-arg ARGS)
1029  ;(declare (dynamic-extent args))
1030    ; vector arg is (vector key-index keyvect unused)
1031  (let* ((ARGS-LEN (length args))
1032         (keyvect (%svref vector-arg 1))
1033         (keyvect-len (length keyvect))
1034         (key-index (%svref vector-arg 0))
1035         (keys-in (- args-len key-index))
1036         aok)  ; actually * 2
1037    (declare (fixnum args-len key-index keys-in keyvect-len))
1038   
1039    (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len)))
1040    (do ((i key-index (+ i 2))
1041         (kargs (nthcdr key-index args) (cddr kargs)))
1042        ((eq i args-len))
1043      (declare (fixnum i))
1044      (when aok (return))
1045      (let ((key (car kargs)))
1046        (when (and (eq key :allow-other-keys)
1047                   (cadr kargs))
1048          (return))
1049        (when (not (dotimes (i keyvect-len nil)
1050                     (if (eq key (%svref keyvect i))
1051                       (return t))))
1052          ; not found - is :allow-other-keys t in rest of user args
1053          (when (not (do ((remargs kargs (cddr remargs)))
1054                         ((null remargs) nil)
1055                       (when (and (eq (car remargs) :allow-other-keys)
1056                                  (cadr remargs))
1057                         (setq aok t)
1058                         (return t))))             
1059            (bad-key-error key vector-arg 
1060                           (collect-lexpr-args args key-index args-len))))))))
1061#| ; testing
1062(setq keyvect  #(:a :b ))
1063(setq foo (make-array 3))
1064(setf (aref foo 0) keyvect (aref foo 1) 2)
1065(setf (aref foo 2)(method window-close (window)))
1066( %%check-keywords 1 2 :a 3 :c 4 foo)
1067( %%check-keywords 1 2 :a 3 :b 4 :d foo)
1068|#
1069 
1070   
1071
1072
1073
1074;;; Map an effective-method to it's generic-function.
1075;;; This is only used for effective-method's which are not combined-method's
1076;;; (e.g. those created by non-STANDARD method-combination)
1077(defvar *effective-method-gfs* (make-hash-table :test 'eq :weak :key))
1078
1079
1080(defun get-combined-method (method-list gf)
1081  (let ((cm (gethash-combined-method method-list)))
1082    (when cm
1083      (setq gf (combined-method-gf gf))
1084      (if (combined-method-p cm)
1085        (and (eq (combined-method-gf cm) gf) cm)
1086        (and (eq (gethash cm *effective-method-gfs*) gf) cm)))))
1087
1088(defun put-combined-method (method-list cm gf)
1089  (unless (%method-function-p cm)       ; don't bother with non-combined methods
1090    (puthash-combined-method method-list cm)
1091    (unless (combined-method-p cm)
1092      (setf (gethash cm *effective-method-gfs*) (combined-method-gf gf))))
1093  cm)
1094
1095(defun make-standard-combined-method-internal (methods gf &optional 
1096                                                       keywords
1097                                                       (ok-if-no-primaries
1098                                                        (null methods)))
1099  (let ((method-list (and methods (compute-method-list methods nil))))
1100    (if method-list                 ; no applicable primary methods
1101      (if (atom method-list)
1102        (%method.function method-list)    ; can jump right to the method-function
1103        (progn
1104          (incf *returned-combined-methods*)  ; dont need this
1105          (if (contains-call-next-method-with-args-p method-list)
1106            (make-cnm-combined-method gf methods method-list keywords)
1107            (or (get-combined-method method-list gf)
1108                (progn
1109                  (incf *consed-combined-methods*)  ; dont need this
1110                  (puthash-combined-method
1111                   method-list
1112                   (%cons-combined-method
1113                    gf method-list #'%%standard-combined-method-dcode)))))))
1114      (if ok-if-no-primaries
1115        (make-no-applicable-method-function (combined-method-gf gf))
1116        (no-applicable-primary-method gf methods)))))
1117
1118; Initialized after the initialization (generic) functions exist.
1119(defvar *initialization-functions-alist* nil)
1120
1121;;; This could be in-line above, but I was getting confused.
1122
1123;;; ok
1124(defun make-cnm-combined-method (gf methods method-list keywords)
1125  (setq gf (combined-method-gf gf))
1126  (let ((key (cons methods method-list)))
1127    (or (get-combined-method key gf)
1128        (let* (key-or-init-arg
1129               key-or-init-fn)
1130          (if keywords
1131            (let* ((bits (inner-lfun-bits gf))
1132                   (numreq (ldb $lfbits-numreq bits))
1133                   (key-index (+ numreq (ldb $lfbits-numopt bits))))
1134              (setq key-or-init-arg (vector key-index keywords gf))
1135              (setq key-or-init-fn #'x-%%check-keywords))
1136            (let ((init-cell (assq gf *initialization-functions-alist*)))
1137              (when init-cell               
1138                (setq key-or-init-arg init-cell)
1139                (setq key-or-init-fn #'%%cnm-with-args-check-initargs))))
1140          (incf *consed-combined-methods*)
1141          (let* ((vect (vector gf methods key-or-init-arg key-or-init-fn method-list))
1142                 (self (%cons-combined-method
1143                        gf vect #'%%cnm-with-args-combined-method-dcode)))
1144            ;(setf (svref vect 4) self)
1145            (puthash-combined-method ; if  testing 1 2 3 dont put in our real table
1146             key
1147             self))))))
1148
1149
1150(defparameter *check-call-next-method-with-args* t)
1151
1152(defun contains-call-next-method-with-args-p (method-list)
1153  (when *check-call-next-method-with-args*
1154    (let ((methods method-list)
1155          method)
1156      (loop
1157        (setq method (pop methods))
1158        (unless methods (return nil))
1159        (unless (listp method)
1160          (if (logbitp $lfbits-nextmeth-with-args-bit
1161                       (lfun-bits (%method.function method)))
1162            (return t)))))))
1163
1164;;; The METHODS arg is a sorted list of applicable methods.  Returns
1165;;; the method-list expected by
1166;;; %%before-and-after-combined-method-dcode or a single method, or
1167;;; NIL if there are no applicable primaries
1168(defun compute-method-list (methods &optional (sub-dispatch? t))
1169  (let (arounds befores primaries afters qs)
1170    (dolist (m methods)
1171      (setq qs (%method.qualifiers m))
1172      (if qs
1173        (if (cdr qs)
1174          (%invalid-method-error
1175           m "Multiple method qualifiers not allowed in ~s method combination"
1176           'standard)
1177          (case (car qs)
1178            (:before (push m befores))
1179            (:after (push m afters))
1180            (:around (push m arounds))
1181            (t (%invalid-method-error m "~s is not one of ~s, ~s, and ~s."
1182                                      (car qs) :before :after :around))))
1183        (push m primaries)))
1184    (setq primaries (nreverse primaries)
1185          arounds (nreverse arounds)
1186          befores (nreverse befores))
1187    (unless sub-dispatch?
1188      (setq primaries (nremove-uncallable-next-methods primaries)
1189            arounds (nremove-uncallable-next-methods arounds)))
1190    (flet ((next-method-bit-p (method)
1191                              (logbitp $lfbits-nextmeth-bit 
1192                                       (lfun-bits (%method.function method)))))
1193      (unless (null primaries)            ; return NIL if no applicable primary methods
1194        (when (and arounds
1195                   (not sub-dispatch?)
1196                   (not (next-method-bit-p (car (last arounds)))))
1197          ;; Arounds don't call-next-method, can't get to befores,
1198          ;; afters, or primaries
1199          (setq primaries arounds
1200                arounds nil
1201                befores nil
1202                afters nil))
1203        (if (and (null befores) (null afters)
1204                 (progn
1205                   (when arounds
1206                     (setq primaries (nconc arounds primaries)
1207                           arounds nil)
1208                     (unless sub-dispatch?
1209                       (setq primaries (nremove-uncallable-next-methods primaries))))
1210                   t)
1211                 (null (cdr primaries))
1212                 (not (next-method-bit-p (car primaries))))
1213          (car primaries)                 ; single method, no call-next-method
1214          (let ((method-list primaries))
1215            (if (or befores afters)
1216              (setq method-list (cons befores (cons afters method-list))))
1217            (nconc arounds method-list)))))))
1218
1219
1220
1221(defun %invalid-method-error (method format-string &rest format-args)
1222  (error "~s is an invalid method.~%~?" method format-string format-args))
1223
1224(defun %method-combination-error (format-string &rest args)
1225  (apply #'error format-string args))
1226
1227
1228
1229(defun combined-method-gf (gf-or-cm)
1230  (let ((gf gf-or-cm))
1231    (while (combined-method-p gf)
1232      (setq gf (lfun-name gf)))
1233    gf))
1234
1235
1236(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args)
1237  (let* ((argnum (%gf-dispatch-table-argnum table))
1238         (arg (nth argnum args)))
1239    (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper)))
1240
1241
1242(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional
1243                                              (arg (nth-or-gf-error 
1244                                                    argnum args gf-or-cm))
1245                                              (wrapper (arg-wrapper arg)))
1246  ;; Here when we can't find the method in the dispatch table.
1247  ;; Compute it and add it to the table.  This code will remain in Lisp.
1248  (multiple-value-bind (combined-method sub-dispatch?)
1249      (compute-nth-arg-combined-method
1250       gf-or-cm (%gf-dispatch-table-methods table) argnum args
1251       wrapper)
1252    (multiple-value-bind (index obsolete-wrappers-p)
1253        ( find-gf-dispatch-table-index table wrapper)
1254      (if index
1255        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
1256           (setf (%gf-dispatch-table-ref table index) wrapper))
1257        (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
1258    (if sub-dispatch?
1259      (let ((table (%combined-method-methods combined-method)))
1260        (nth-arg-combined-method-trap
1261         combined-method
1262         table
1263         (%gf-dispatch-table-argnum table)
1264         args))
1265      combined-method)))
1266
1267;;; Returns (values combined-method sub-dispatch?)
1268;;; If sub-dispatch? is true, need to compute a combined-method on the
1269;;; next arg.
1270(defun compute-nth-arg-combined-method (gf methods argnum args &optional 
1271                                           (wrapper (arg-wrapper
1272                                                     (nth-or-gf-error
1273                                                      argnum args gf))))
1274  (let* ((cpl (%inited-class-cpl (%wrapper-class wrapper)))
1275         (real-gf (combined-method-gf gf))
1276         (mc (%gf-method-combination real-gf))
1277         (standard-mc? (eq mc *standard-method-combination*))
1278         applicable-methods eql-methods specializers specializer sub-dispatch?)
1279    (dolist (method methods)
1280      ;;(require-type method 'standard-method)   ; for debugging.
1281      (setq specializers (nthcdr argnum (%method.specializers method))
1282            specializer (%car specializers))
1283      (when (if (typep specializer 'eql-specializer)
1284              (when (cpl-memq (%wrapper-class
1285                                (arg-wrapper (eql-specializer-object specializer))) cpl)
1286                (push method eql-methods))
1287              (when (cpl-memq specializer cpl)
1288                (push method applicable-methods)))
1289        (if (contains-non-t-specializer? (%cdr specializers))
1290          (setq sub-dispatch? t))))
1291    (if (or eql-methods applicable-methods)
1292      (if (or (not standard-mc?)
1293            (contains-primary-method? applicable-methods)
1294            (contains-primary-method? eql-methods))
1295        (let ((cpls (args-cpls args)))
1296          (if eql-methods
1297            (make-eql-combined-method
1298             eql-methods applicable-methods cpls gf argnum sub-dispatch? mc)
1299            (if sub-dispatch?
1300              (values (make-n+1th-arg-combined-method applicable-methods gf argnum)
1301                      t)
1302              (if standard-mc?
1303                (make-standard-combined-method applicable-methods cpls gf)
1304                (compute-effective-method-function
1305                 real-gf mc (sort-methods applicable-methods
1306                                          (args-cpls args)
1307                                          (%gf-precedence-list real-gf)))))))
1308        (no-applicable-primary-method
1309         real-gf
1310         (sort-methods (append eql-methods applicable-methods)
1311                       (args-cpls args)
1312                       (%gf-precedence-list real-gf))))
1313       (make-no-applicable-method-function real-gf))))
1314
1315(defun nth-or-gf-error (n l gf)
1316  (declare (fixnum l))
1317  (do* ((i 0 (1+ i))
1318        (l l (cdr l)))
1319       ((null l) (dcode-too-few-args i gf))
1320    (declare (fixnum i))
1321    (if (= i n)
1322      (return (car l)))))
1323
1324(defun contains-non-t-specializer? (specializer-list)
1325  (dolist (s specializer-list nil)
1326    (unless (eq *t-class* s)
1327      (return t))))
1328
1329(defun contains-primary-method? (method-list)
1330  (dolist (m method-list nil)
1331    (if (null (%method.qualifiers m))
1332      (return t))))
1333
1334(defun args-cpls (args &aux res)
1335  (dolist (arg args)
1336    (push (%inited-class-cpl (%wrapper-class (arg-wrapper arg))) res))
1337  (nreverse res))
1338
1339
1340
1341;;; This needs to be updated to use a linear search in a vector changing to
1342;;; a hash table when the number of entries crosses some threshold.
1343(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
1344                                             (method-combination *standard-method-combination*))
1345  (let ((eql-ms (copy-list eql-methods))
1346        (precedence-list (%gf-precedence-list (combined-method-gf gf)))
1347        (standard-mc? (eq method-combination *standard-method-combination*))
1348        (real-gf (combined-method-gf gf))
1349        eql-method-alist
1350        (can-use-eq? t))
1351    (unless sub-dispatch?
1352      (setq methods (sort-methods methods cpls precedence-list)))
1353    (while eql-ms
1354      (let ((eql-element (eql-specializer-object (nth argnum (%method.specializers (car eql-ms)))))
1355            (this-element-methods eql-ms)
1356            cell last-cell)
1357        (if (or (and (numberp eql-element) (not (fixnump eql-element)))
1358                (macptrp eql-element))
1359          (setq can-use-eq? nil))
1360        (setf eql-ms (%cdr eql-ms)
1361              (%cdr this-element-methods) nil
1362              cell eql-ms)
1363        (while cell
1364          (if (eql eql-element
1365                     (eql-specializer-object (nth argnum (%method.specializers (car cell)))))
1366            (let ((cell-save cell))
1367              (if last-cell
1368                (setf (%cdr last-cell) (cdr cell))
1369                (setq eql-ms (cdr eql-ms)))
1370              (setf cell (cdr cell)
1371                    (%cdr cell-save) this-element-methods
1372                    this-element-methods cell-save))
1373            (setq last-cell cell
1374                  cell (cdr cell))))
1375        (let* ((sorted-methods
1376                (sort-methods (nreconc (copy-list this-element-methods)
1377                                       (copy-list methods))
1378                              cpls
1379                              precedence-list))
1380               (method-list (and standard-mc? (compute-method-list sorted-methods sub-dispatch?))))
1381          (when (or (not standard-mc?)
1382                    (memq method-list this-element-methods)
1383                    (and (consp method-list)
1384                         (labels ((member-anywhere (tem mlist)
1385                                    (member tem mlist
1386                                            :test #'(lambda (tem el)
1387                                                      (if (listp el)
1388                                                        (member-anywhere tem el)
1389                                                        (member el tem))))))
1390                           (member-anywhere this-element-methods method-list))))
1391            ; Do EQL comparison only if the EQL methods can run
1392            ; (e.g. does not come after a primary method that does not call-next-method)
1393            (push (cons eql-element
1394                        (if sub-dispatch?
1395                          (make-n+1th-arg-combined-method
1396                           sorted-methods gf argnum)
1397                          (if standard-mc?
1398                            (make-standard-combined-method sorted-methods nil gf)
1399                            (compute-effective-method-function
1400                             real-gf method-combination sorted-methods))))
1401                  eql-method-alist)))))
1402    ;;eql-method-alist has (element . combined-method) pairs.
1403    ;;for now, we're going to use assq or assoc
1404    (let ((default-method (if sub-dispatch?
1405                            (make-n+1th-arg-combined-method
1406                             methods gf argnum)
1407                            (if standard-mc?
1408                              (make-standard-combined-method methods nil gf t)
1409                              (compute-effective-method-function
1410                               real-gf method-combination methods)))))
1411      (if eql-method-alist
1412        (%cons-combined-method 
1413         gf (cons argnum (cons eql-method-alist default-method))
1414         (if can-use-eq? 
1415           #'%%assq-combined-method-dcode
1416           #'%%assoc-combined-method-dcode))
1417        default-method))))
1418
1419
1420
1421
1422(defun %%assq-combined-method-dcode (stuff args)
1423  ;; stuff is (argnum eql-method-list . default-method)
1424  ;(declare (dynamic-extent args))
1425  (if (listp args)
1426    (let* ((args-len (list-length args))
1427           (argnum (car stuff)))
1428      (when (>= argnum args-len)(signal-program-error  "Too few args to ~s." (%method-gf (cddr stuff))))
1429      (let* ((arg (nth argnum args))
1430             (thing (assq arg (cadr stuff)))) ; are these things methods or method-functions? - fns   
1431        (if thing 
1432          (apply (cdr thing) args)
1433          (apply (cddr stuff) args))))
1434    (let* ((args-len (%lexpr-count args))
1435           (argnum (car stuff)))
1436      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1437      (let* ((arg (%lexpr-ref args args-len argnum))
1438             (thing (assq arg (cadr stuff))))
1439        (if thing 
1440          (%apply-lexpr (cdr thing) args)
1441          (%apply-lexpr (cddr stuff) args))))))
1442 
1443
1444(DEFun %%assoc-combined-method-dcode (stuff args)
1445  ;; stuff is (argnum eql-method-list . default-method)
1446  ;(declare (dynamic-extent args))
1447  (if (listp args)
1448    (let* ((args-len (list-length args))
1449           (argnum (car stuff)))
1450      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1451      (let* ((arg (nth argnum args))
1452             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1453        (if thing 
1454          (apply (cdr thing) args)
1455          (apply (cddr stuff) args))))
1456    (let* ((args-len (%lexpr-count args))
1457           (argnum (car stuff)))
1458      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1459      (let* ((arg (%lexpr-ref args args-len argnum))
1460             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1461        (if thing 
1462          (%apply-lexpr (cdr thing) args)
1463          (%apply-lexpr (cddr stuff) args))))))
1464
1465
1466;;; Assumes the two methods have the same number of specializers and
1467;;; that each specializer of each method is in the corresponding
1468;;; element of cpls (e.g. cpls is a list of the cpl's for the classes
1469;;; of args for which both method1 & method2 are applicable.
1470(defun %method< (method1 method2 cpls)
1471  (let ((s1s (%method.specializers method1))
1472        (s2s (%method.specializers method2))
1473        s1 s2 cpl)
1474    (loop
1475      (if (null s1s)
1476        (return (method-qualifiers< method1 method2)))
1477      (setq s1 (%pop s1s)
1478            s2 (%pop s2s)
1479            cpl (%pop cpls))
1480      (cond ((typep s1 'eql-specializer) 
1481             (unless (eq s1 s2)
1482               (return t)))
1483            ((typep s2 'eql-specializer) (return nil))
1484            ((eq s1 s2))
1485            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1486
1487(defun %simple-method< (method1 method2 cpl)
1488  (let ((s1 (%car (%method.specializers method1)))
1489        (s2 (%car (%method.specializers method2))))
1490    (cond ((typep s1 'eql-specializer) 
1491           (if (eq s1 s2)
1492             (method-qualifiers< method1 method2)
1493             t))
1494          ((typep s2 'eql-specializer) nil)
1495          ((eq s1 s2) (method-qualifiers< method1 method2))
1496          (t (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))
1497
1498; Sort methods with argument-precedence-order
1499(defun %hairy-method< (method1 method2 cpls apo)
1500  (let ((s1s (%method.specializers method1))
1501        (s2s (%method.specializers method2))
1502        s1 s2 cpl index)
1503    (loop
1504      (if (null apo)
1505        (return (method-qualifiers< method1 method2)))
1506      (setq index (pop apo))
1507      (setq s1 (nth index s1s)
1508            s2 (nth index s2s)
1509            cpl (nth index cpls))
1510      (cond ((typep s1 'eql-specializer) 
1511             (unless (eq s1 s2)
1512               (return t)))
1513            ((typep s2 'eql-specializer) (return nil))
1514            ((eq s1 s2))
1515            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1516
1517; This can matter if the user removes & reinstalls methods between
1518; invoking a generic-function and doing call-next-method with args.
1519; Hence, we need a truly canonical sort order for the methods
1520; (or a smarter comparison than EQUAL in %%cnm-with-args-check-methods).
1521(defun method-qualifiers< (method1 method2)
1522  (labels ((qualifier-list< (ql1 ql2 &aux q1 q2)
1523              (cond ((null ql1) (not (null ql2)))
1524                    ((null ql2) nil)
1525                    ((eq (setq q1 (car ql1)) (setq q2 (car ql2)))
1526                     (qualifier-list< (cdr ql1) (cdr ql2)))
1527                    ((string-lessp q1 q2) t)
1528                    ; This isn't entirely correct.
1529                    ; two qualifiers with the same pname in different packages
1530                    ; are not comparable here.
1531                    ; Unfortunately, users can change package names, hence,
1532                    ; comparing the package names doesn't work either.
1533                    (t nil))))
1534    (qualifier-list< (%method.qualifiers method1) (%method.qualifiers method2))))
1535       
1536(defun sort-methods (methods cpls &optional apo)
1537  (cond ((null cpls) methods)
1538        ((null (%cdr cpls))
1539         (setq cpls (%car cpls))
1540         (flet ((simple-sort-fn (m1 m2)
1541                  (%simple-method< m1 m2 cpls)))
1542           (declare (dynamic-extent #'simple-sort-fn))
1543           (%sort-list-no-key methods #'simple-sort-fn)))
1544        ((null apo)                     ; no unusual argument-precedence-order
1545         (flet ((sort-fn (m1 m2) 
1546                  (%method< m1 m2 cpls)))
1547           (declare (dynamic-extent #'sort-fn))
1548           (%sort-list-no-key methods #'sort-fn)))
1549        (t                              ; I guess some people are just plain rude
1550         (flet ((hairy-sort-fn (m1 m2)
1551                  (%hairy-method< m1 m2 cpls apo)))
1552           (declare (dynamic-extent #'hairy-sort-fn))
1553           (%sort-list-no-key methods #'hairy-sort-fn)))))
1554
1555(defun nremove-uncallable-next-methods (methods)
1556  (do ((m methods (%cdr m))
1557       mbits)
1558      ((null m))
1559    (setq mbits (lfun-bits (%method.function (%car m))))
1560    (unless (logbitp $lfbits-nextmeth-bit mbits)
1561      (setf (%cdr m) nil)
1562      (return)))
1563  methods)
1564
1565
1566(defun cpl-index (superclass cpl)
1567  ;; This will be table lookup later.  Also we'll prelookup the tables
1568  ;; in compute-1st-arg-combined-methods above.
1569  (locally (declare (optimize (speed 3)(safety 0)))
1570    (do ((i 0 (%i+ i 1))
1571         (cpl cpl (%cdr cpl)))
1572        ((null cpl) nil)
1573      (if (eq superclass (%car cpl))
1574        (return i)))))
1575
1576(defun cpl-memq (superclass cpl)
1577  (locally (declare (optimize (speed 3)(safety 0)))
1578    (do ((cpl cpl (%cdr cpl)))
1579        ((null cpl) nil)
1580      (if (eq superclass (%car cpl))
1581        (return cpl)))))
1582
1583;;; Combined method interpretation
1584
1585
1586;;; magic is a list of (cnm-cm (methods) . args) cnm-cm is the
1587;;; argument checker for call-next-method-with-args or nil could make
1588;;; it be a cons as a flag that magic has been heap consed - done
1589;;; could also switch car and cadr if we do &lexpr business then if
1590;;; cddr is lexpr-p (aka (not listp)) thats the clue also would need
1591;;; to do lexpr-apply or apply depending on the state.
1592
1593
1594(defun %%standard-combined-method-dcode (methods args)
1595  ;; combined-methods as made by make-combined-method are in methods
1596  ;; args are as put there by the caller of the gf.
1597  (let* ((car-meths (car methods))
1598         (cell-2 (cons methods args))
1599         (magic (cons nil cell-2)))
1600    ;; i.e. magic is nil methods . args
1601    (declare (dynamic-extent magic)
1602             (dynamic-extent cell-2))   
1603    (if (listp car-meths)
1604      (%%before-and-after-combined-method-dcode magic)
1605      (progn       
1606        (if (not (cdr methods))
1607          (%rplaca (cdr magic) car-meths)
1608          (%rplaca (cdr magic) (cdr methods)))
1609        ; so maybe its a combined-method ?? - no
1610        (apply-with-method-context magic (%method.function car-meths) args)))))
1611
1612;;; args is list, old-args may be lexpr
1613(defun cmp-args-old-args (args old-args numreq)
1614  (declare (optimize (speed 3)(safety 0)))
1615  (if (listp old-args)
1616    (do ((newl args (cdr newl))
1617         (oldl old-args (cdr oldl))
1618         (i 0 (1+ i)))
1619        ((eql i numreq) t)
1620      (when (neq (car newl)(car oldl))(return nil)))
1621    (let ((len (%lexpr-count old-args)))
1622      (do ((newl args (cdr newl))
1623           (i 0 (1+ i)))
1624          ((eql i numreq) t)
1625        (when (neq (car newl)(%lexpr-ref old-args len i))(return nil))))))       
1626
1627
1628; called from call-next-method-with-args with magic supplied and 1st time around with not
1629(defun %%cnm-with-args-combined-method-dcode (thing args &optional magic) ; was &rest args
1630  ;(declare (dynamic-extent args))
1631  ; now thing is vector of gf orig methods, arg for key or initarg check, key or initarg fnction
1632  ; and our job is to do all the arg checking
1633  (let ()
1634    (when magic
1635      (flet ((do-it (thing args)
1636               (let* ((args-len (length args))
1637                      (gf (svref thing 0))  ; could get this from a method
1638                      (numreq (ldb $lfbits-numreq (inner-lfun-bits gf)))
1639                      (next-methods (cadr magic)))
1640                 ;(when (null self)(error "Next method with args context error"))
1641                 (when (neq 0 numreq)
1642                   ; oh screw it - old-args may be lexpr too
1643                   (let ((old-args (cddr magic)))
1644                     (when (< args-len numreq) (signal-program-error "Too few args to ~S" gf))
1645                     (when (null (cmp-args-old-args args old-args numreq))
1646                       ; required args not eq - usually true, we expect
1647                       (let ((new-methods (%compute-applicable-methods* gf args))
1648                             (old-methods (svref thing 1)))
1649                         (when (not (equal new-methods old-methods))
1650                           (error '"Applicable-methods changed in call-next-method.~%~
1651                                    Should be: ~s~%Was: ~s~%Next-methods: ~s"
1652                                  old-methods new-methods next-methods))))))
1653                 (let ((key-or-init-fn (svref thing 3)))
1654                   (when key-or-init-fn 
1655                     ; was apply
1656                     (funcall key-or-init-fn (svref thing 2) args))))))
1657        (if (listp args)
1658          (do-it thing args)
1659          (with-list-from-lexpr (args-list args)
1660            (do-it thing args-list)))))
1661    ; ok done checking - lets do it
1662    (let* ((methods (if magic (cadr magic)(svref thing 4)))  ;<< was 5 this is nil unless cnm with args
1663           ; was if magic
1664           (car-meths (car methods))
1665           (cell-2 (cons methods args))
1666           (magic (cons thing cell-2)))
1667      (declare (dynamic-extent magic cell-2))
1668      ; i.e. magic is thing methods . args
1669      ;(%rplaca magic thing)
1670      ;(setf (cadr magic) methods)
1671      ;(%rplaca (cdr magic) methods)
1672      ;(setf (cddr magic) args)
1673      ;(%rplacd (cdr magic) args)
1674      (if (listp car-meths)
1675        (progn
1676          (%%before-and-after-combined-method-dcode magic))
1677        (progn       
1678          (if (not (cdr methods))
1679            (%rplaca (cdr magic) car-meths)
1680            (%rplaca (cdr magic) (cdr methods)))
1681          ; so maybe its a combined-method ?? - no
1682          (apply-with-method-context magic (%method.function car-meths) args))))))
1683
1684
1685
1686;;; here if car of methods is listp. methods = (befores afters . primaries)
1687(defun %%before-and-after-combined-method-dcode (magic) 
1688  (declare (list magic))
1689  (let* ((methods (cadr magic))         
1690         (befores (car methods))         
1691         (cdr-meths (cdr methods))
1692         (primaries (cdr cdr-meths))
1693         (afters (car cdr-meths))
1694         (args (cddr magic)))
1695    (declare (list befores afters primaries))
1696    (when befores 
1697      (dolist (method befores)
1698        (rplaca (cdr magic) method)
1699        (apply-with-method-context magic (%method.function method) args)))
1700    (let* ((cdr (cdr primaries))
1701           (method-function (%method.function (car primaries))))   ; guaranteed non nil?
1702      (rplaca (cdr magic) (if (null cdr)(car primaries) cdr))     
1703      (if (null afters)
1704        (apply-with-method-context magic method-function args)  ; tail call if possible
1705        (multiple-value-prog1
1706          (apply-with-method-context magic method-function args)       
1707          (dolist (method afters)
1708            (rplaca (cdr magic) method)
1709            (apply-with-method-context magic (%method.function method) args)))))))
1710
1711
1712; This is called by the compiler expansion of next-method-p
1713; I think there's a bug going around... LAP fever! I'm immune
1714(defun %next-method-p (magic)
1715  (let ((methods (%cadr magic)))
1716    (consp methods)))
1717
1718
1719(defun %call-next-method (magic &rest args) ; if args supplied they are new ones
1720  (declare (dynamic-extent args)) 
1721  (if args
1722    (apply #'%call-next-method-with-args magic args)
1723    (let* ((next-methods (%cadr magic))) ; don't get this closed magic stuff     
1724      (if (not (consp next-methods))
1725        ( %no-next-method  magic)           
1726        (let ((args (%cddr magic)))  ; get original args
1727          ;The unwind-protect is needed in case some hacker in his/her wisdom decides to:
1728          ; (defmethod foo (x) (catch 'foo (call-next-method)) (call-next-method))
1729          ; where the next-method throws to 'foo.
1730          ; The alternative is to make a new magic var with args
1731          ; actually not that fancy (call-next-method)(call-next-method) is same problem
1732          (let ()
1733            (unwind-protect
1734              (if (listp (car next-methods))
1735                ( %%before-and-after-combined-method-dcode magic)
1736                (let ((cdr (cdr next-methods)))
1737                  (rplaca (cdr magic)(if (not cdr)(car next-methods) cdr))
1738                  (let ((method-function (%method.function (car next-methods))))
1739                    (apply-with-method-context magic method-function args))))
1740              (rplaca (cdr magic) next-methods))))))))
1741
1742;; Note: we need to change the compiler to call this when it can prove that
1743;; call-next-method cannot be called a second time. I believe thats done.
1744
1745
1746(defun %tail-call-next-method (magic)
1747  (let* ((next-methods (%cadr magic))  ; or make it car
1748         (args (%cddr magic))) ; get original args       
1749    (if (not (consp next-methods)) ; or consp?
1750      ( %no-next-method magic)
1751      (if (listp (car next-methods))
1752        ( %%before-and-after-combined-method-dcode magic)
1753        (let ((cdr (cdr next-methods)))
1754          (rplaca (cdr magic) (if (not cdr)(car next-methods) cdr))
1755          (apply-with-method-context magic (%method.function (car next-methods)) args))))))
1756
1757; may be simpler to blow another cell so magic looks like
1758; (cnm-cm/nil next-methods . args) - done
1759; and also use first cell to mean heap-consed if itsa cons
1760
1761(defun %call-next-method-with-args (magic &rest args)
1762  (declare (dynamic-extent args))
1763  (if (null args)
1764    (%call-next-method magic)
1765    (let* ((methods (%cadr magic)))
1766      (if (not (consp methods))
1767        (%no-next-method  magic)
1768        (let* ((cnm-cm (car magic)))
1769          ; a combined method
1770          (when (consp cnm-cm)(setq cnm-cm (car cnm-cm)))
1771          ; could just put the vector in car magic & no self needed in vector?
1772          (let ((the-vect cnm-cm)) ;  <<
1773            (funcall #'%%cnm-with-args-combined-method-dcode ;(%combined-method-dcode cnm-cm)
1774                     the-vect
1775                     args
1776                     magic)))))))
1777
1778
1779
1780; called from x%%call-next-method-with-args - its the key-or-init-fn
1781(defun %%cnm-with-args-check-initargs (init-cell args)
1782  ; here we forget the lexpr idea because it wants to cdr
1783  ;(declare (dynamic-extent args))
1784  (let* ((rest (cdr args))
1785         (first-arg (car args)))
1786    (declare (list rest))
1787    (let* ((initargs rest)
1788           (init-function (car init-cell))
1789           (instance (cond ((eq init-function #'update-instance-for-different-class)
1790                            (setq initargs (cdr rest))
1791                            (car rest))
1792                           ((eq init-function #'shared-initialize)
1793                            (setq initargs (cdr rest))
1794                            first-arg)
1795                           ((eq init-function #'update-instance-for-redefined-class)
1796                            (setq initargs (%cdddr rest))
1797                            first-arg)
1798                           (t first-arg)))
1799           (class (class-of instance))
1800           bad-initarg)
1801      (dolist (functions (cdr init-cell)
1802                         (error "Bad initarg: ~s to call-next-method for ~s~%on ~s"
1803                                bad-initarg instance (car init-cell)))
1804        (multiple-value-bind 
1805          (errorp bad-key)
1806          (if (eq (car functions) #'initialize-instance)
1807            (apply #'check-initargs instance class initargs nil
1808                   #'initialize-instance #'allocate-instance #'shared-initialize
1809                   nil)
1810            (apply #'check-initargs instance class initargs nil functions))
1811          (if errorp
1812            (unless bad-initarg (setq bad-initarg bad-key))
1813            (return t)))))))
1814
1815
1816
1817(defun %no-next-method (magic)
1818  (let* ((method (%cadr magic)))
1819    (if (consp method) (setq method (car method)))
1820    (unless (typep method 'standard-method)
1821      (error "call-next-method called outside of generic-function dispatch context.~@
1822              Usually indicates an error in a define-method-combination form."))
1823    (let ((args (cddr magic))
1824          (gf (%method.gf method)))
1825      (if (listp args)
1826        (apply #'no-next-method gf method args)
1827        (%apply-lexpr #'no-next-method gf method args)))))
1828
1829
1830
1831
1832;;; This makes a consed version of the magic first arg to a method.
1833;;; Called when someone closes over the magic arg. (i.e. does (george
1834;;; #'call-next-method))
1835
1836(defun %cons-magic-next-method-arg (magic)
1837  ; car is a cons as a flag that its already heap-consed! - else cnm-cm or nil
1838  (if (consp (car magic))
1839    magic
1840    (list* (list (car magic))
1841           (if (consp (%cadr magic))
1842             (copy-list (%cadr magic)) ; is this copy needed - probably not
1843             (cadr magic))
1844           (let ((args (%cddr magic)))
1845             (if (listp args)
1846               (copy-list args)
1847               (let* ((len (%lexpr-count args))
1848                      (l (make-list len)))
1849                 (do ((i 0 (1+ i))
1850                      (list l (cdr list)))
1851                     ((null list))
1852                   (%rplaca list (%lexpr-ref args len i)))
1853                 l))))))
1854
1855
1856; Support CALL-METHOD in DEFINE-METHOD-COMBINATION
1857(defun %%call-method* (method next-methods args)
1858  (let* ((method-function (%method.function method))
1859         (bits (lfun-bits method-function)))
1860    (declare (fixnum bits))
1861    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1862                  (logbitp  $lfbits-method-bit bits)))
1863      (if (listp args)
1864        (apply method-function args)
1865        (%apply-lexpr method-function args))
1866      (let* ((cell-2 (cons next-methods args))
1867             (magic (cons nil cell-2)))
1868        (declare (dynamic-extent magic)
1869                 (dynamic-extent cell-2)) 
1870        (if (null next-methods)
1871          (%rplaca (cdr magic) method))
1872        (apply-with-method-context magic method-function args)))))
1873
1874; Error checking version for user's to call
1875(defun %call-method* (method next-methods args)
1876  (let* ((method-function (%method.function method))
1877         (bits (lfun-bits method-function)))
1878    (declare (fixnum bits))
1879    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1880                  (logbitp  $lfbits-method-bit bits)))
1881      (progn
1882        (require-type method 'standard-method)
1883        (if (listp args)
1884          (apply method-function args)
1885          (%apply-lexpr method-function args)))
1886      (progn
1887        (do* ((list next-methods (cdr list)))
1888             ((null list))
1889          (when (not (listp list))
1890            (%err-disp $XIMPROPERLIST next-methods))
1891          (when (not (standard-method-p (car list)))
1892            (report-bad-arg (car list) 'standard-method))) 
1893        (let* ((cell-2 (cons next-methods args))
1894               (magic (cons nil cell-2)))
1895          (declare (dynamic-extent magic)
1896                   (dynamic-extent cell-2)) 
1897          (if (null next-methods)
1898            (%rplaca (cdr magic) method))
1899          (apply-with-method-context magic method-function args))))))
1900
1901
1902
Note: See TracBrowser for help on using the repository browser.