source: branches/qres/ccl/level-1/l1-dcode.lisp @ 15278

Last change on this file since 15278 was 14056, checked in by gz, 9 years ago

r13980 from trunk (defmethod memory leak)

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