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

Last change on this file since 3967 was 3967, checked in by gb, 14 years ago

Comments and formatting changes only.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 73.6 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  (let* ((methods (%gf-dispatch-table-methods (%gf-dispatch-table gf)))
867         (cpl (%inited-class-cpl (%wrapper-class wrapper)))
868         (method-combination (%gf-method-combination gf))
869         applicable-methods eql-methods specializer)
870    (dolist (method methods)
871      (setq specializer (%car (%method.specializers method)))
872      (if (typep specializer 'eql-specializer)
873        (when (cpl-memq (%wrapper-class (arg-wrapper (eql-specializer-object specializer))) cpl)
874          (push method eql-methods))
875        (when (cpl-memq specializer cpl)
876          (push method applicable-methods))))
877    (if (null eql-methods)
878      (if (eq method-combination *standard-method-combination*)
879        (make-standard-combined-method applicable-methods (list cpl) gf)
880        (compute-effective-method-function 
881         gf 
882         method-combination
883         (sort-methods applicable-methods
884                       (list cpl)
885                       (%gf-precedence-list gf))))
886      (make-eql-combined-method 
887       eql-methods applicable-methods (list cpl) gf 0 nil method-combination))))
888     
889
890
891(defvar *combined-methods* (make-hash-table  :test 'equal :weak :value))                         
892
893(defun gethash-combined-method (key)
894  (gethash key *combined-methods*))
895
896(defun puthash-combined-method (key value)
897  (setf (gethash key *combined-methods*) value))
898
899;;; Some statistics on the hash table above
900(defvar *returned-combined-methods* 0)
901(defvar *consed-combined-methods* 0)
902
903;;; Assumes methods are already sorted if cpls is nil
904(defun make-standard-combined-method (methods cpls gf &optional
905                                              (ok-if-no-primaries (null methods)))
906  (unless (null cpls)
907    (setq methods (sort-methods 
908                   methods cpls (%gf-precedence-list (combined-method-gf gf)))))
909  (let* ((keywords (compute-allowable-keywords-vector gf methods))
910         (combined-method (make-standard-combined-method-internal
911                           methods gf keywords ok-if-no-primaries)))
912    (if (and keywords methods)
913      (make-keyword-checking-combined-method gf combined-method keywords)
914      combined-method)))
915
916
917;;; Initialized below after the functions exist.
918(defvar *clos-initialization-functions* nil)
919
920;;; Returns NIL if all keywords allowed, or a vector of the allowable ones.
921(defun compute-allowable-keywords-vector (gf methods)
922  (setq gf (combined-method-gf gf))
923  (unless (memq gf *clos-initialization-functions*)
924    (let* ((gbits (inner-lfun-bits gf))
925           (&key-mentioned-p (logbitp $lfbits-keys-bit gbits)))
926      (unless (or (logbitp $lfbits-aok-bit gbits)
927                  (dolist (method methods)
928                    (let ((mbits (lfun-bits (%method.function method))))
929                      (when (logbitp $lfbits-keys-bit mbits)
930                        (setq &key-mentioned-p t)
931                        (if (logbitp $lfbits-aok-bit mbits)
932                          (return t)))))
933                  (not &key-mentioned-p))
934        (let (keys)
935          (flet ((adjoin-keys (keyvect keys)
936                              (when keyvect
937                                (dovector (key keyvect) (pushnew key keys)))
938                              keys))
939            (when (logbitp $lfbits-keys-bit gbits)
940              (setq keys (adjoin-keys (%defgeneric-keys gf) keys)))
941            (dolist (method methods)
942              (let ((f (%inner-method-function method)))
943                (when (logbitp $lfbits-keys-bit (lfun-bits f))
944                  (setq keys (adjoin-keys (lfun-keyvect f) keys))))))
945          (apply #'vector keys))))))
946
947
948(defun make-keyword-checking-combined-method (gf combined-method keyvect)
949  (let* ((bits (inner-lfun-bits gf))
950         (numreq (ldb $lfbits-numreq bits))
951         (key-index (+ numreq (ldb $lfbits-numopt bits))))
952    (%cons-combined-method 
953     gf       
954     (vector key-index keyvect combined-method)
955     #'%%check-keywords)))
956
957
958
959(defun odd-keys-error (varg l) 
960  (let ((gf (combined-method-gf (%svref varg 2))))
961    (signal-program-error "Odd number of keyword args to ~s~%keyargs: ~s" gf l)))
962
963
964(defun bad-key-error (key varg l)
965  (let* ((keys (%svref varg 1))
966         (gf (combined-method-gf (%svref varg 2)))
967         (*print-array* t)
968         (*print-readably* t)
969         (readable-keys (format nil "~s" keys)))
970    (signal-program-error "Bad keyword ~s to ~s.~%keyargs: ~s~%allowable keys are ~a." key gf l readable-keys)))
971
972; vector arg is (vector key-index keyvect combined-method) ; the next combined method
973
974(defun %%check-keywords (vector-arg args)
975  (flet ((do-it (vector-arg args)
976           (let* ((args-len (length args))
977                  (keyvect (%svref vector-arg 1))
978                  (keyvect-len (length keyvect))
979                  (key-index (%svref vector-arg 0)))
980                                        ; vector arg is (vector key-index keyvect combined-method) ; the next combined method
981             (declare (fixnum args-len key-index keyvect-len))
982             (when (>= args-len key-index)
983               (let* ((keys-in (- args-len key-index))) ; actually * 2
984                 (declare (fixnum  key-index keys-in keyvect-len))
985                 (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len)))
986                 (unless (%cadr (%pl-search (nthcdr key-index args) :allow-other-keys))
987                   (do ((i key-index (+ i 2))
988                        (kargs (nthcdr key-index args) (cddr kargs)))
989                       ((eq i args-len))
990                     (declare (fixnum i))
991                     (let ((key (car kargs)))
992                       (when (not (or (eq key :allow-other-keys)
993                                      (dotimes (i keyvect-len nil)
994                                        (if (eq key (%svref keyvect i))
995                                          (return t)))))
996                         (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len))
997                         ))))))
998             (let ((method (%svref vector-arg 2)))
999                                        ; magic here ?? not needed
1000               (apply method args)))))
1001    (if (listp args)
1002      (do-it vector-arg args)
1003      (with-list-from-lexpr (args-list args)
1004        (do-it vector-arg args-list)))))
1005
1006
1007
1008 
1009
1010
1011; called from %%call-next-method-with-args - its the key-or-init-fn
1012; called from call-next-method-with-args - just check the blooming keys
1013; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil
1014; means dont call any methods - but need the gf or method for error message
1015(defun x-%%check-keywords (vector-arg ARGS)
1016  ;(declare (dynamic-extent args))
1017    ; vector arg is (vector key-index keyvect unused)
1018  (let* ((ARGS-LEN (length args))
1019         (keyvect (%svref vector-arg 1))
1020         (keyvect-len (length keyvect))
1021         (key-index (%svref vector-arg 0))
1022         (keys-in (- args-len key-index))
1023         aok)  ; actually * 2
1024    (declare (fixnum args-len key-index keys-in keyvect-len))
1025   
1026    (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len)))
1027    (do ((i key-index (+ i 2))
1028         (kargs (nthcdr key-index args) (cddr kargs)))
1029        ((eq i args-len))
1030      (declare (fixnum i))
1031      (when aok (return))
1032      (let ((key (car kargs)))
1033        (when (and (eq key :allow-other-keys)
1034                   (cadr kargs))
1035          (return))
1036        (when (not (dotimes (i keyvect-len nil)
1037                     (if (eq key (%svref keyvect i))
1038                       (return t))))
1039          ; not found - is :allow-other-keys t in rest of user args
1040          (when (not (do ((remargs kargs (cddr remargs)))
1041                         ((null remargs) nil)
1042                       (when (and (eq (car remargs) :allow-other-keys)
1043                                  (cadr remargs))
1044                         (setq aok t)
1045                         (return t))))             
1046            (bad-key-error key vector-arg 
1047                           (collect-lexpr-args args key-index args-len))))))))
1048#| ; testing
1049(setq keyvect  #(:a :b ))
1050(setq foo (make-array 3))
1051(setf (aref foo 0) keyvect (aref foo 1) 2)
1052(setf (aref foo 2)(method window-close (window)))
1053( %%check-keywords 1 2 :a 3 :c 4 foo)
1054( %%check-keywords 1 2 :a 3 :b 4 :d foo)
1055|#
1056 
1057   
1058
1059
1060
1061; Map an effective-method to it's generic-function.
1062; This is only used for effective-method's which are not combined-method's
1063; (e.g. those created by non-STANDARD method-combination)
1064(defvar *effective-method-gfs* (make-hash-table :test 'eq :weak :key))
1065
1066
1067(defun get-combined-method (method-list gf)
1068  (let ((cm (gethash-combined-method method-list)))
1069    (when cm
1070      (setq gf (combined-method-gf gf))
1071      (if (combined-method-p cm)
1072        (and (eq (combined-method-gf cm) gf) cm)
1073        (and (eq (gethash cm *effective-method-gfs*) gf) cm)))))
1074
1075(defun put-combined-method (method-list cm gf)
1076  (unless (%method-function-p cm)       ; don't bother with non-combined methods
1077    (puthash-combined-method method-list cm)
1078    (unless (combined-method-p cm)
1079      (setf (gethash cm *effective-method-gfs*) (combined-method-gf gf))))
1080  cm)
1081
1082(defun make-standard-combined-method-internal (methods gf &optional 
1083                                                       keywords
1084                                                       (ok-if-no-primaries
1085                                                        (null methods)))
1086  (let ((method-list (and methods (compute-method-list methods))))
1087    (if method-list                 ; no applicable primary methods
1088      (if (atom method-list)
1089        (%method.function method-list)    ; can jump right to the method-function
1090        (progn
1091          (incf *returned-combined-methods*)  ; dont need this
1092          (if (contains-call-next-method-with-args-p method-list)
1093            (make-cnm-combined-method gf methods method-list keywords)
1094            (or (get-combined-method method-list gf)
1095                (progn
1096                  (incf *consed-combined-methods*)  ; dont need this
1097                  (puthash-combined-method
1098                   method-list
1099                   (%cons-combined-method
1100                    gf method-list #'%%standard-combined-method-dcode)))))))
1101      (if ok-if-no-primaries
1102        (make-no-applicable-method-function (combined-method-gf gf))
1103        (no-applicable-primary-method gf methods)))))
1104
1105; Initialized after the initialization (generic) functions exist.
1106(defvar *initialization-functions-alist* nil)
1107
1108; This could be in-line above, but I was getting confused.
1109
1110; ok
1111(defun make-cnm-combined-method (gf methods method-list keywords)
1112  (setq gf (combined-method-gf gf))
1113  (let ((key (cons methods method-list)))
1114    (or (get-combined-method key gf)
1115        (let* (key-or-init-arg
1116               key-or-init-fn)
1117          (if keywords
1118            (let* ((bits (inner-lfun-bits gf))
1119                   (numreq (ldb $lfbits-numreq bits))
1120                   (key-index (+ numreq (ldb $lfbits-numopt bits))))
1121              (setq key-or-init-arg (vector key-index keywords gf))
1122              (setq key-or-init-fn #'x-%%check-keywords))
1123            (let ((init-cell (assq gf *initialization-functions-alist*)))
1124              (when init-cell               
1125                (setq key-or-init-arg init-cell)
1126                (setq key-or-init-fn #'%%cnm-with-args-check-initargs))))
1127          (incf *consed-combined-methods*)
1128          (let* ((vect (vector gf methods key-or-init-arg key-or-init-fn method-list))
1129                 (self (%cons-combined-method
1130                        gf vect #'%%cnm-with-args-combined-method-dcode)))
1131            ;(setf (svref vect 4) self)
1132            (puthash-combined-method ; if  testing 1 2 3 dont put in our real table
1133             key
1134             self))))))
1135
1136
1137(defparameter *check-call-next-method-with-args* t)
1138
1139(defun contains-call-next-method-with-args-p (method-list)
1140  (when *check-call-next-method-with-args*
1141    (let ((methods method-list)
1142          method)
1143      (loop
1144        (setq method (pop methods))
1145        (unless methods (return nil))
1146        (unless (listp method)
1147          (if (logbitp $lfbits-nextmeth-with-args-bit
1148                       (lfun-bits (%method.function method)))
1149            (return t)))))))
1150
1151;;; The METHODS arg is a sorted list of applicable methods.  Returns
1152;;; the method-list expected by
1153;;; %%before-and-after-combined-method-dcode or a single method, or
1154;;; NIL if there are no applicable primaries
1155(defun compute-method-list (methods)
1156  (let (arounds befores primaries afters qs)
1157    (dolist (m methods)
1158      (setq qs (%method.qualifiers m))
1159      (if qs
1160        (if (cdr qs)
1161          (%invalid-method-error
1162           m "Multiple method qualifiers not allowed in ~s method combination"
1163           'standard)
1164          (case (car qs)
1165            (:before (push m befores))
1166            (:after (push m afters))
1167            (:around (push m arounds))
1168            (t (%invalid-method-error m "~s is not one of ~s, ~s, and ~s."
1169                                      (car qs) :before :after :around))))
1170        (push m primaries)))
1171    (setq primaries (nremove-uncallable-next-methods (nreverse primaries))
1172          arounds (nremove-uncallable-next-methods (nreverse arounds))
1173          befores (nreverse befores))     
1174    (flet ((next-method-bit-p (method)
1175                              (logbitp $lfbits-nextmeth-bit 
1176                                       (lfun-bits (%method.function method)))))
1177      (unless (null primaries)            ; return NIL if no applicable primary methods
1178        (when (and arounds (not (next-method-bit-p (car (last arounds)))))
1179          ;; Arounds don't call-next-method, can't get to befores,
1180          ;; afters, or primaries
1181          (setq primaries arounds
1182                arounds nil
1183                befores nil
1184                afters nil))
1185        (if (and (null befores) (null afters)
1186                 (progn
1187                   (when arounds
1188                     (setq primaries (nremove-uncallable-next-methods
1189                                      (nconc arounds primaries))
1190                           arounds nil))
1191                   t)
1192                 (null (cdr primaries))
1193                 (not (next-method-bit-p (car primaries))))
1194          (car primaries)                 ; single method, no call-next-method
1195          (let ((method-list primaries))
1196            (if (or befores afters)
1197              (setq method-list (cons befores (cons afters method-list))))
1198            (nconc arounds method-list)))))))
1199
1200
1201
1202(defun %invalid-method-error (method format-string &rest format-args)
1203  (error "~s is an invalid method.~%~?" method format-string format-args))
1204
1205(defun %method-combination-error (format-string &rest args)
1206  (apply #'error format-string args))
1207
1208
1209
1210(defun combined-method-gf (gf-or-cm)
1211  (let ((gf gf-or-cm))
1212    (while (combined-method-p gf)
1213      (setq gf (lfun-name gf)))
1214    gf))
1215
1216
1217(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args)
1218  (let* ((argnum (%gf-dispatch-table-argnum table))
1219         (arg (nth argnum args)))
1220    (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper)))
1221
1222
1223(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional
1224                                              (arg (nth-or-gf-error 
1225                                                    argnum args gf-or-cm))
1226                                              (wrapper (arg-wrapper arg)))
1227  ;; Here when we can't find the method in the dispatch table.
1228  ;; Compute it and add it to the table.  This code will remain in Lisp.
1229  (multiple-value-bind (combined-method sub-dispatch?)
1230                       (compute-nth-arg-combined-method
1231                        gf-or-cm (%gf-dispatch-table-methods table) argnum args
1232                        wrapper)
1233    (multiple-value-bind (index obsolete-wrappers-p)
1234                         ( find-gf-dispatch-table-index table wrapper)
1235      (if index
1236        (setf (%gf-dispatch-table-ref table index) wrapper
1237              (%gf-dispatch-table-ref table (%i+ index 1)) combined-method)
1238        (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
1239    (if sub-dispatch?
1240      (let ((table (%combined-method-methods combined-method)))
1241        (nth-arg-combined-method-trap
1242         combined-method
1243         table
1244         (%gf-dispatch-table-argnum table)
1245         args))
1246      combined-method)))
1247
1248;;; Returns (values combined-method sub-dispatch?)
1249;;; If sub-dispatch? is true, need to compute a combined-method on the
1250;;; next arg.
1251(defun compute-nth-arg-combined-method (gf methods argnum args &optional 
1252                                           (wrapper (arg-wrapper
1253                                                     (nth-or-gf-error
1254                                                      argnum args gf))))
1255  (let* ((cpl (%inited-class-cpl (%wrapper-class wrapper)))
1256         (real-gf (combined-method-gf gf))
1257         (mc (%gf-method-combination real-gf))
1258         (standard-mc? (eq mc *standard-method-combination*))
1259         applicable-methods eql-methods specializers specializer sub-dispatch?)
1260    (dolist (method methods)
1261      ;;(require-type method 'standard-method)   ; for debugging.
1262      (setq specializers (nthcdr argnum (%method.specializers method))
1263            specializer (%car specializers))
1264      (when (if (typep specializer 'eql-specializer)
1265              (when (cpl-memq (%wrapper-class
1266                                (arg-wrapper (eql-specializer-object specializer))) cpl)
1267                (push method eql-methods))
1268              (when (cpl-memq specializer cpl)
1269                (push method applicable-methods)))
1270        (if (contains-non-t-specializer? (%cdr specializers))
1271          (setq sub-dispatch? t))))
1272    (if (or eql-methods applicable-methods)
1273      (if (or (not standard-mc?)
1274            (contains-primary-method? applicable-methods)
1275            (contains-primary-method? eql-methods))
1276        (let ((cpls (args-cpls args)))
1277          (if eql-methods
1278            (make-eql-combined-method
1279             eql-methods applicable-methods cpls gf argnum sub-dispatch? mc)
1280            (if sub-dispatch?
1281              (values (make-n+1th-arg-combined-method applicable-methods gf argnum)
1282                      t)
1283              (if standard-mc?
1284                (make-standard-combined-method applicable-methods cpls gf)
1285                (compute-effective-method-function
1286                 real-gf mc (sort-methods applicable-methods
1287                                          (args-cpls args)
1288                                          (%gf-precedence-list real-gf)))))))
1289        (no-applicable-primary-method
1290         real-gf
1291         (sort-methods (append eql-methods applicable-methods)
1292                       (args-cpls args)
1293                       (%gf-precedence-list real-gf))))
1294       (make-no-applicable-method-function real-gf))))
1295
1296(defun nth-or-gf-error (n l gf)
1297  (declare (fixnum l))
1298  (do* ((i 0 (1+ i))
1299        (l l (cdr l)))
1300       ((null l) (dcode-too-few-args i gf))
1301    (declare (fixnum i))
1302    (if (= i n)
1303      (return (car l)))))
1304
1305(defun contains-non-t-specializer? (specializer-list)
1306  (dolist (s specializer-list nil)
1307    (unless (eq *t-class* s)
1308      (return t))))
1309
1310(defun contains-primary-method? (method-list)
1311  (dolist (m method-list nil)
1312    (if (null (%method.qualifiers m))
1313      (return t))))
1314
1315(defun args-cpls (args &aux res)
1316  (dolist (arg args)
1317    (push (%inited-class-cpl (%wrapper-class (arg-wrapper arg))) res))
1318  (nreverse res))
1319
1320
1321
1322;;; This needs to be updated to use a linear search in a vector changing to
1323;;; a hash table when the number of entries crosses some threshold.
1324(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
1325                                             (method-combination *standard-method-combination*))
1326  (let ((eql-ms (copy-list eql-methods))
1327        (precedence-list (%gf-precedence-list (combined-method-gf gf)))
1328        (standard-mc? (eq method-combination *standard-method-combination*))
1329        (real-gf (combined-method-gf gf))
1330        eql-method-alist
1331        (can-use-eq? t))
1332    (unless sub-dispatch?
1333      (setq methods (sort-methods methods cpls precedence-list)))
1334    (while eql-ms
1335      (let ((eql-element (eql-specializer-object (nth argnum (%method.specializers (car eql-ms)))))
1336            (this-element-methods eql-ms)
1337            cell last-cell)
1338        (if (or (and (numberp eql-element) (not (fixnump eql-element)))
1339                (macptrp eql-element))
1340          (setq can-use-eq? nil))
1341        (setf eql-ms (%cdr eql-ms)
1342              (%cdr this-element-methods) nil
1343              cell eql-ms)
1344        (while cell
1345          (if (eql eql-element
1346                     (eql-specializer-object (nth argnum (%method.specializers (car cell)))))
1347            (let ((cell-save cell))
1348              (if last-cell
1349                (setf (%cdr last-cell) (cdr cell))
1350                (setq eql-ms (cdr eql-ms)))
1351              (setf cell (cdr cell)
1352                    (%cdr cell-save) this-element-methods
1353                    this-element-methods cell-save))
1354            (setq last-cell cell
1355                  cell (cdr cell))))
1356        (let* ((sorted-methods
1357                (sort-methods (nreconc (copy-list this-element-methods)
1358                                       (copy-list methods))
1359                              cpls
1360                              precedence-list))
1361               (method-list (and standard-mc? (compute-method-list sorted-methods))))
1362          (when (or (not standard-mc?)
1363                    (memq method-list this-element-methods)
1364                    (and (consp method-list)
1365                         (labels ((member-anywhere (tem mlist)
1366                                    (member tem mlist
1367                                            :test #'(lambda (tem el)
1368                                                      (if (listp el)
1369                                                        (member-anywhere tem el)
1370                                                        (member el tem))))))
1371                           (member-anywhere this-element-methods method-list))))
1372            ; Do EQL comparison only if the EQL methods can run
1373            ; (e.g. does not come after a primary method that does not call-next-method)
1374            (push (cons eql-element
1375                        (if sub-dispatch?
1376                          (make-n+1th-arg-combined-method
1377                           sorted-methods gf argnum)
1378                          (if standard-mc?
1379                            (make-standard-combined-method sorted-methods nil gf)
1380                            (compute-effective-method-function
1381                             real-gf method-combination sorted-methods))))
1382                  eql-method-alist)))))
1383    ;;eql-method-alist has (element . combined-method) pairs.
1384    ;;for now, we're going to use assq or assoc
1385    (let ((default-method (if sub-dispatch?
1386                            (make-n+1th-arg-combined-method
1387                             methods gf argnum)
1388                            (if standard-mc?
1389                              (make-standard-combined-method methods nil gf t)
1390                              (compute-effective-method-function
1391                               real-gf method-combination methods)))))
1392      (if eql-method-alist
1393        (%cons-combined-method 
1394         gf (cons argnum (cons eql-method-alist default-method))
1395         (if can-use-eq? 
1396           #'%%assq-combined-method-dcode
1397           #'%%assoc-combined-method-dcode))
1398        default-method))))
1399
1400
1401
1402
1403(defun %%assq-combined-method-dcode (stuff args)
1404  ;; stuff is (argnum eql-method-list . default-method)
1405  ;(declare (dynamic-extent args))
1406  (if (listp args)
1407    (let* ((args-len (list-length args))
1408           (argnum (car stuff)))
1409      (when (>= argnum args-len)(signal-program-error  "Too few args to ~s." (%method-gf (cddr stuff))))
1410      (let* ((arg (nth argnum args))
1411             (thing (assq arg (cadr stuff)))) ; are these things methods or method-functions? - fns   
1412        (if thing 
1413          (apply (cdr thing) args)
1414          (apply (cddr stuff) args))))
1415    (let* ((args-len (%lexpr-count args))
1416           (argnum (car stuff)))
1417      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1418      (let* ((arg (%lexpr-ref args args-len argnum))
1419             (thing (assq arg (cadr stuff))))
1420        (if thing 
1421          (%apply-lexpr (cdr thing) args)
1422          (%apply-lexpr (cddr stuff) args))))))
1423 
1424
1425(DEFun %%assoc-combined-method-dcode (stuff args)
1426  ;; stuff is (argnum eql-method-list . default-method)
1427  ;(declare (dynamic-extent args))
1428  (if (listp args)
1429    (let* ((args-len (list-length args))
1430           (argnum (car stuff)))
1431      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1432      (let* ((arg (nth argnum args))
1433             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1434        (if thing 
1435          (apply (cdr thing) args)
1436          (apply (cddr stuff) args))))
1437    (let* ((args-len (%lexpr-count args))
1438           (argnum (car stuff)))
1439      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
1440      (let* ((arg (%lexpr-ref args args-len argnum))
1441             (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions?   
1442        (if thing 
1443          (%apply-lexpr (cdr thing) args)
1444          (%apply-lexpr (cddr stuff) args))))))
1445
1446
1447;;; Assumes the two methods have the same number of specializers and
1448;;; that each specializer of each method is in the corresponding
1449;;; element of cpls (e.g. cpls is a list of the cpl's for the classes
1450;;; of args for which both method1 & method2 are applicable.
1451(defun %method< (method1 method2 cpls)
1452  (let ((s1s (%method.specializers method1))
1453        (s2s (%method.specializers method2))
1454        s1 s2 cpl)
1455    (loop
1456      (if (null s1s)
1457        (return (method-qualifiers< method1 method2)))
1458      (setq s1 (%pop s1s)
1459            s2 (%pop s2s)
1460            cpl (%pop cpls))
1461      (cond ((typep s1 'eql-specializer) 
1462             (unless (eq s1 s2)
1463               (return t)))
1464            ((typep s2 'eql-specializer) (return nil))
1465            ((eq s1 s2))
1466            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1467
1468(defun %simple-method< (method1 method2 cpl)
1469  (let ((s1 (%car (%method.specializers method1)))
1470        (s2 (%car (%method.specializers method2))))
1471    (cond ((typep s1 'eql-specializer) 
1472           (if (eq s1 s2)
1473             (method-qualifiers< method1 method2)
1474             t))
1475          ((typep s2 'eql-specializer) nil)
1476          ((eq s1 s2) (method-qualifiers< method1 method2))
1477          (t (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))
1478
1479; Sort methods with argument-precedence-order
1480(defun %hairy-method< (method1 method2 cpls apo)
1481  (let ((s1s (%method.specializers method1))
1482        (s2s (%method.specializers method2))
1483        s1 s2 cpl index)
1484    (loop
1485      (if (null apo)
1486        (return (method-qualifiers< method1 method2)))
1487      (setq index (pop apo))
1488      (setq s1 (nth index s1s)
1489            s2 (nth index s2s)
1490            cpl (nth index cpls))
1491      (cond ((typep s1 'eql-specializer) 
1492             (unless (eq s1 s2)
1493               (return t)))
1494            ((typep s2 'eql-specializer) (return nil))
1495            ((eq s1 s2))
1496            (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl))))))))
1497
1498; This can matter if the user removes & reinstalls methods between
1499; invoking a generic-function and doing call-next-method with args.
1500; Hence, we need a truly canonical sort order for the methods
1501; (or a smarter comparison than EQUAL in %%cnm-with-args-check-methods).
1502(defun method-qualifiers< (method1 method2)
1503  (labels ((qualifier-list< (ql1 ql2 &aux q1 q2)
1504              (cond ((null ql1) (not (null ql2)))
1505                    ((null ql2) nil)
1506                    ((eq (setq q1 (car ql1)) (setq q2 (car ql2)))
1507                     (qualifier-list< (cdr ql1) (cdr ql2)))
1508                    ((string-lessp q1 q2) t)
1509                    ; This isn't entirely correct.
1510                    ; two qualifiers with the same pname in different packages
1511                    ; are not comparable here.
1512                    ; Unfortunately, users can change package names, hence,
1513                    ; comparing the package names doesn't work either.
1514                    (t nil))))
1515    (qualifier-list< (%method.qualifiers method1) (%method.qualifiers method2))))
1516       
1517(defun sort-methods (methods cpls &optional apo)
1518  (cond ((null cpls) methods)
1519        ((null (%cdr cpls))
1520         (setq cpls (%car cpls))
1521         (flet ((simple-sort-fn (m1 m2)
1522                  (%simple-method< m1 m2 cpls)))
1523           (declare (dynamic-extent #'simple-sort-fn))
1524           (%sort-list-no-key methods #'simple-sort-fn)))
1525        ((null apo)                     ; no unusual argument-precedence-order
1526         (flet ((sort-fn (m1 m2) 
1527                  (%method< m1 m2 cpls)))
1528           (declare (dynamic-extent #'sort-fn))
1529           (%sort-list-no-key methods #'sort-fn)))
1530        (t                              ; I guess some people are just plain rude
1531         (flet ((hairy-sort-fn (m1 m2)
1532                  (%hairy-method< m1 m2 cpls apo)))
1533           (declare (dynamic-extent #'hairy-sort-fn))
1534           (%sort-list-no-key methods #'hairy-sort-fn)))))
1535
1536(defun nremove-uncallable-next-methods (methods)
1537  (do ((m methods (%cdr m))
1538       mbits)
1539      ((null m))
1540    (setq mbits (lfun-bits (%method.function (%car m))))
1541    (unless (logbitp $lfbits-nextmeth-bit mbits)
1542      (setf (%cdr m) nil)
1543      (return)))
1544  methods)
1545
1546
1547(defun cpl-index (superclass cpl)
1548  ;; This will be table lookup later.  Also we'll prelookup the tables
1549  ;; in compute-1st-arg-combined-methods above.
1550  (locally (declare (optimize (speed 3)(safety 0)))
1551    (do ((i 0 (%i+ i 1))
1552         (cpl cpl (%cdr cpl)))
1553        ((null cpl) nil)
1554      (if (eq superclass (%car cpl))
1555        (return i)))))
1556
1557(defun cpl-memq (superclass cpl)
1558  (locally (declare (optimize (speed 3)(safety 0)))
1559    (do ((cpl cpl (%cdr cpl)))
1560        ((null cpl) nil)
1561      (if (eq superclass (%car cpl))
1562        (return cpl)))))
1563
1564;;; Combined method interpretation
1565
1566
1567;;; magic is a list of (cnm-cm (methods) . args) cnm-cm is the
1568;;; argument checker for call-next-method-with-args or nil could make
1569;;; it be a cons as a flag that magic has been heap consed - done
1570;;; could also switch car and cadr if we do &lexpr business then if
1571;;; cddr is lexpr-p (aka (not listp)) thats the clue also would need
1572;;; to do lexpr-apply or apply depending on the state.
1573
1574
1575(defun %%standard-combined-method-dcode (methods args)
1576  ;; combined-methods as made by make-combined-method are in methods
1577  ;; args are as put there by the caller of the gf.
1578  (let* ((car-meths (car methods))
1579         (cell-2 (cons methods args))
1580         (magic (cons nil cell-2)))
1581    ;; i.e. magic is nil methods . args
1582    (declare (dynamic-extent magic)
1583             (dynamic-extent cell-2))   
1584    (if (listp car-meths)
1585      (%%before-and-after-combined-method-dcode magic)
1586      (progn       
1587        (if (not (cdr methods))
1588          (%rplaca (cdr magic) car-meths)
1589          (%rplaca (cdr magic) (cdr methods)))
1590        ; so maybe its a combined-method ?? - no
1591        (apply-with-method-context magic (%method.function car-meths) args)))))
1592
1593;;; args is list, old-args may be lexpr
1594(defun cmp-args-old-args (args old-args numreq)
1595  (declare (optimize (speed 3)(safety 0)))
1596  (if (listp old-args)
1597    (do ((newl args (cdr newl))
1598         (oldl old-args (cdr oldl))
1599         (i 0 (1+ i)))
1600        ((eql i numreq) t)
1601      (when (neq (car newl)(car oldl))(return nil)))
1602    (let ((len (%lexpr-count old-args)))
1603      (do ((newl args (cdr newl))
1604           (i 0 (1+ i)))
1605          ((eql i numreq) t)
1606        (when (neq (car newl)(%lexpr-ref old-args len i))(return nil))))))       
1607
1608
1609; called from call-next-method-with-args with magic supplied and 1st time around with not
1610(defun %%cnm-with-args-combined-method-dcode (thing args &optional magic) ; was &rest args
1611  ;(declare (dynamic-extent args))
1612  ; now thing is vector of gf orig methods, arg for key or initarg check, key or initarg fnction
1613  ; and our job is to do all the arg checking
1614  (let ()
1615    (when magic
1616      (flet ((do-it (thing args)
1617               (let* ((args-len (length args))
1618                      (gf (svref thing 0))  ; could get this from a method
1619                      (numreq (ldb $lfbits-numreq (inner-lfun-bits gf)))
1620                      (next-methods (cadr magic)))
1621                 ;(when (null self)(error "Next method with args context error"))
1622                 (when (neq 0 numreq)
1623                   ; oh screw it - old-args may be lexpr too
1624                   (let ((old-args (cddr magic)))
1625                     (when (< args-len numreq) (signal-program-error "Too few args to ~S" gf))
1626                     (when (null (cmp-args-old-args args old-args numreq))
1627                       ; required args not eq - usually true, we expect
1628                       (let ((new-methods (%compute-applicable-methods* gf args))
1629                             (old-methods (svref thing 1)))
1630                         (when (not (equal new-methods old-methods))
1631                           (error '"Applicable-methods changed in call-next-method.~%~
1632                                    Should be: ~s~%Was: ~s~%Next-methods: ~s"
1633                                  old-methods new-methods next-methods))))))
1634                 (let ((key-or-init-fn (svref thing 3)))
1635                   (when key-or-init-fn 
1636                     ; was apply
1637                     (funcall key-or-init-fn (svref thing 2) args))))))
1638        (if (listp args)
1639          (do-it thing args)
1640          (with-list-from-lexpr (args-list args)
1641            (do-it thing args-list)))))
1642    ; ok done checking - lets do it
1643    (let* ((methods (if magic (cadr magic)(svref thing 4)))  ;<< was 5 this is nil unless cnm with args
1644           ; was if magic
1645           (car-meths (car methods))
1646           (cell-2 (cons methods args))
1647           (magic (cons thing cell-2)))
1648      (declare (dynamic-extent magic cell-2))
1649      ; i.e. magic is thing methods . args
1650      ;(%rplaca magic thing)
1651      ;(setf (cadr magic) methods)
1652      ;(%rplaca (cdr magic) methods)
1653      ;(setf (cddr magic) args)
1654      ;(%rplacd (cdr magic) args)
1655      (if (listp car-meths)
1656        (progn
1657          (%%before-and-after-combined-method-dcode magic))
1658        (progn       
1659          (if (not (cdr methods))
1660            (%rplaca (cdr magic) car-meths)
1661            (%rplaca (cdr magic) (cdr methods)))
1662          ; so maybe its a combined-method ?? - no
1663          (apply-with-method-context magic (%method.function car-meths) args))))))
1664
1665
1666
1667;;; here if car of methods is listp. methods = (befores afters . primaries)
1668(defun %%before-and-after-combined-method-dcode (magic) 
1669  (declare (list magic))
1670  (let* ((methods (cadr magic))         
1671         (befores (car methods))         
1672         (cdr-meths (cdr methods))
1673         (primaries (cdr cdr-meths))
1674         (afters (car cdr-meths))
1675         (args (cddr magic)))
1676    (declare (list befores afters primaries))
1677    (when befores 
1678      (dolist (method befores)
1679        (rplaca (cdr magic) method)
1680        (apply-with-method-context magic (%method.function method) args)))
1681    (let* ((cdr (cdr primaries))
1682           (method-function (%method.function (car primaries))))   ; guaranteed non nil?
1683      (rplaca (cdr magic) (if (null cdr)(car primaries) cdr))     
1684      (if (null afters)
1685        (apply-with-method-context magic method-function args)  ; tail call if possible
1686        (multiple-value-prog1
1687          (apply-with-method-context magic method-function args)       
1688          (dolist (method afters)
1689            (rplaca (cdr magic) method)
1690            (apply-with-method-context magic (%method.function method) args)))))))
1691
1692
1693; This is called by the compiler expansion of next-method-p
1694; I think there's a bug going around... LAP fever! I'm immune
1695(defun %next-method-p (magic)
1696  (let ((methods (%cadr magic)))
1697    (consp methods)))
1698
1699
1700(defun %call-next-method (magic &rest args) ; if args supplied they are new ones
1701  (declare (dynamic-extent args)) 
1702  (if args
1703    (apply #'%call-next-method-with-args magic args)
1704    (let* ((next-methods (%cadr magic))) ; don't get this closed magic stuff     
1705      (if (not (consp next-methods))
1706        ( %no-next-method  magic)           
1707        (let ((args (%cddr magic)))  ; get original args
1708          ;The unwind-protect is needed in case some hacker in his/her wisdom decides to:
1709          ; (defmethod foo (x) (catch 'foo (call-next-method)) (call-next-method))
1710          ; where the next-method throws to 'foo.
1711          ; The alternative is to make a new magic var with args
1712          ; actually not that fancy (call-next-method)(call-next-method) is same problem
1713          (let ()
1714            (unwind-protect
1715              (if (listp (car next-methods))
1716                ( %%before-and-after-combined-method-dcode magic)
1717                (let ((cdr (cdr next-methods)))
1718                  (rplaca (cdr magic)(if (not cdr)(car next-methods) cdr))
1719                  (let ((method-function (%method.function (car next-methods))))
1720                    (apply-with-method-context magic method-function args))))
1721              (rplaca (cdr magic) next-methods))))))))
1722
1723;; Note: we need to change the compiler to call this when it can prove that
1724;; call-next-method cannot be called a second time. I believe thats done.
1725
1726
1727(defun %tail-call-next-method (magic)
1728  (let* ((next-methods (%cadr magic))  ; or make it car
1729         (args (%cddr magic))) ; get original args       
1730    (if (not (consp next-methods)) ; or consp?
1731      ( %no-next-method magic)
1732      (if (listp (car next-methods))
1733        ( %%before-and-after-combined-method-dcode magic)
1734        (let ((cdr (cdr next-methods)))
1735          (rplaca (cdr magic) (if (not cdr)(car next-methods) cdr))
1736          (apply-with-method-context magic (%method.function (car next-methods)) args))))))
1737
1738; may be simpler to blow another cell so magic looks like
1739; (cnm-cm/nil next-methods . args) - done
1740; and also use first cell to mean heap-consed if itsa cons
1741
1742(defun %call-next-method-with-args (magic &rest args)
1743  (declare (dynamic-extent args))
1744  (if (null args)
1745    (%call-next-method magic)
1746    (let* ((methods (%cadr magic)))
1747      (if (not (consp methods))
1748        (%no-next-method  magic)
1749        (let* ((cnm-cm (car magic)))
1750          ; a combined method
1751          (when (consp cnm-cm)(setq cnm-cm (car cnm-cm)))
1752          ; could just put the vector in car magic & no self needed in vector?
1753          (let ((the-vect cnm-cm)) ;  <<
1754            (funcall #'%%cnm-with-args-combined-method-dcode ;(%combined-method-dcode cnm-cm)
1755                     the-vect
1756                     args
1757                     magic)))))))
1758
1759
1760
1761; called from x%%call-next-method-with-args - its the key-or-init-fn
1762(defun %%cnm-with-args-check-initargs (init-cell args)
1763  ; here we forget the lexpr idea because it wants to cdr
1764  ;(declare (dynamic-extent args))
1765  (let* ((rest (cdr args))
1766         (first-arg (car args)))
1767    (declare (list rest))
1768    (let* ((initargs rest)
1769           (init-function (car init-cell))
1770           (instance (cond ((eq init-function #'update-instance-for-different-class)
1771                            (setq initargs (cdr rest))
1772                            (car rest))
1773                           ((eq init-function #'shared-initialize)
1774                            (setq initargs (cdr rest))
1775                            first-arg)
1776                           ((eq init-function #'update-instance-for-redefined-class)
1777                            (setq initargs (%cdddr rest))
1778                            first-arg)
1779                           (t first-arg)))
1780           (class (class-of instance))
1781           bad-initarg)
1782      (dolist (functions (cdr init-cell)
1783                         (error "Bad initarg: ~s to call-next-method for ~s~%on ~s"
1784                                bad-initarg instance (car init-cell)))
1785        (multiple-value-bind 
1786          (errorp bad-key)
1787          (if (eq (car functions) #'initialize-instance)
1788            (apply #'check-initargs instance class initargs nil
1789                   #'initialize-instance #'allocate-instance #'shared-initialize
1790                   nil)
1791            (apply #'check-initargs instance class initargs nil functions))
1792          (if errorp
1793            (unless bad-initarg (setq bad-initarg bad-key))
1794            (return t)))))))
1795
1796
1797
1798(defun %no-next-method (magic)
1799  (let* ((method (%cadr magic)))
1800    (if (consp method) (setq method (car method)))
1801    (unless (typep method 'standard-method)
1802      (error "call-next-method called outside of generic-function dispatch context.~@
1803              Usually indicates an error in a define-method-combination form."))
1804    (let ((args (cddr magic))
1805          (gf (%method.gf method)))
1806      (if (listp args)
1807        (apply #'no-next-method gf method args)
1808        (%apply-lexpr #'no-next-method gf method args)))))
1809
1810
1811
1812
1813;;; This makes a consed version of the magic first arg to a method.
1814;;; Called when someone closes over the magic arg. (i.e. does (george
1815;;; #'call-next-method))
1816
1817(defun %cons-magic-next-method-arg (magic)
1818  ; car is a cons as a flag that its already heap-consed! - else cnm-cm or nil
1819  (if (consp (car magic))
1820    magic
1821    (list* (list (car magic))
1822           (if (consp (%cadr magic))
1823             (copy-list (%cadr magic)) ; is this copy needed - probably not
1824             (cadr magic))
1825           (let ((args (%cddr magic)))
1826             (if (listp args)
1827               (copy-list args)
1828               (let* ((len (%lexpr-count args))
1829                      (l (make-list len)))
1830                 (do ((i 0 (1+ i))
1831                      (list l (cdr list)))
1832                     ((null list))
1833                   (%rplaca list (%lexpr-ref args len i)))
1834                 l))))))
1835
1836
1837; Support CALL-METHOD in DEFINE-METHOD-COMBINATION
1838(defun %%call-method* (method next-methods args)
1839  (let* ((method-function (%method.function method))
1840         (bits (lfun-bits method-function)))
1841    (declare (fixnum bits))
1842    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1843                  (logbitp  $lfbits-method-bit bits)))
1844      (if (listp args)
1845        (apply method-function args)
1846        (%apply-lexpr method-function args))
1847      (let* ((cell-2 (cons next-methods args))
1848             (magic (cons nil cell-2)))
1849        (declare (dynamic-extent magic)
1850                 (dynamic-extent cell-2)) 
1851        (if (null next-methods)
1852          (%rplaca (cdr magic) method))
1853        (apply-with-method-context magic method-function args)))))
1854
1855; Error checking version for user's to call
1856(defun %call-method* (method next-methods args)
1857  (let* ((method-function (%method.function method))
1858         (bits (lfun-bits method-function)))
1859    (declare (fixnum bits))
1860    (if (not (and (logbitp $lfbits-nextmeth-bit  bits)
1861                  (logbitp  $lfbits-method-bit bits)))
1862      (progn
1863        (require-type method 'standard-method)
1864        (if (listp args)
1865          (apply method-function args)
1866          (%apply-lexpr method-function args)))
1867      (progn
1868        (do* ((list next-methods (cdr list)))
1869             ((null list))
1870          (when (not (listp list))
1871            (%err-disp $XIMPROPERLIST next-methods))
1872          (when (not (standard-method-p (car list)))
1873            (report-bad-arg (car list) 'standard-method))) 
1874        (let* ((cell-2 (cons next-methods args))
1875               (magic (cons nil cell-2)))
1876          (declare (dynamic-extent magic)
1877                   (dynamic-extent cell-2)) 
1878          (if (null next-methods)
1879            (%rplaca (cdr magic) method))
1880          (apply-with-method-context magic method-function args))))))
1881
1882
1883
Note: See TracBrowser for help on using the repository browser.