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

Last change on this file since 15109 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

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