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

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

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