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

Last change on this file since 7069 was 7069, checked in by gb, 13 years ago

Define and use %GF-DISPATCH-TABLE-STORE-CONDITIONAL; this is intended
to avoid race conditions where two threads try to update a distpatch
table index with different {wrapper, combined-method} pairs at the same
time. (As it's written, if the store-conditional fails because a slot
that we thought was free is now in use, we simply don't cache the
pair and get a cache miss the next time; that may or may not be more
work than repeating the whole process would be.)

The store-conditional is used on attempt to update the combined-method
slot in the pair; the wrapper slot is only updated if the store-conditional
succeeds. Code which probes the wrapper slots shouldn't be confused by
a half-updated pair (should never see a non-null wrapper slot and a
null combined-method slot.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 74.3 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))))
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)
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 (nremove-uncallable-next-methods (nreverse primaries))
1185          arounds (nremove-uncallable-next-methods (nreverse arounds))
1186          befores (nreverse befores))     
1187    (flet ((next-method-bit-p (method)
1188                              (logbitp $lfbits-nextmeth-bit 
1189                                       (lfun-bits (%method.function method)))))
1190      (unless (null primaries)            ; return NIL if no applicable primary methods
1191        (when (and arounds (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 (nremove-uncallable-next-methods
1202                                      (nconc arounds primaries))
1203                           arounds nil))
1204                   t)
1205                 (null (cdr primaries))
1206                 (not (next-method-bit-p (car primaries))))
1207          (car primaries)                 ; single method, no call-next-method
1208          (let ((method-list primaries))
1209            (if (or befores afters)
1210              (setq method-list (cons befores (cons afters method-list))))
1211            (nconc arounds method-list)))))))
1212
1213
1214
1215(defun %invalid-method-error (method format-string &rest format-args)
1216  (error "~s is an invalid method.~%~?" method format-string format-args))
1217
1218(defun %method-combination-error (format-string &rest args)
1219  (apply #'error format-string args))
1220
1221
1222
1223(defun combined-method-gf (gf-or-cm)
1224  (let ((gf gf-or-cm))
1225    (while (combined-method-p gf)
1226      (setq gf (lfun-name gf)))
1227    gf))
1228
1229
1230(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args)
1231  (let* ((argnum (%gf-dispatch-table-argnum table))
1232         (arg (nth argnum args)))
1233    (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper)))
1234
1235
1236(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional
1237                                              (arg (nth-or-gf-error 
1238                                                    argnum args gf-or-cm))
1239                                              (wrapper (arg-wrapper arg)))
1240  ;; Here when we can't find the method in the dispatch table.
1241  ;; Compute it and add it to the table.  This code will remain in Lisp.
1242  (multiple-value-bind (combined-method sub-dispatch?)
1243      (compute-nth-arg-combined-method
1244       gf-or-cm (%gf-dispatch-table-methods table) argnum args
1245       wrapper)
1246    (multiple-value-bind (index obsolete-wrappers-p)
1247        ( find-gf-dispatch-table-index table wrapper)
1248      (if index
1249        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
1250           (setf (%gf-dispatch-table-ref table index) wrapper))
1251        (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
1252    (if sub-dispatch?
1253      (let ((table (%combined-method-methods combined-method)))
1254        (nth-arg-combined-method-trap
1255         combined-method
1256         table
1257         (%gf-dispatch-table-argnum table)
1258         args))
1259      combined-method)))
1260
1261;;; Returns (values combined-method sub-dispatch?)
1262;;; If sub-dispatch? is true, need to compute a combined-method on the
1263;;; next arg.
1264(defun compute-nth-arg-combined-method (gf methods argnum args &optional 
1265                                           (wrapper (arg-wrapper
1266                                                     (nth-or-gf-error
1267                                                      argnum args gf))))
1268  (let* ((cpl (%inited-class-cpl (%wrapper-class wrapper)))
1269         (real-gf (combined-method-gf gf))
1270         (mc (%gf-method-combination real-gf))
1271         (standard-mc? (eq mc *standard-method-combination*))
1272         applicable-methods eql-methods specializers specializer sub-dispatch?)
1273    (dolist (method methods)
1274      ;;(require-type method 'standard-method)   ; for debugging.
1275      (setq specializers (nthcdr argnum (%method.specializers method))
1276            specializer (%car specializers))
1277      (when (if (typep specializer 'eql-specializer)
1278              (when (cpl-memq (%wrapper-class
1279                                (arg-wrapper (eql-specializer-object specializer))) cpl)
1280                (push method eql-methods))
1281              (when (cpl-memq specializer cpl)
1282                (push method applicable-methods)))
1283        (if (contains-non-t-specializer? (%cdr specializers))
1284          (setq sub-dispatch? t))))
1285    (if (or eql-methods applicable-methods)
1286      (if (or (not standard-mc?)
1287            (contains-primary-method? applicable-methods)
1288            (contains-primary-method? eql-methods))
1289        (let ((cpls (args-cpls args)))
1290          (if eql-methods
1291            (make-eql-combined-method
1292             eql-methods applicable-methods cpls gf argnum sub-dispatch? mc)
1293            (if sub-dispatch?
1294              (values (make-n+1th-arg-combined-method applicable-methods gf argnum)
1295                      t)
1296              (if standard-mc?
1297                (make-standard-combined-method applicable-methods cpls gf)
1298                (compute-effective-method-function
1299                 real-gf mc (sort-methods applicable-methods
1300                                          (args-cpls args)
1301                                          (%gf-precedence-list real-gf)))))))
1302        (no-applicable-primary-method
1303         real-gf
1304         (sort-methods (append eql-methods applicable-methods)
1305                       (args-cpls args)
1306                       (%gf-precedence-list real-gf))))
1307       (make-no-applicable-method-function real-gf))))
1308
1309(defun nth-or-gf-error (n l gf)
1310  (declare (fixnum l))
1311  (do* ((i 0 (1+ i))
1312        (l l (cdr l)))
1313       ((null l) (dcode-too-few-args i gf))
1314    (declare (fixnum i))
1315    (if (= i n)
1316      (return (car l)))))
1317
1318(defun contains-non-t-specializer? (specializer-list)
1319  (dolist (s specializer-list nil)
1320    (unless (eq *t-class* s)
1321      (return t))))
1322
1323(defun contains-primary-method? (method-list)
1324  (dolist (m method-list nil)
1325    (if (null (%method.qualifiers m))
1326      (return t))))
1327
1328(defun args-cpls (args &aux res)
1329  (dolist (arg args)
1330    (push (%inited-class-cpl (%wrapper-class (arg-wrapper arg))) res))
1331  (nreverse res))
1332
1333
1334
1335;;; This needs to be updated to use a linear search in a vector changing to
1336;;; a hash table when the number of entries crosses some threshold.
1337(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
1338                                             (method-combination *standard-method-combination*))
1339  (let ((eql-ms (copy-list eql-methods))
1340        (precedence-list (%gf-precedence-list (combined-method-gf gf)))
1341        (standard-mc? (eq method-combination *standard-method-combination*))
1342        (real-gf (combined-method-gf gf))
1343        eql-method-alist
1344        (can-use-eq? t))
1345    (unless sub-dispatch?
1346      (setq methods (sort-methods methods cpls precedence-list)))
1347    (while eql-ms
1348      (let ((eql-element (eql-specializer-object (nth argnum (%method.specializers (car eql-ms)))))
1349            (this-element-methods eql-ms)
1350            cell last-cell)
1351        (if (or (and (numberp eql-element) (not (fixnump eql-element)))
1352                (macptrp eql-element))
1353          (setq can-use-eq? nil))
1354        (setf eql-ms (%cdr eql-ms)
1355              (%cdr this-element-methods) nil
1356              cell eql-ms)
1357        (while cell
1358          (if (eql eql-element
1359                     (eql-specializer-object (nth argnum (%method.specializers (car cell)))))
1360            (let ((cell-save cell))
1361              (if last-cell
1362                (setf (%cdr last-cell) (cdr cell))
1363                (setq eql-ms (cdr eql-ms)))
1364              (setf cell (cdr cell)
1365                    (%cdr cell-save) this-element-methods
1366                    this-element-methods cell-save))
1367            (setq last-cell cell
1368                  cell (cdr cell))))
1369        (let* ((sorted-methods
1370                (sort-methods (nreconc (copy-list this-element-methods)
1371                                       (copy-list methods))
1372                              cpls
1373                              precedence-list))
1374               (method-list (and standard-mc? (compute-method-list sorted-methods))))
1375          (when (or (not standard-mc?)
1376                    (memq method-list this-element-methods)
1377                    (and (consp method-list)
1378                         (labels ((member-anywhere (tem mlist)
1379                                    (member tem mlist
1380                                            :test #'(lambda (tem el)
1381                                                      (if (listp el)
1382                                                        (member-anywhere tem el)
1383                                                        (member el tem))))))
1384                           (member-anywhere this-element-methods method-list))))
1385            ; Do EQL comparison only if the EQL methods can run
1386            ; (e.g. does not come after a primary method that does not call-next-method)
1387            (push (cons eql-element
1388                        (if sub-dispatch?
1389                          (make-n+1th-arg-combined-method
1390                           sorted-methods gf argnum)
1391                          (if standard-mc?
1392                            (make-standard-combined-method sorted-methods nil gf)
1393                            (compute-effective-method-function
1394                             real-gf method-combination sorted-methods))))
1395                  eql-method-alist)))))
1396    ;;eql-method-alist has (element . combined-method) pairs.
1397    ;;for now, we're going to use assq or assoc
1398    (let ((default-method (if sub-dispatch?
1399                            (make-n+1th-arg-combined-method
1400                             methods gf argnum)
1401                            (if standard-mc?
1402                              (make-standard-combined-method methods nil gf t)
1403                              (compute-effective-method-function
1404                               real-gf method-combination methods)))))
1405      (if eql-method-alist
1406        (%cons-combined-method 
1407         gf (cons argnum (cons eql-method-alist default-method))
1408         (if can-use-eq? 
1409           #'%%assq-combined-method-dcode
1410           #'%%assoc-combined-method-dcode))
1411        default-method))))
1412
1413
1414
1415
1416(defun %%assq-combined-method-dcode (stuff args)
1417  ;; stuff is (argnum eql-method-list . default-method)
1418  ;(declare (dynamic-extent args))
1419  (if (listp args)
1420    (let* ((args-len (list-length args))
1421           (argnum (car stuff)))
1422      (when (>= argnum args-len)(signal-program-error  "Too few args to ~s." (%method-gf (cddr stuff))))
1423      (let* ((arg (nth argnum args))
1424             (thing (assq arg (cadr stuff)))) ; are these things methods or method-functions? - fns   
1425        (if thing 
1426          (apply (cdr thing) args)
1427          (apply (cddr stuff) args))))
1428    (let* ((args-len (%lexpr-count args))
1429           (argnum (car stuff)))
1430      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1431      (let* ((arg (%lexpr-ref args args-len argnum))
1432             (thing (assq arg (cadr stuff))))
1433        (if thing 
1434          (%apply-lexpr (cdr thing) args)
1435          (%apply-lexpr (cddr stuff) args))))))
1436 
1437
1438(DEFun %%assoc-combined-method-dcode (stuff args)
1439  ;; stuff is (argnum eql-method-list . default-method)
1440  ;(declare (dynamic-extent args))
1441  (if (listp args)
1442    (let* ((args-len (list-length args))
1443           (argnum (car stuff)))
1444      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1445      (let* ((arg (nth argnum args))
1446             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1447        (if thing 
1448          (apply (cdr thing) args)
1449          (apply (cddr stuff) args))))
1450    (let* ((args-len (%lexpr-count args))
1451           (argnum (car stuff)))
1452      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1453      (let* ((arg (%lexpr-ref args args-len argnum))
1454             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1455        (if thing 
1456          (%apply-lexpr (cdr thing) args)
1457          (%apply-lexpr (cddr stuff) args))))))
1458
1459
1460;;; Assumes the two methods have the same number of specializers and
1461;;; that each specializer of each method is in the corresponding
1462;;; element of cpls (e.g. cpls is a list of the cpl's for the classes
1463;;; of args for which both method1 & method2 are applicable.
1464(defun %method< (method1 method2 cpls)
1465  (let ((s1s (%method.specializers method1))
1466        (s2s (%method.specializers method2))
1467        s1 s2 cpl)
1468    (loop
1469      (if (null s1s)
1470        (return (method-qualifiers< method1 method2)))
1471      (setq s1 (%pop s1s)
1472            s2 (%pop s2s)
1473            cpl (%pop cpls))
1474      (cond ((typep s1 'eql-specializer) 
1475             (unless (eq s1 s2)
1476               (return t)))
1477            ((typep s2 'eql-specializer) (return nil))
1478            ((eq s1 s2))
1479            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1480
1481(defun %simple-method< (method1 method2 cpl)
1482  (let ((s1 (%car (%method.specializers method1)))
1483        (s2 (%car (%method.specializers method2))))
1484    (cond ((typep s1 'eql-specializer) 
1485           (if (eq s1 s2)
1486             (method-qualifiers< method1 method2)
1487             t))
1488          ((typep s2 'eql-specializer) nil)
1489          ((eq s1 s2) (method-qualifiers< method1 method2))
1490          (t (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))
1491
1492; Sort methods with argument-precedence-order
1493(defun %hairy-method< (method1 method2 cpls apo)
1494  (let ((s1s (%method.specializers method1))
1495        (s2s (%method.specializers method2))
1496        s1 s2 cpl index)
1497    (loop
1498      (if (null apo)
1499        (return (method-qualifiers< method1 method2)))
1500      (setq index (pop apo))
1501      (setq s1 (nth index s1s)
1502            s2 (nth index s2s)
1503            cpl (nth index cpls))
1504      (cond ((typep s1 'eql-specializer) 
1505             (unless (eq s1 s2)
1506               (return t)))
1507            ((typep s2 'eql-specializer) (return nil))
1508            ((eq s1 s2))
1509            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1510
1511; This can matter if the user removes & reinstalls methods between
1512; invoking a generic-function and doing call-next-method with args.
1513; Hence, we need a truly canonical sort order for the methods
1514; (or a smarter comparison than EQUAL in %%cnm-with-args-check-methods).
1515(defun method-qualifiers< (method1 method2)
1516  (labels ((qualifier-list< (ql1 ql2 &aux q1 q2)
1517              (cond ((null ql1) (not (null ql2)))
1518                    ((null ql2) nil)
1519                    ((eq (setq q1 (car ql1)) (setq q2 (car ql2)))
1520                     (qualifier-list< (cdr ql1) (cdr ql2)))
1521                    ((string-lessp q1 q2) t)
1522                    ; This isn't entirely correct.
1523                    ; two qualifiers with the same pname in different packages
1524                    ; are not comparable here.
1525                    ; Unfortunately, users can change package names, hence,
1526                    ; comparing the package names doesn't work either.
1527                    (t nil))))
1528    (qualifier-list< (%method.qualifiers method1) (%method.qualifiers method2))))
1529       
1530(defun sort-methods (methods cpls &optional apo)
1531  (cond ((null cpls) methods)
1532        ((null (%cdr cpls))
1533         (setq cpls (%car cpls))
1534         (flet ((simple-sort-fn (m1 m2)
1535                  (%simple-method< m1 m2 cpls)))
1536           (declare (dynamic-extent #'simple-sort-fn))
1537           (%sort-list-no-key methods #'simple-sort-fn)))
1538        ((null apo)                     ; no unusual argument-precedence-order
1539         (flet ((sort-fn (m1 m2) 
1540                  (%method< m1 m2 cpls)))
1541           (declare (dynamic-extent #'sort-fn))
1542           (%sort-list-no-key methods #'sort-fn)))
1543        (t                              ; I guess some people are just plain rude
1544         (flet ((hairy-sort-fn (m1 m2)
1545                  (%hairy-method< m1 m2 cpls apo)))
1546           (declare (dynamic-extent #'hairy-sort-fn))
1547           (%sort-list-no-key methods #'hairy-sort-fn)))))
1548
1549(defun nremove-uncallable-next-methods (methods)
1550  (do ((m methods (%cdr m))
1551       mbits)
1552      ((null m))
1553    (setq mbits (lfun-bits (%method.function (%car m))))
1554    (unless (logbitp $lfbits-nextmeth-bit mbits)
1555      (setf (%cdr m) nil)
1556      (return)))
1557  methods)
1558
1559
1560(defun cpl-index (superclass cpl)
1561  ;; This will be table lookup later.  Also we'll prelookup the tables
1562  ;; in compute-1st-arg-combined-methods above.
1563  (locally (declare (optimize (speed 3)(safety 0)))
1564    (do ((i 0 (%i+ i 1))
1565         (cpl cpl (%cdr cpl)))
1566        ((null cpl) nil)
1567      (if (eq superclass (%car cpl))
1568        (return i)))))
1569
1570(defun cpl-memq (superclass cpl)
1571  (locally (declare (optimize (speed 3)(safety 0)))
1572    (do ((cpl cpl (%cdr cpl)))
1573        ((null cpl) nil)
1574      (if (eq superclass (%car cpl))
1575        (return cpl)))))
1576
1577;;; Combined method interpretation
1578
1579
1580;;; magic is a list of (cnm-cm (methods) . args) cnm-cm is the
1581;;; argument checker for call-next-method-with-args or nil could make
1582;;; it be a cons as a flag that magic has been heap consed - done
1583;;; could also switch car and cadr if we do &lexpr business then if
1584;;; cddr is lexpr-p (aka (not listp)) thats the clue also would need
1585;;; to do lexpr-apply or apply depending on the state.
1586
1587
1588(defun %%standard-combined-method-dcode (methods args)
1589  ;; combined-methods as made by make-combined-method are in methods
1590  ;; args are as put there by the caller of the gf.
1591  (let* ((car-meths (car methods))
1592         (cell-2 (cons methods args))
1593         (magic (cons nil cell-2)))
1594    ;; i.e. magic is nil methods . args
1595    (declare (dynamic-extent magic)
1596             (dynamic-extent cell-2))   
1597    (if (listp car-meths)
1598      (%%before-and-after-combined-method-dcode magic)
1599      (progn       
1600        (if (not (cdr methods))
1601          (%rplaca (cdr magic) car-meths)
1602          (%rplaca (cdr magic) (cdr methods)))
1603        ; so maybe its a combined-method ?? - no
1604        (apply-with-method-context magic (%method.function car-meths) args)))))
1605
1606;;; args is list, old-args may be lexpr
1607(defun cmp-args-old-args (args old-args numreq)
1608  (declare (optimize (speed 3)(safety 0)))
1609  (if (listp old-args)
1610    (do ((newl args (cdr newl))
1611         (oldl old-args (cdr oldl))
1612         (i 0 (1+ i)))
1613        ((eql i numreq) t)
1614      (when (neq (car newl)(car oldl))(return nil)))
1615    (let ((len (%lexpr-count old-args)))
1616      (do ((newl args (cdr newl))
1617           (i 0 (1+ i)))
1618          ((eql i numreq) t)
1619        (when (neq (car newl)(%lexpr-ref old-args len i))(return nil))))))       
1620
1621
1622; called from call-next-method-with-args with magic supplied and 1st time around with not
1623(defun %%cnm-with-args-combined-method-dcode (thing args &optional magic) ; was &rest args
1624  ;(declare (dynamic-extent args))
1625  ; now thing is vector of gf orig methods, arg for key or initarg check, key or initarg fnction
1626  ; and our job is to do all the arg checking
1627  (let ()
1628    (when magic
1629      (flet ((do-it (thing args)
1630               (let* ((args-len (length args))
1631                      (gf (svref thing 0))  ; could get this from a method
1632                      (numreq (ldb $lfbits-numreq (inner-lfun-bits gf)))
1633                      (next-methods (cadr magic)))
1634                 ;(when (null self)(error "Next method with args context error"))
1635                 (when (neq 0 numreq)
1636                   ; oh screw it - old-args may be lexpr too
1637                   (let ((old-args (cddr magic)))
1638                     (when (< args-len numreq) (signal-program-error "Too few args to ~S" gf))
1639                     (when (null (cmp-args-old-args args old-args numreq))
1640                       ; required args not eq - usually true, we expect
1641                       (let ((new-methods (%compute-applicable-methods* gf args))
1642                             (old-methods (svref thing 1)))
1643                         (when (not (equal new-methods old-methods))
1644                           (error '"Applicable-methods changed in call-next-method.~%~
1645                                    Should be: ~s~%Was: ~s~%Next-methods: ~s"
1646                                  old-methods new-methods next-methods))))))
1647                 (let ((key-or-init-fn (svref thing 3)))
1648                   (when key-or-init-fn 
1649                     ; was apply
1650                     (funcall key-or-init-fn (svref thing 2) args))))))
1651        (if (listp args)
1652          (do-it thing args)
1653          (with-list-from-lexpr (args-list args)
1654            (do-it thing args-list)))))
1655    ; ok done checking - lets do it
1656    (let* ((methods (if magic (cadr magic)(svref thing 4)))  ;<< was 5 this is nil unless cnm with args
1657           ; was if magic
1658           (car-meths (car methods))
1659           (cell-2 (cons methods args))
1660           (magic (cons thing cell-2)))
1661      (declare (dynamic-extent magic cell-2))
1662      ; i.e. magic is thing methods . args
1663      ;(%rplaca magic thing)
1664      ;(setf (cadr magic) methods)
1665      ;(%rplaca (cdr magic) methods)
1666      ;(setf (cddr magic) args)
1667      ;(%rplacd (cdr magic) args)
1668      (if (listp car-meths)
1669        (progn
1670          (%%before-and-after-combined-method-dcode magic))
1671        (progn       
1672          (if (not (cdr methods))
1673            (%rplaca (cdr magic) car-meths)
1674            (%rplaca (cdr magic) (cdr methods)))
1675          ; so maybe its a combined-method ?? - no
1676          (apply-with-method-context magic (%method.function car-meths) args))))))
1677
1678
1679
1680;;; here if car of methods is listp. methods = (befores afters . primaries)
1681(defun %%before-and-after-combined-method-dcode (magic) 
1682  (declare (list magic))
1683  (let* ((methods (cadr magic))         
1684         (befores (car methods))         
1685         (cdr-meths (cdr methods))
1686         (primaries (cdr cdr-meths))
1687         (afters (car cdr-meths))
1688         (args (cddr magic)))
1689    (declare (list befores afters primaries))
1690    (when befores 
1691      (dolist (method befores)
1692        (rplaca (cdr magic) method)
1693        (apply-with-method-context magic (%method.function method) args)))
1694    (let* ((cdr (cdr primaries))
1695           (method-function (%method.function (car primaries))))   ; guaranteed non nil?
1696      (rplaca (cdr magic) (if (null cdr)(car primaries) cdr))     
1697      (if (null afters)
1698        (apply-with-method-context magic method-function args)  ; tail call if possible
1699        (multiple-value-prog1
1700          (apply-with-method-context magic method-function args)       
1701          (dolist (method afters)
1702            (rplaca (cdr magic) method)
1703            (apply-with-method-context magic (%method.function method) args)))))))
1704
1705
1706; This is called by the compiler expansion of next-method-p
1707; I think there's a bug going around... LAP fever! I'm immune
1708(defun %next-method-p (magic)
1709  (let ((methods (%cadr magic)))
1710    (consp methods)))
1711
1712
1713(defun %call-next-method (magic &rest args) ; if args supplied they are new ones
1714  (declare (dynamic-extent args)) 
1715  (if args
1716    (apply #'%call-next-method-with-args magic args)
1717    (let* ((next-methods (%cadr magic))) ; don't get this closed magic stuff     
1718      (if (not (consp next-methods))
1719        ( %no-next-method  magic)           
1720        (let ((args (%cddr magic)))  ; get original args
1721          ;The unwind-protect is needed in case some hacker in his/her wisdom decides to:
1722          ; (defmethod foo (x) (catch 'foo (call-next-method)) (call-next-method))
1723          ; where the next-method throws to 'foo.
1724          ; The alternative is to make a new magic var with args
1725          ; actually not that fancy (call-next-method)(call-next-method) is same problem
1726          (let ()
1727            (unwind-protect
1728              (if (listp (car next-methods))
1729                ( %%before-and-after-combined-method-dcode magic)
1730                (let ((cdr (cdr next-methods)))
1731                  (rplaca (cdr magic)(if (not cdr)(car next-methods) cdr))
1732                  (let ((method-function (%method.function (car next-methods))))
1733                    (apply-with-method-context magic method-function args))))
1734              (rplaca (cdr magic) next-methods))))))))
1735
1736;; Note: we need to change the compiler to call this when it can prove that
1737;; call-next-method cannot be called a second time. I believe thats done.
1738
1739
1740(defun %tail-call-next-method (magic)
1741  (let* ((next-methods (%cadr magic))  ; or make it car
1742         (args (%cddr magic))) ; get original args       
1743    (if (not (consp next-methods)) ; or consp?
1744      ( %no-next-method magic)
1745      (if (listp (car next-methods))
1746        ( %%before-and-after-combined-method-dcode magic)
1747        (let ((cdr (cdr next-methods)))
1748          (rplaca (cdr magic) (if (not cdr)(car next-methods) cdr))
1749          (apply-with-method-context magic (%method.function (car next-methods)) args))))))
1750
1751; may be simpler to blow another cell so magic looks like
1752; (cnm-cm/nil next-methods . args) - done
1753; and also use first cell to mean heap-consed if itsa cons
1754
1755(defun %call-next-method-with-args (magic &rest args)
1756  (declare (dynamic-extent args))
1757  (if (null args)
1758    (%call-next-method magic)
1759    (let* ((methods (%cadr magic)))
1760      (if (not (consp methods))
1761        (%no-next-method  magic)
1762        (let* ((cnm-cm (car magic)))
1763          ; a combined method
1764          (when (consp cnm-cm)(setq cnm-cm (car cnm-cm)))
1765          ; could just put the vector in car magic & no self needed in vector?
1766          (let ((the-vect cnm-cm)) ;  <<
1767            (funcall #'%%cnm-with-args-combined-method-dcode ;(%combined-method-dcode cnm-cm)
1768                     the-vect
1769                     args
1770                     magic)))))))
1771
1772
1773
1774; called from x%%call-next-method-with-args - its the key-or-init-fn
1775(defun %%cnm-with-args-check-initargs (init-cell args)
1776  ; here we forget the lexpr idea because it wants to cdr
1777  ;(declare (dynamic-extent args))
1778  (let* ((rest (cdr args))
1779         (first-arg (car args)))
1780    (declare (list rest))
1781    (let* ((initargs rest)
1782           (init-function (car init-cell))
1783           (instance (cond ((eq init-function #'update-instance-for-different-class)
1784                            (setq initargs (cdr rest))
1785                            (car rest))
1786                           ((eq init-function #'shared-initialize)
1787                            (setq initargs (cdr rest))
1788                            first-arg)
1789                           ((eq init-function #'update-instance-for-redefined-class)
1790                            (setq initargs (%cdddr rest))
1791                            first-arg)
1792                           (t first-arg)))
1793           (class (class-of instance))
1794           bad-initarg)
1795      (dolist (functions (cdr init-cell)
1796                         (error "Bad initarg: ~s to call-next-method for ~s~%on ~s"
1797                                bad-initarg instance (car init-cell)))
1798        (multiple-value-bind 
1799          (errorp bad-key)
1800          (if (eq (car functions) #'initialize-instance)
1801            (apply #'check-initargs instance class initargs nil
1802                   #'initialize-instance #'allocate-instance #'shared-initialize
1803                   nil)
1804            (apply #'check-initargs instance class initargs nil functions))
1805          (if errorp
1806            (unless bad-initarg (setq bad-initarg bad-key))
1807            (return t)))))))
1808
1809
1810
1811(defun %no-next-method (magic)
1812  (let* ((method (%cadr magic)))
1813    (if (consp method) (setq method (car method)))
1814    (unless (typep method 'standard-method)
1815      (error "call-next-method called outside of generic-function dispatch context.~@
1816              Usually indicates an error in a define-method-combination form."))
1817    (let ((args (cddr magic))
1818          (gf (%method.gf method)))
1819      (if (listp args)
1820        (apply #'no-next-method gf method args)
1821        (%apply-lexpr #'no-next-method gf method args)))))
1822
1823
1824
1825
1826;;; This makes a consed version of the magic first arg to a method.
1827;;; Called when someone closes over the magic arg. (i.e. does (george
1828;;; #'call-next-method))
1829
1830(defun %cons-magic-next-method-arg (magic)
1831  ; car is a cons as a flag that its already heap-consed! - else cnm-cm or nil
1832  (if (consp (car magic))
1833    magic
1834    (list* (list (car magic))
1835           (if (consp (%cadr magic))
1836             (copy-list (%cadr magic)) ; is this copy needed - probably not
1837             (cadr magic))
1838           (let ((args (%cddr magic)))
1839             (if (listp args)
1840               (copy-list args)
1841               (let* ((len (%lexpr-count args))
1842                      (l (make-list len)))
1843                 (do ((i 0 (1+ i))
1844                      (list l (cdr list)))
1845                     ((null list))
1846                   (%rplaca list (%lexpr-ref args len i)))
1847                 l))))))
1848
1849
1850; Support CALL-METHOD in DEFINE-METHOD-COMBINATION
1851(defun %%call-method* (method next-methods args)
1852  (let* ((method-function (%method.function method))
1853         (bits (lfun-bits method-function)))
1854    (declare (fixnum bits))
1855    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1856                  (logbitp  $lfbits-method-bit bits)))
1857      (if (listp args)
1858        (apply method-function args)
1859        (%apply-lexpr method-function args))
1860      (let* ((cell-2 (cons next-methods args))
1861             (magic (cons nil cell-2)))
1862        (declare (dynamic-extent magic)
1863                 (dynamic-extent cell-2)) 
1864        (if (null next-methods)
1865          (%rplaca (cdr magic) method))
1866        (apply-with-method-context magic method-function args)))))
1867
1868; Error checking version for user's to call
1869(defun %call-method* (method next-methods args)
1870  (let* ((method-function (%method.function method))
1871         (bits (lfun-bits method-function)))
1872    (declare (fixnum bits))
1873    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1874                  (logbitp  $lfbits-method-bit bits)))
1875      (progn
1876        (require-type method 'standard-method)
1877        (if (listp args)
1878          (apply method-function args)
1879          (%apply-lexpr method-function args)))
1880      (progn
1881        (do* ((list next-methods (cdr list)))
1882             ((null list))
1883          (when (not (listp list))
1884            (%err-disp $XIMPROPERLIST next-methods))
1885          (when (not (standard-method-p (car list)))
1886            (report-bad-arg (car list) 'standard-method))) 
1887        (let* ((cell-2 (cons next-methods args))
1888               (magic (cons nil cell-2)))
1889          (declare (dynamic-extent magic)
1890                   (dynamic-extent cell-2)) 
1891          (if (null next-methods)
1892            (%rplaca (cdr magic) method))
1893          (apply-with-method-context magic method-function args))))))
1894
1895
1896
Note: See TracBrowser for help on using the repository browser.