source: branches/x8664-call/ccl/level-1/l1-dcode.lisp @ 6399

Last change on this file since 6399 was 6399, checked in by gb, 15 years ago

In SET-GF-ARG-INFO, clear the dt cache if APO changes.

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