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

Last change on this file since 14153 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

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