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

Last change on this file since 11887 was 11349, checked in by gz, 11 years ago

bug #378: In %cnm-with-args-combined-method-dcode, which is called for call-next-method with args, don't try to check for a change in the set of applicable methods if don't have the necessary info. This happens (only) for non-standard method combinations, because %%call-method* doesn't set up the info.

I'm not sure whether we're supposed to check this for non-standard method combinations, if so, that's
a different bug.

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