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

Last change on this file since 6 was 6, checked in by gb, 18 years ago

Initial revision

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