source: trunk/abcl/src/org/armedbear/lisp/clos.lisp @ 13788

Last change on this file since 13788 was 13788, checked in by rschlatte, 10 years ago

move error checking into canonicalize-direct-superclasses

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 149.7 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; Copyright (C) 2010 Mark Evenson
5;;; $Id: clos.lisp 13788 2012-01-17 20:15:55Z rschlatte $
6;;;
7;;; This program is free software; you can redistribute it and/or
8;;; modify it under the terms of the GNU General Public License
9;;; as published by the Free Software Foundation; either version 2
10;;; of the License, or (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
20;;;
21;;; As a special exception, the copyright holders of this library give you
22;;; permission to link this library with independent modules to produce an
23;;; executable, regardless of the license terms of these independent
24;;; modules, and to copy and distribute the resulting executable under
25;;; terms of your choice, provided that you also meet, for each linked
26;;; independent module, the terms and conditions of the license of that
27;;; module.  An independent module is a module which is not derived from
28;;; or based on this library.  If you modify this library, you may extend
29;;; this exception to your version of the library, but you are not
30;;; obligated to do so.  If you do not wish to do so, delete this
31;;; exception statement from your version.
32
33;;; Originally based on Closette.
34
35;;; Closette Version 1.0 (February 10, 1991)
36;;;
37;;; Copyright (c) 1990, 1991 Xerox Corporation.
38;;; All rights reserved.
39;;;
40;;; Use and copying of this software and preparation of derivative works
41;;; based upon this software are permitted.  Any distribution of this
42;;; software or derivative works must comply with all applicable United
43;;; States export control laws.
44;;;
45;;; This software is made available AS IS, and Xerox Corporation makes no
46;;; warranty about the software, its performance or its conformity to any
47;;; specification.
48;;;
49;;; Closette is an implementation of a subset of CLOS with a metaobject
50;;; protocol as described in "The Art of The Metaobject Protocol",
51;;; MIT Press, 1991.
52
53(in-package #:mop)
54
55;;
56;;
57;;
58;; In order to bootstrap CLOS, first implement the required API as
59;; normal functions which only apply to the "root" metaclass
60;; STANDARD-CLASS.
61;;
62;; After putting the normal functions in place, the building blocks
63;; are in place to gradually swap the normal functions with
64;; generic functions and methods.
65;;
66;; Some functionality implemented in the temporary regular functions
67;; needs to be available later as a method definition to be dispatched
68;; to for the STANDARD-CLASS case.  To prevent repeated code, the
69;; functions are implemented in functions by the same name as the
70;; API functions, but with the STD- prefix.
71;;
72;; When hacking this file, note that some important parts are implemented
73;; in the Java world. These Java bits can be found in the files
74;;
75;; * LispClass.java
76;; * SlotClass.java
77;; * StandardClass.java
78;; * BuiltInClass.java
79;; * StandardObject.java
80;; * StandardObjectFunctions.java
81;; * Layout.java
82;;
83;; In case of function names, those defined on the Java side can be
84;; recognized by their prefixed percent sign.
85;;
86;; The API functions need to be declaimed NOTINLINE explicitly, because
87;; that prevents inlining in the current FASL (which is allowed by the
88;; CLHS without the declaration); this is a hard requirement to in order
89;; to be able to swap the symbol's function slot with a generic function
90;; later on - with it actually being used.
91;;
92;;
93;;
94;; ### Note that the "declares all API functions as regular functions"
95;; isn't true when I write the above, but it's definitely the target.
96;;
97;;
98
99(export '(class-precedence-list class-slots
100          slot-definition-name))
101(defconstant +the-standard-class+ (find-class 'standard-class))
102(defconstant +the-structure-class+ (find-class 'structure-class))
103(defconstant +the-standard-object-class+ (find-class 'standard-object))
104(defconstant +the-standard-method-class+ (find-class 'standard-method))
105(defconstant +the-standard-reader-method-class+
106  (find-class 'standard-reader-method))
107(defconstant +the-standard-generic-function-class+
108  (find-class 'standard-generic-function))
109(defconstant +the-T-class+ (find-class 'T))
110(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
111(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
112(defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition))
113
114;; Don't use DEFVAR, because that disallows loading clos.lisp
115;; after compiling it: the binding won't get assigned to T anymore
116(defparameter *clos-booting* t)
117
118(defmacro define-class->%class-forwarder (name)
119  (let* (($name (if (consp name) (cadr name) name))
120         (%name (intern (concatenate 'string
121                                     "%"
122                                     (if (consp name)
123                                         (symbol-name 'set-) "")
124                                     (symbol-name $name))
125                        (symbol-package $name))))
126    `(progn
127       (declaim (notinline ,name))
128       (defun ,name (&rest args)
129         (apply #',%name args)))))
130
131;;
132;;  DEFINE PLACE HOLDER FUNCTIONS
133;;
134
135(define-class->%class-forwarder class-name)
136(define-class->%class-forwarder (setf class-name))
137(define-class->%class-forwarder class-slots)
138(define-class->%class-forwarder (setf class-slots))
139(define-class->%class-forwarder class-direct-slots)
140(define-class->%class-forwarder (setf class-direct-slots))
141(define-class->%class-forwarder class-layout)
142(define-class->%class-forwarder (setf class-layout))
143(define-class->%class-forwarder class-direct-superclasses)
144(define-class->%class-forwarder (setf class-direct-superclasses))
145(define-class->%class-forwarder class-direct-subclasses)
146(define-class->%class-forwarder (setf class-direct-subclasses))
147(define-class->%class-forwarder class-direct-methods)
148(define-class->%class-forwarder (setf class-direct-methods))
149(define-class->%class-forwarder class-precedence-list)
150(define-class->%class-forwarder (setf class-precedence-list))
151(define-class->%class-forwarder class-finalized-p)
152(define-class->%class-forwarder (setf class-finalized-p))
153(define-class->%class-forwarder class-default-initargs)
154(define-class->%class-forwarder (setf class-default-initargs))
155(define-class->%class-forwarder class-direct-default-initargs)
156(define-class->%class-forwarder (setf class-direct-default-initargs))
157
158(defun no-applicable-method (generic-function &rest args)
159  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
160         generic-function
161         args))
162
163(defun function-keywords (method)
164  (%function-keywords method))
165
166
167
168(defmacro push-on-end (value location)
169  `(setf ,location (nconc ,location (list ,value))))
170
171;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
172;;; which must be non-nil.
173
174(defun (setf getf*) (new-value plist key)
175  (block body
176    (do ((x plist (cddr x)))
177        ((null x))
178      (when (eq (car x) key)
179        (setf (car (cdr x)) new-value)
180        (return-from body new-value)))
181    (push-on-end key plist)
182    (push-on-end new-value plist)
183    new-value))
184
185(defun mapappend (fun &rest args)
186  (if (some #'null args)
187      ()
188      (append (apply fun (mapcar #'car args))
189              (apply #'mapappend fun (mapcar #'cdr args)))))
190
191(defun mapplist (fun x)
192  (if (null x)
193      ()
194      (cons (funcall fun (car x) (cadr x))
195            (mapplist fun (cddr x)))))
196
197(defsetf std-instance-layout %set-std-instance-layout)
198(defsetf standard-instance-access %set-standard-instance-access)
199
200(defun (setf find-class) (new-value symbol &optional errorp environment)
201  (declare (ignore errorp environment))
202  (%set-find-class symbol new-value))
203
204(defun canonicalize-direct-slots (direct-slots)
205  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
206
207(defun canonicalize-direct-slot (spec)
208  (if (symbolp spec)
209      `(list :name ',spec)
210      (let ((name (car spec))
211            (initfunction nil)
212            (initform nil)
213            (initargs ())
214            (type nil)
215            (allocation nil)
216            (documentation nil)
217            (readers ())
218            (writers ())
219            (other-options ())
220            (non-std-options ()))
221        (do ((olist (cdr spec) (cddr olist)))
222            ((null olist))
223          (case (car olist)
224            (:initform
225             (when initform
226               (error 'program-error
227                      "duplicate slot option :INITFORM for slot named ~S"
228                      name))
229             (setq initfunction t)
230             (setq initform (cadr olist)))
231            (:initarg
232             (push-on-end (cadr olist) initargs))
233            (:allocation
234             (when allocation
235               (error 'program-error
236                      "duplicate slot option :ALLOCATION for slot named ~S"
237                      name))
238             (setf allocation (cadr olist))
239             (push-on-end (car olist) other-options)
240             (push-on-end (cadr olist) other-options))
241            (:type
242             (when type
243               (error 'program-error
244                      "duplicate slot option :TYPE for slot named ~S"
245                      name))
246             (setf type (cadr olist))) ;; FIXME type is ignored
247            (:documentation
248             (when documentation
249               (error 'program-error
250                      "duplicate slot option :DOCUMENTATION for slot named ~S"
251                      name))
252             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
253            (:reader
254             (maybe-note-name-defined (cadr olist))
255             (push-on-end (cadr olist) readers))
256            (:writer
257             (maybe-note-name-defined (cadr olist))
258             (push-on-end (cadr olist) writers))
259            (:accessor
260             (maybe-note-name-defined (cadr olist))
261             (push-on-end (cadr olist) readers)
262             (push-on-end `(setf ,(cadr olist)) writers))
263            (t
264             (push-on-end `(quote ,(car olist)) non-std-options)
265             (push-on-end `(quote ,(cadr olist)) non-std-options))))
266        `(list
267          :name ',name
268          ,@(when initfunction
269              `(:initform ',initform
270                :initfunction ,(if (eq allocation :class)
271                                   ;; CLHS specifies the initform for a
272                                   ;; class allocation level slot needs
273                                   ;; to be evaluated in the dynamic
274                                   ;; extent of the DEFCLASS form
275                                   (let ((var (gensym)))
276                                     `(let ((,var ,initform))
277                                        (lambda () ,var)))
278                                 `(lambda () ,initform))))
279          ,@(when initargs `(:initargs ',initargs))
280          ,@(when readers `(:readers ',readers))
281          ,@(when writers `(:writers ',writers))
282          ,@other-options
283    ,@non-std-options))))
284
285(defun maybe-note-name-defined (name)
286  (when (fboundp 'note-name-defined)
287    (note-name-defined name)))
288
289(defun canonicalize-direct-superclasses (direct-superclasses)
290  (let ((classes '()))
291    (dolist (class-specifier direct-superclasses)
292      (let ((class (if (classp class-specifier)
293                       class-specifier
294                       (find-class class-specifier nil))))
295        (unless class
296          (setf class (make-forward-referenced-class class-specifier)))
297        (when (and (typep class 'built-in-class)
298                   (not (member class *extensible-built-in-classes*)))
299          (error "Attempt to define a subclass of built-in-class ~S."
300                 class-specifier))
301        (push class classes)))
302    (nreverse classes)))
303
304(defun canonicalize-defclass-options (options)
305  (mapappend #'canonicalize-defclass-option options))
306
307(defun canonicalize-defclass-option (option)
308  (case (car option)
309    (:metaclass
310     (list ':metaclass
311           `(find-class ',(cadr option))))
312    (:default-initargs
313     (list
314      ':direct-default-initargs
315      `(list ,@(mapappend
316                #'(lambda (x) x)
317                (mapplist
318                 #'(lambda (key value)
319                    `(',key ,(make-initfunction value)))
320                 (cdr option))))))
321    ((:documentation :report)
322     (list (car option) `',(cadr option)))
323    (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
324
325(defun make-initfunction (initform)
326  `(function (lambda () ,initform)))
327
328(defun slot-definition-allocation (slot-definition)
329  (%slot-definition-allocation slot-definition))
330
331(declaim (notinline (setf slot-definition-allocation)))
332(defun (setf slot-definition-allocation) (value slot-definition)
333  (set-slot-definition-allocation slot-definition value))
334
335(defun slot-definition-initargs (slot-definition)
336  (%slot-definition-initargs slot-definition))
337
338(declaim (notinline (setf slot-definition-initargs)))
339(defun (setf slot-definition-initargs) (value slot-definition)
340  (set-slot-definition-initargs slot-definition value))
341
342(defun slot-definition-initform (slot-definition)
343  (%slot-definition-initform slot-definition))
344
345(declaim (notinline (setf slot-definition-initform)))
346(defun (setf slot-definition-initform) (value slot-definition)
347  (set-slot-definition-initform slot-definition value))
348
349(defun slot-definition-initfunction (slot-definition)
350  (%slot-definition-initfunction slot-definition))
351
352(declaim (notinline (setf slot-definition-initfunction)))
353(defun (setf slot-definition-initfunction) (value slot-definition)
354  (set-slot-definition-initfunction slot-definition value))
355
356(defun slot-definition-name (slot-definition)
357  (%slot-definition-name slot-definition))
358
359(declaim (notinline (setf slot-definition-name)))
360(defun (setf slot-definition-name) (value slot-definition)
361  (set-slot-definition-name slot-definition value))
362
363(defun slot-definition-readers (slot-definition)
364  (%slot-definition-readers slot-definition))
365
366(declaim (notinline (setf slot-definition-readers)))
367(defun (setf slot-definition-readers) (value slot-definition)
368  (set-slot-definition-readers slot-definition value))
369
370(defun slot-definition-writers (slot-definition)
371  (%slot-definition-writers slot-definition))
372
373(declaim (notinline (setf slot-definition-writers)))
374(defun (setf slot-definition-writers) (value slot-definition)
375  (set-slot-definition-writers slot-definition value))
376
377(defun slot-definition-allocation-class (slot-definition)
378  (%slot-definition-allocation-class slot-definition))
379
380(declaim (notinline (setf slot-definition-allocation-class)))
381(defun (setf slot-definition-allocation-class) (value slot-definition)
382  (set-slot-definition-allocation-class slot-definition value))
383
384(defun slot-definition-location (slot-definition)
385  (%slot-definition-location slot-definition))
386
387(declaim (notinline (setf slot-definition-location-class)))
388(defun (setf slot-definition-location) (value slot-definition)
389  (set-slot-definition-location slot-definition value))
390
391(defun init-slot-definition (slot &key name
392                             (initargs ())
393                             (initform nil)
394                             (initfunction nil)
395                             (readers ())
396                             (writers ())
397                             (allocation :instance)
398                             (allocation-class nil))
399  (setf (slot-definition-name slot) name)
400  (setf (slot-definition-initargs slot) initargs)
401  (setf (slot-definition-initform slot) initform)
402  (setf (slot-definition-initfunction slot) initfunction)
403  (setf (slot-definition-readers slot) readers)
404  (setf (slot-definition-writers slot) writers)
405  (setf (slot-definition-allocation slot) allocation)
406  (setf (slot-definition-allocation-class slot) allocation-class)
407  slot)
408
409(defun make-direct-slot-definition (class &rest args)
410  (let ((slot-class (direct-slot-definition-class class)))
411    (if (eq slot-class +the-standard-direct-slot-definition-class+)
412  (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
413    (apply #'init-slot-definition slot :allocation-class class args)
414    slot)
415  (progn
416    (let ((slot (apply #'make-instance slot-class :allocation-class class
417           args)))
418      slot)))))
419
420(defun make-effective-slot-definition (class &rest args)
421  (let ((slot-class (effective-slot-definition-class class)))
422    (if (eq slot-class +the-standard-effective-slot-definition-class+)
423  (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
424    (apply #'init-slot-definition slot args)
425    slot)
426  (progn
427    (let ((slot (apply #'make-instance slot-class args)))
428      slot)))))
429
430;;; finalize-inheritance
431
432(defun std-compute-class-default-initargs (class)
433  (mapcan #'(lambda (c)
434              (copy-list
435               (class-direct-default-initargs c)))
436          (class-precedence-list class)))
437
438(defun std-finalize-inheritance (class)
439  ;; In case the class is already finalized, return
440  ;; immediately, as per AMOP.
441  (when (class-finalized-p class)
442    (return-from std-finalize-inheritance))
443  (setf (class-precedence-list class)
444   (funcall (if (eq (class-of class) +the-standard-class+)
445                #'std-compute-class-precedence-list
446                #'compute-class-precedence-list)
447            class))
448  (setf (class-slots class)
449                   (funcall (if (eq (class-of class) +the-standard-class+)
450                                #'std-compute-slots
451                     #'compute-slots) class))
452  (let ((old-layout (class-layout class))
453        (length 0)
454        (instance-slots '())
455        (shared-slots '()))
456    (dolist (slot (class-slots class))
457      (case (slot-definition-allocation slot)
458        (:instance
459         (setf (slot-definition-location slot) length)
460         (incf length)
461         (push (slot-definition-name slot) instance-slots))
462        (:class
463         (unless (slot-definition-location slot)
464           (let ((allocation-class (slot-definition-allocation-class slot)))
465             (setf (slot-definition-location slot)
466       (if (eq allocation-class class)
467           (cons (slot-definition-name slot) +slot-unbound+)
468           (slot-location allocation-class (slot-definition-name slot))))))
469         (push (slot-definition-location slot) shared-slots))))
470    (when old-layout
471      ;; Redefined class: initialize added shared slots.
472      (dolist (location shared-slots)
473        (let* ((slot-name (car location))
474               (old-location (layout-slot-location old-layout slot-name)))
475          (unless old-location
476            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
477                   (initfunction (slot-definition-initfunction slot-definition)))
478              (when initfunction
479                (setf (cdr location) (funcall initfunction))))))))
480    (setf (class-layout class)
481          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
482  (setf (class-default-initargs class)
483        (std-compute-class-default-initargs class))
484  (setf (class-finalized-p class) t))
485
486(declaim (notinline finalize-inheritance))
487(defun finalize-inheritance (class)
488  (std-finalize-inheritance class))
489
490
491;;; Class precedence lists
492
493(defun std-compute-class-precedence-list (class)
494  (let ((classes-to-order (collect-superclasses* class)))
495    (dolist (super classes-to-order)
496      (when (typep super 'forward-referenced-class)
497        (error "Can't compute class precedence list for class ~A ~
498                which depends on forward referenced class ~A." class super)))
499    (topological-sort classes-to-order
500                      (remove-duplicates
501                       (mapappend #'local-precedence-ordering
502                                  classes-to-order))
503                      #'std-tie-breaker-rule)))
504
505;;; topological-sort implements the standard algorithm for topologically
506;;; sorting an arbitrary set of elements while honoring the precedence
507;;; constraints given by a set of (X,Y) pairs that indicate that element
508;;; X must precede element Y.  The tie-breaker procedure is called when it
509;;; is necessary to choose from multiple minimal elements; both a list of
510;;; candidates and the ordering so far are provided as arguments.
511
512(defun topological-sort (elements constraints tie-breaker)
513  (let ((remaining-constraints constraints)
514        (remaining-elements elements)
515        (result ()))
516    (loop
517      (let ((minimal-elements
518             (remove-if
519              #'(lambda (class)
520                 (member class remaining-constraints
521                         :key #'cadr))
522              remaining-elements)))
523        (when (null minimal-elements)
524          (if (null remaining-elements)
525              (return-from topological-sort result)
526              (error "Inconsistent precedence graph.")))
527        (let ((choice (if (null (cdr minimal-elements))
528                          (car minimal-elements)
529                          (funcall tie-breaker
530                                   minimal-elements
531                                   result))))
532          (setq result (append result (list choice)))
533          (setq remaining-elements
534                (remove choice remaining-elements))
535          (setq remaining-constraints
536                (remove choice
537                        remaining-constraints
538                        :test #'member)))))))
539
540;;; In the event of a tie while topologically sorting class precedence lists,
541;;; the CLOS Specification says to "select the one that has a direct subclass
542;;; rightmost in the class precedence list computed so far."  The same result
543;;; is obtained by inspecting the partially constructed class precedence list
544;;; from right to left, looking for the first minimal element to show up among
545;;; the direct superclasses of the class precedence list constituent.
546;;; (There's a lemma that shows that this rule yields a unique result.)
547
548(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
549  (dolist (cpl-constituent (reverse cpl-so-far))
550    (let* ((supers (class-direct-superclasses cpl-constituent))
551           (common (intersection minimal-elements supers)))
552      (when (not (null common))
553        (return-from std-tie-breaker-rule (car common))))))
554
555;;; This version of collect-superclasses* isn't bothered by cycles in the class
556;;; hierarchy, which sometimes happen by accident.
557
558(defun collect-superclasses* (class)
559  (labels ((all-superclasses-loop (seen superclasses)
560                                  (let ((to-be-processed
561                                         (set-difference superclasses seen)))
562                                    (if (null to-be-processed)
563                                        superclasses
564                                        (let ((class-to-process
565                                               (car to-be-processed)))
566                                          (all-superclasses-loop
567                                           (cons class-to-process seen)
568                                           (union (class-direct-superclasses
569                                                   class-to-process)
570                                                  superclasses)))))))
571          (all-superclasses-loop () (list class))))
572
573;;; The local precedence ordering of a class C with direct superclasses C_1,
574;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
575
576(defun local-precedence-ordering (class)
577  (mapcar #'list
578          (cons class
579                (butlast (class-direct-superclasses class)))
580          (class-direct-superclasses class)))
581
582;;; Slot inheritance
583
584(defun std-compute-slots (class)
585  (let* ((all-slots (mapappend #'class-direct-slots
586                               (class-precedence-list class)))
587         (all-names (remove-duplicates
588                     (mapcar 'slot-definition-name all-slots))))
589    (mapcar #'(lambda (name)
590               (funcall
591                (if (eq (class-of class) +the-standard-class+)
592                    #'std-compute-effective-slot-definition
593                    #'compute-effective-slot-definition)
594                class
595                name
596                (remove name all-slots
597                        :key 'slot-definition-name
598                        :test-not #'eq)))
599            all-names)))
600
601(defun std-compute-effective-slot-definition (class name direct-slots)
602  (let ((initer (find-if-not #'null direct-slots
603                             :key 'slot-definition-initfunction)))
604    (make-effective-slot-definition
605     class
606     :name name
607     :initform (if initer
608                   (slot-definition-initform initer)
609                   nil)
610     :initfunction (if initer
611                       (slot-definition-initfunction initer)
612                       nil)
613     :initargs (remove-duplicates
614                (mapappend 'slot-definition-initargs
615                           direct-slots))
616     :allocation (slot-definition-allocation (car direct-slots))
617     :allocation-class (when (slot-boundp (car direct-slots)
618            'sys::allocation-class)
619       ;;for some classes created in Java
620       ;;(e.g. SimpleCondition) this slot is unbound
621       (slot-definition-allocation-class (car direct-slots))))))
622
623;;; Standard instance slot access
624
625;;; N.B. The location of the effective-slots slots in the class metaobject for
626;;; standard-class must be determined without making any further slot
627;;; references.
628
629(defun find-slot-definition (class slot-name)
630  (dolist (slot (class-slots class) nil)
631    (when (eq slot-name (slot-definition-name slot))
632      (return slot))))
633
634(defun slot-location (class slot-name)
635  (let ((slot (find-slot-definition class slot-name)))
636    (if slot
637        (slot-definition-location slot)
638        nil)))
639
640(defun instance-slot-location (instance slot-name)
641  (let ((layout (std-instance-layout instance)))
642    (and layout (layout-slot-location layout slot-name))))
643
644(defun slot-value (object slot-name)
645  (if (or (eq (class-of (class-of object)) +the-standard-class+)
646    (eq (class-of (class-of object)) +the-structure-class+))
647      (std-slot-value object slot-name)
648      (slot-value-using-class (class-of object) object slot-name)))
649
650(defsetf std-slot-value set-std-slot-value)
651
652(defun %set-slot-value (object slot-name new-value)
653  (if (or (eq (class-of (class-of object)) +the-standard-class+)
654    (eq (class-of (class-of object)) +the-structure-class+))
655      (setf (std-slot-value object slot-name) new-value)
656      (set-slot-value-using-class new-value (class-of object)
657                                  object slot-name)))
658
659(defsetf slot-value %set-slot-value)
660
661(defun slot-boundp (object slot-name)
662  (if (eq (class-of (class-of object)) +the-standard-class+)
663      (std-slot-boundp object slot-name)
664      (slot-boundp-using-class (class-of object) object slot-name)))
665
666(defun std-slot-makunbound (instance slot-name)
667  (let ((location (instance-slot-location instance slot-name)))
668    (cond ((fixnump location)
669           (setf (standard-instance-access instance location) +slot-unbound+))
670          ((consp location)
671           (setf (cdr location) +slot-unbound+))
672          (t
673           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
674  instance)
675
676(defun slot-makunbound (object slot-name)
677  (if (eq (class-of (class-of object)) +the-standard-class+)
678      (std-slot-makunbound object slot-name)
679      (slot-makunbound-using-class (class-of object) object slot-name)))
680
681(defun std-slot-exists-p (instance slot-name)
682  (not (null (find slot-name (class-slots (class-of instance))
683                   :key 'slot-definition-name))))
684
685(defun slot-exists-p (object slot-name)
686  (if (eq (class-of (class-of object)) +the-standard-class+)
687      (std-slot-exists-p object slot-name)
688      (slot-exists-p-using-class (class-of object) object slot-name)))
689
690(defun instance-slot-p (slot)
691  (eq (slot-definition-allocation slot) :instance))
692
693(defun std-allocate-instance (class)
694  ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized
695  ;; and if not, tries to finalize it.
696  (unless (class-finalized-p class)
697    (std-finalize-inheritance class))
698  (sys::%std-allocate-instance class))
699
700(defun allocate-funcallable-instance (class)
701  (unless (class-finalized-p class)
702    (std-finalize-inheritance class))
703  (let ((instance (sys::%allocate-funcallable-instance class)))
704    (set-funcallable-instance-function
705     instance
706     #'(lambda (&rest args)
707         (declare (ignore args))
708         (error 'program-error "Called a funcallable-instance with unset function.")))
709    instance))
710
711(defun make-instance-standard-class (metaclass
712             &rest initargs
713                                     &key name direct-superclasses direct-slots
714                                     direct-default-initargs
715                                     documentation)
716  (declare (ignore metaclass))
717  (let ((class (std-allocate-instance +the-standard-class+)))
718    (check-initargs (list #'allocate-instance #'initialize-instance)
719                    (list* class initargs)
720                    class t initargs
721                    *make-instance-initargs-cache* 'make-instance)
722    (%set-class-name name class)
723    (%set-class-layout nil class)
724    (%set-class-direct-subclasses ()  class)
725    (%set-class-direct-methods ()  class)
726    (%set-class-documentation class documentation)
727    (std-after-initialization-for-classes class
728                                          :direct-superclasses direct-superclasses
729                                          :direct-slots direct-slots
730                                          :direct-default-initargs direct-default-initargs)
731    class))
732
733;(defun convert-to-direct-slot-definition (class canonicalized-slot)
734;  (apply #'make-instance
735;         (apply #'direct-slot-definition-class
736;                class canonicalized-slot)
737;         canonicalized-slot))
738
739(defun std-after-initialization-for-classes (class
740                                             &key direct-superclasses direct-slots
741                                             direct-default-initargs
742                                             &allow-other-keys)
743  (let ((supers (or direct-superclasses
744                    (list +the-standard-object-class+))))
745    (setf (class-direct-superclasses class) supers)
746    (dolist (superclass supers)
747      (pushnew class (class-direct-subclasses superclass))))
748  (let ((slots (mapcar #'(lambda (slot-properties)
749                          (apply #'make-direct-slot-definition class slot-properties))
750                       direct-slots)))
751    (setf (class-direct-slots class) slots)
752    (dolist (direct-slot slots)
753      (dolist (reader (slot-definition-readers direct-slot))
754        (add-reader-method class reader (slot-definition-name direct-slot)))
755      (dolist (writer (slot-definition-writers direct-slot))
756        (add-writer-method class writer (slot-definition-name direct-slot)))))
757  (setf (class-direct-default-initargs class) direct-default-initargs)
758  (maybe-finalize-class-subtree class)
759  (values))
760
761(defun canonical-slot-name (canonical-slot)
762  (getf canonical-slot :name))
763
764(defvar *extensible-built-in-classes*
765  (list (find-class 'sequence)
766        (find-class 'java:java-object)))
767
768(defvar *make-instance-initargs-cache*
769  (make-hash-table :test #'eq)
770  "Cached sets of allowable initargs, keyed on the class they belong to.")
771(defvar *reinitialize-instance-initargs-cache*
772  (make-hash-table :test #'eq)
773  "Cached sets of allowable initargs, keyed on the class they belong to.")
774
775(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
776  ;; Check for duplicate slots.
777  (remf all-keys :metaclass)
778  (let ((slots (getf all-keys :direct-slots)))
779    (dolist (s1 slots)
780      (let ((name1 (canonical-slot-name s1)))
781        (dolist (s2 (cdr (memq s1 slots)))
782          (when (eq name1 (canonical-slot-name s2))
783            (error 'program-error "Duplicate slot ~S" name1))))))
784  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
785  (let ((names ()))
786    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
787          (name (car initargs) (car initargs)))
788         ((null initargs))
789      (push name names))
790    (do* ((names names (cdr names))
791          (name (car names) (car names)))
792         ((null names))
793      (when (memq name (cdr names))
794        (error 'program-error
795               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
796               :format-arguments (list name)))))
797  (let ((old-class (find-class name nil)))
798    (cond ((and old-class (eq name (class-name old-class)))
799           (cond ((typep old-class 'built-in-class)
800                  (error "The symbol ~S names a built-in class." name))
801                 ((typep old-class 'forward-referenced-class)
802                  (let ((new-class (apply #'make-instance-standard-class
803                                          +the-standard-class+
804                                          :name name all-keys)))
805                    (%set-find-class name new-class)
806                    (setf (class-direct-subclasses new-class)
807                          (class-direct-subclasses old-class))
808                    (dolist (subclass (class-direct-subclasses old-class))
809                      (setf (class-direct-superclasses subclass)
810                            (substitute new-class old-class
811                                        (class-direct-superclasses subclass))))
812                    (maybe-finalize-class-subtree new-class)
813                    new-class))
814                 (t
815                  ;; We're redefining the class.
816                  (apply #'reinitialize-instance old-class all-keys)
817                  old-class)))
818          (t
819           (let ((class (apply (if metaclass
820                                   #'make-instance
821                                   #'make-instance-standard-class)
822                               (or metaclass
823                                   +the-standard-class+)
824                               :name name all-keys)))
825             (%set-find-class name class)
826             class)))))
827
828
829(defun maybe-finalize-class-subtree (class)
830  (when (every #'class-finalized-p (class-direct-superclasses class))
831    (finalize-inheritance class)
832    (dolist (subclass (class-direct-subclasses class))
833       (maybe-finalize-class-subtree subclass))))
834
835(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
836  (unless (>= (length form) 3)
837    (error 'program-error "Wrong number of arguments for DEFCLASS."))
838  (check-declaration-type name)
839  `(ensure-class ',name
840                 :direct-superclasses
841                 (canonicalize-direct-superclasses ',direct-superclasses)
842                 :direct-slots
843                 ,(canonicalize-direct-slots direct-slots)
844                 ,@(canonicalize-defclass-options options)))
845
846(defun expand-long-defcombin (name args)
847  (destructuring-bind (lambda-list method-groups &rest body) args
848    `(apply #'define-long-form-method-combination
849            ',name
850            ',lambda-list
851            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
852            ',body)))
853
854;;; The class method-combination and its subclasses are defined in
855;;; StandardClass.java, but we cannot use make-instance and slot-value
856;;; yet.
857
858(defun %make-long-method-combination (&key name documentation lambda-list
859                                       method-group-specs args-lambda-list
860                                       generic-function-symbol function
861                                       arguments declarations forms)
862  (let ((instance (std-allocate-instance (find-class 'long-method-combination))))
863    (setf (std-slot-value instance 'sys::name) name)
864    (setf (std-slot-value instance 'documentation) documentation)
865    (setf (std-slot-value instance 'sys::lambda-list) lambda-list)
866    (setf (std-slot-value instance 'method-group-specs) method-group-specs)
867    (setf (std-slot-value instance 'args-lambda-list) args-lambda-list)
868    (setf (std-slot-value instance 'generic-function-symbol)
869          generic-function-symbol)
870    (setf (std-slot-value instance 'function) function)
871    (setf (std-slot-value instance 'arguments) arguments)
872    (setf (std-slot-value instance 'declarations) declarations)
873    (setf (std-slot-value instance 'forms) forms)
874    instance))
875
876(defun method-combination-name (method-combination)
877  (check-type method-combination method-combination)
878  (std-slot-value method-combination 'sys::name))
879
880(defun method-combination-documentation (method-combination)
881  (check-type method-combination method-combination)
882  (std-slot-value method-combination 'documentation))
883
884(defun short-method-combination-operator (method-combination)
885  (check-type method-combination short-method-combination)
886  (std-slot-value method-combination 'operator))
887
888(defun short-method-combination-identity-with-one-argument (method-combination)
889  (check-type method-combination short-method-combination)
890  (std-slot-value method-combination 'identity-with-one-argument))
891
892(defun long-method-combination-lambda-list (method-combination)
893  (check-type method-combination long-method-combination)
894  (std-slot-value method-combination 'sys::lambda-list))
895
896(defun long-method-combination-method-group-specs (method-combination)
897  (check-type method-combination long-method-combination)
898  (std-slot-value method-combination 'method-group-specs))
899
900(defun long-method-combination-args-lambda-list (method-combination)
901  (check-type method-combination long-method-combination)
902  (std-slot-value method-combination 'args-lambda-list))
903
904(defun long-method-combination-generic-function-symbol (method-combination)
905  (check-type method-combination long-method-combination)
906  (std-slot-value method-combination 'generic-function-symbol))
907
908(defun long-method-combination-function (method-combination)
909  (check-type method-combination long-method-combination)
910  (std-slot-value method-combination 'function))
911
912(defun long-method-combination-arguments (method-combination)
913  (check-type method-combination long-method-combination)
914  (std-slot-value method-combination 'arguments))
915
916(defun long-method-combination-declarations (method-combination)
917  (check-type method-combination long-method-combination)
918  (std-slot-value method-combination 'declarations))
919
920(defun long-method-combination-forms (method-combination)
921  (check-type method-combination long-method-combination)
922  (std-slot-value method-combination 'forms))
923
924
925(defun expand-short-defcombin (whole)
926  (let* ((name (cadr whole))
927         (documentation
928          (getf (cddr whole) :documentation ""))
929         (identity-with-one-arg
930          (getf (cddr whole) :identity-with-one-argument nil))
931         (operator
932          (getf (cddr whole) :operator name)))
933    `(progn
934       ;; Class short-method-combination is defined in StandardClass.java.
935       (let ((instance (std-allocate-instance
936                        (find-class 'short-method-combination))))
937         (setf (std-slot-value instance 'sys::name) ',name)
938         (setf (std-slot-value instance 'documentation) ',documentation)
939         (setf (std-slot-value instance 'operator) ',operator)
940         (setf (std-slot-value instance 'identity-with-one-argument)
941               ',identity-with-one-arg)
942         (setf (get ',name 'method-combination-object) instance)
943         ',name))))
944
945(defmacro define-method-combination (&whole form name &rest args)
946  (if (and (cddr form)
947           (listp (caddr form)))
948      (expand-long-defcombin name args)
949      (expand-short-defcombin form)))
950
951(define-method-combination +      :identity-with-one-argument t)
952(define-method-combination and    :identity-with-one-argument t)
953(define-method-combination append :identity-with-one-argument nil)
954(define-method-combination list   :identity-with-one-argument nil)
955(define-method-combination max    :identity-with-one-argument t)
956(define-method-combination min    :identity-with-one-argument t)
957(define-method-combination nconc  :identity-with-one-argument t)
958(define-method-combination or     :identity-with-one-argument t)
959(define-method-combination progn  :identity-with-one-argument t)
960
961;;;
962;;; long form of define-method-combination (from Sacla and XCL)
963;;;
964(defun define-method-combination-type (name &rest initargs)
965    (setf (get name 'method-combination-object)
966          (apply '%make-long-method-combination initargs)))
967
968(defun method-group-p (selecter qualifiers)
969  ;; selecter::= qualifier-pattern | predicate
970  (etypecase selecter
971    (list (or (equal selecter qualifiers)
972              (let ((last (last selecter)))
973                (when (eq '* (cdr last))
974                  (let* ((prefix `(,@(butlast selecter) ,(car last)))
975                         (pos (mismatch prefix qualifiers)))
976                    (or (null pos) (= pos (length prefix))))))))
977    ((eql *) t)
978    (symbol (funcall (symbol-function selecter) qualifiers))))
979
980(defun check-variable-name (name)
981  (flet ((valid-variable-name-p (name)
982                                (and (symbolp name) (not (constantp name)))))
983    (assert (valid-variable-name-p name))))
984
985(defun canonicalize-method-group-spec (spec)
986  ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
987  ;; long-form-option::= :description description | :order order |
988  ;;                     :required required-p
989  ;; a canonicalized-spec is a simple plist.
990  (let* ((rest spec)
991         (name (prog2 (check-variable-name (car rest))
992                 (car rest)
993                 (setq rest (cdr rest))))
994         (option-names '(:description :order :required))
995         (selecters (let ((end (or (position-if #'(lambda (it)
996                                                   (member it option-names))
997                                                rest)
998                                   (length rest))))
999                      (prog1 (subseq rest 0 end)
1000                        (setq rest (subseq rest end)))))
1001         (description (getf rest :description ""))
1002         (order (getf rest :order :most-specific-first))
1003         (required-p (getf rest :required)))
1004    `(list :name ',name
1005           :predicate (lambda (qualifiers)
1006                        (loop for item in ',selecters
1007                          thereis (method-group-p item qualifiers)))
1008           :description ',description
1009           :order ',order
1010           :required ',required-p
1011           :*-selecter ,(equal selecters '(*)))))
1012
1013(defun extract-required-part (lambda-list)
1014  (flet ((skip (key lambda-list)
1015               (if (eq (first lambda-list) key)
1016                   (cddr lambda-list)
1017                   lambda-list)))
1018    (ldiff (skip '&environment (skip '&whole lambda-list))
1019           (member-if #'(lambda (it) (member it lambda-list-keywords))
1020                      lambda-list))))
1021
1022(defun extract-specified-part (key lambda-list)
1023  (case key
1024    ((&eval &whole)
1025     (list (second (member key lambda-list))))
1026    (t
1027     (let ((here (cdr (member key lambda-list))))
1028       (ldiff here
1029              (member-if #'(lambda (it) (member it lambda-list-keywords))
1030                         here))))))
1031
1032(defun extract-optional-part (lambda-list)
1033  (extract-specified-part '&optional lambda-list))
1034
1035(defun parse-define-method-combination-arguments-lambda-list (lambda-list)
1036  ;; Define-method-combination Arguments Lambda Lists
1037  ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
1038  (let ((required (extract-required-part lambda-list))
1039        (whole    (extract-specified-part '&whole    lambda-list))
1040        (optional (extract-specified-part '&optional lambda-list))
1041        (rest     (extract-specified-part '&rest     lambda-list))
1042        (keys     (extract-specified-part '&key      lambda-list))
1043        (aux      (extract-specified-part '&aux      lambda-list)))
1044    (values (first whole)
1045            required
1046            (mapcar #'(lambda (spec)
1047                       (if (consp spec)
1048                           `(,(first spec) ,(second spec) ,@(cddr spec))
1049                           `(,spec nil)))
1050                    optional)
1051            (first rest)
1052            (mapcar #'(lambda (spec)
1053                       (let ((key (if (consp spec) (car spec) spec))
1054                             (rest (when (consp spec) (rest spec))))
1055                         `(,(if (consp key) key `(,(make-keyword key) ,key))
1056                           ,(car rest)
1057                           ,@(cdr rest))))
1058                    keys)
1059            (mapcar #'(lambda (spec)
1060                       (if (consp spec)
1061                           `(,(first spec) ,(second spec))
1062                           `(,spec nil)))
1063                    aux))))
1064
1065(defmacro getk (plist key init-form)
1066  "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
1067  (let ((not-exist (gensym))
1068        (value (gensym)))
1069    `(let ((,value (getf ,plist ,key ,not-exist)))
1070       (if (eq ,not-exist ,value) ,init-form ,value))))
1071
1072(defun wrap-with-call-method-macro (gf args-var forms)
1073  `(macrolet
1074       ((call-method (method &optional next-method-list)
1075          `(funcall
1076            ,(cond
1077              ((listp method)
1078               (assert (eq (first method) 'make-method))
1079               ;; by generating an inline expansion we prevent allocation
1080               ;; of a method instance which will be discarded immediately
1081               ;; after reading the METHOD-FUNCTION slot
1082               (compute-method-function
1083                    `(lambda (&rest ,(gensym))
1084                       ;; the MAKE-METHOD body form gets evaluated in
1085                       ;; the null lexical environment augmented
1086                       ;; with a binding for CALL-METHOD
1087                       ,(wrap-with-call-method-macro ,gf
1088                                                     ',args-var
1089                                                     (second method)))))
1090              (t (%method-function method)))
1091            ,',args-var
1092            ,(unless (null next-method-list)
1093                     ;; by not generating an emf when there are no next methods,
1094                     ;; we ensure next-method-p returns NIL
1095                     (compute-effective-method-function
1096                        ,gf (process-next-method-list next-method-list))))))
1097     ,@forms))
1098
1099(defmacro with-args-lambda-list (args-lambda-list
1100                                 generic-function-symbol
1101                                 gf-args-symbol
1102                                 &body forms)
1103  (let ((gf-lambda-list (gensym))
1104        (nrequired (gensym))
1105        (noptional (gensym))
1106        (rest-args (gensym)))
1107    (multiple-value-bind (whole required optional rest keys aux)
1108        (parse-define-method-combination-arguments-lambda-list args-lambda-list)
1109      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))
1110              (,nrequired (length (extract-required-part ,gf-lambda-list)))
1111              (,noptional (length (extract-optional-part ,gf-lambda-list)))
1112              (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))
1113              ,@(when whole `((,whole ,gf-args-symbol)))
1114              ,@(loop for var in required and i upfrom 0
1115                  collect `(,var (when (< ,i ,nrequired)
1116                                   (nth ,i ,gf-args-symbol))))
1117              ,@(loop for (var init-form) in optional and i upfrom 0
1118                  collect
1119                  `(,var (if (< ,i ,noptional)
1120                             (nth (+ ,nrequired ,i) ,gf-args-symbol)
1121                             ,init-form)))
1122              ,@(when rest `((,rest ,rest-args)))
1123              ,@(loop for ((key var) init-form) in keys and i upfrom 0
1124                  collect `(,var (getk ,rest-args ',key ,init-form)))
1125              ,@(loop for (var init-form) in aux and i upfrom 0
1126                  collect `(,var ,init-form)))
1127         ,@forms))))
1128
1129(defun assert-unambiguous-method-sorting (group-name methods)
1130  (let ((specializers (make-hash-table :test 'equal)))
1131    (dolist (method methods)
1132      (push method (gethash (method-specializers method) specializers)))
1133    (loop for specializer-methods being each hash-value of specializers
1134       using (hash-key method-specializers)
1135       unless (= 1 (length specializer-methods))
1136       do (error "Ambiguous method sorting in method group ~A due to multiple ~
1137                  methods with specializers ~S: ~S"
1138                 group-name method-specializers specializer-methods))))
1139
1140(defmacro with-method-groups (method-group-specs methods-form &body forms)
1141  (flet ((grouping-form (spec methods-var)
1142           (let ((predicate (coerce-to-function (getf spec :predicate)))
1143                 (group (gensym))
1144                 (leftovers (gensym))
1145                 (method (gensym)))
1146             `(let ((,group '())
1147                    (,leftovers '()))
1148                (dolist (,method ,methods-var)
1149                  (if (funcall ,predicate (method-qualifiers ,method))
1150                      (push ,method ,group)
1151                      (push ,method ,leftovers)))
1152                (ecase ,(getf spec :order)
1153                  (:most-specific-last )
1154                  (:most-specific-first (setq ,group (nreverse ,group))))
1155                ,@(when (getf spec :required)
1156                        `((when (null ,group)
1157                            (error "Method group ~S must not be empty."
1158                                   ',(getf spec :name)))))
1159                (setq ,methods-var (nreverse ,leftovers))
1160                ,group))))
1161    (let ((rest (gensym))
1162          (method (gensym)))
1163      `(let* ((,rest ,methods-form)
1164              ,@(mapcar #'(lambda (spec)
1165                           `(,(getf spec :name) ,(grouping-form spec rest)))
1166                        method-group-specs))
1167         (dolist (,method ,rest)
1168           (invalid-method-error ,method
1169                                 "Method ~S with qualifiers ~S does not belong to any method group."
1170                                 ,method (method-qualifiers ,method)))
1171         ,@(unless (and (= 1 (length method-group-specs))
1172                        (getf (car method-group-specs) :*-selecter))
1173             (mapcar #'(lambda (spec)
1174                         `(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name)))
1175                     method-group-specs))
1176         ,@forms))))
1177
1178(defun method-combination-type-lambda
1179  (&key name lambda-list args-lambda-list generic-function-symbol
1180        method-group-specs declarations forms &allow-other-keys)
1181  (declare (ignore name))
1182  (let ((methods (gensym))
1183        (args-var (gensym)))
1184    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
1185       ,@declarations
1186       (with-method-groups ,method-group-specs
1187           ,methods
1188         ,(if (null args-lambda-list)
1189              `(let ((result (progn ,@forms)))
1190                 `(lambda (,',args-var)
1191                    ,(wrap-with-call-method-macro ,generic-function-symbol
1192                                                  ',args-var (list result))))
1193              `(lambda (,args-var)
1194                 (let* ((result
1195                         (with-args-lambda-list ,args-lambda-list
1196                             ,generic-function-symbol ,args-var
1197                           ,@forms))
1198                        (function
1199                         `(lambda (,',args-var) ;; ugly: we're reusing it
1200                          ;; to prevent calling gensym on every EMF invocation
1201                          ,(wrap-with-call-method-macro ,generic-function-symbol
1202                                                        ',args-var
1203                                                        (list result)))))
1204                   (funcall function ,args-var))))))))
1205
1206(defun declarationp (expr)
1207  (and (consp expr) (eq (car expr) 'DECLARE)))
1208
1209(defun long-form-method-combination-args (args)
1210  ;; define-method-combination name lambda-list (method-group-specifier*) args
1211  ;; args ::= [(:arguments . args-lambda-list)]
1212  ;;          [(:generic-function generic-function-symbol)]
1213  ;;          [[declaration* | documentation]] form*
1214  (let ((rest args))
1215    (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
1216             (args-lambda-list ()
1217               (when (nextp :arguments)
1218                 (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
1219             (generic-function-symbol ()
1220                (if (nextp :generic-function)
1221                    (prog1 (second (car rest)) (setq rest (cdr rest)))
1222                    (gensym)))
1223             (declaration* ()
1224               (let ((end (position-if-not #'declarationp rest)))
1225                 (when end
1226                   (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
1227             (documentation? ()
1228               (when (stringp (car rest))
1229                 (prog1 (car rest) (setq rest (cdr rest)))))
1230             (form* () rest))
1231      (let ((declarations '()))
1232        `(:args-lambda-list ,(args-lambda-list)
1233                            :generic-function-symbol ,(generic-function-symbol)
1234                            :documentation ,(prog2 (setq declarations (declaration*))
1235                                              (documentation?))
1236                            :declarations (,@declarations ,@(declaration*))
1237                            :forms ,(form*))))))
1238
1239(defun define-long-form-method-combination (name lambda-list method-group-specs
1240                                                 &rest args)
1241  (let* ((initargs `(:name ,name
1242                     :lambda-list ,lambda-list
1243                     :method-group-specs ,method-group-specs
1244                     ,@(long-form-method-combination-args args)))
1245         (lambda-expression (apply #'method-combination-type-lambda initargs)))
1246    (apply #'define-method-combination-type name
1247           `(,@initargs
1248;;              :function ,(compile nil lambda-expression)
1249             :function ,(coerce-to-function lambda-expression)))
1250    name))
1251
1252(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
1253
1254(defun intern-eql-specializer (object)
1255  (or (gethash object *eql-specializer-table*)
1256      (setf (gethash object *eql-specializer-table*)
1257            ;; we will be called during generic function invocation
1258            ;; setup, so have to rely on plain functions here.
1259            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
1260              (setf (std-slot-value instance 'sys::object) object)
1261              instance))))
1262
1263(defun eql-specializer-object (eql-specializer)
1264  (check-type eql-specializer eql-specializer)
1265  (std-slot-value eql-specializer 'sys::object))
1266
1267;; MOP (p. 216) specifies the following reader generic functions:
1268;;   generic-function-argument-precedence-order
1269;;   generic-function-declarations
1270;;   generic-function-lambda-list
1271;;   generic-function-method-class
1272;;   generic-function-method-combination
1273;;   generic-function-methods
1274;;   generic-function-name
1275
1276;;; These are defined with % in package SYS, defined as functions here
1277;;; and redefined as generic functions once we're all set up.
1278
1279(defun generic-function-lambda-list (gf)
1280  (%generic-function-lambda-list gf))
1281(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
1282
1283(defun (setf generic-function-documentation) (new-value gf)
1284  (set-generic-function-documentation gf new-value))
1285
1286(defun (setf generic-function-initial-methods) (new-value gf)
1287  (set-generic-function-initial-methods gf new-value))
1288
1289(defun generic-function-methods (gf)
1290  (sys:%generic-function-methods gf))
1291(defun (setf generic-function-methods) (new-value gf)
1292  (set-generic-function-methods gf new-value))
1293
1294(defun generic-function-method-class (gf)
1295  (sys:%generic-function-method-class gf))
1296(defun (setf generic-function-method-class) (new-value gf)
1297  (set-generic-function-method-class gf new-value))
1298
1299(defun generic-function-method-combination (gf)
1300  (sys:%generic-function-method-combination gf))
1301(defun (setf generic-function-method-combination) (new-value gf)
1302  (set-generic-function-method-combination gf new-value))
1303
1304(defun generic-function-argument-precedence-order (gf)
1305  (sys:%generic-function-argument-precedence-order gf))
1306(defun (setf generic-function-argument-precedence-order) (new-value gf)
1307  (set-generic-function-argument-precedence-order gf new-value))
1308
1309(declaim (ftype (function * t) classes-to-emf-table))
1310(defun classes-to-emf-table (gf)
1311  (generic-function-classes-to-emf-table gf))
1312
1313(defun (setf classes-to-emf-table) (new-value gf)
1314  (set-generic-function-classes-to-emf-table gf new-value))
1315
1316(defun (setf method-lambda-list) (new-value method)
1317  (set-method-lambda-list method new-value))
1318
1319(defun (setf method-qualifiers) (new-value method)
1320  (set-method-qualifiers method new-value))
1321
1322(defun (setf method-documentation) (new-value method)
1323  (set-method-documentation method new-value))
1324
1325;;; defgeneric
1326
1327(defmacro defgeneric (function-name lambda-list
1328                                    &rest options-and-method-descriptions)
1329  (let ((options ())
1330        (methods ())
1331        (documentation nil))
1332    (dolist (item options-and-method-descriptions)
1333      (case (car item)
1334        (declare) ; FIXME
1335        (:documentation
1336         (when documentation
1337           (error 'program-error
1338                  :format-control "Documentation option was specified twice for generic function ~S."
1339                  :format-arguments (list function-name)))
1340         (setf documentation t)
1341         (push item options))
1342        (:method
1343         (push
1344          `(push (defmethod ,function-name ,@(cdr item))
1345                 (generic-function-initial-methods (fdefinition ',function-name)))
1346          methods))
1347        (t
1348         (push item options))))
1349    (setf options (nreverse options)
1350          methods (nreverse methods))
1351    `(prog1
1352       (%defgeneric
1353        ',function-name
1354        :lambda-list ',lambda-list
1355        ,@(canonicalize-defgeneric-options options))
1356       ,@methods)))
1357
1358(defun canonicalize-defgeneric-options (options)
1359  (mapappend #'canonicalize-defgeneric-option options))
1360
1361(defun canonicalize-defgeneric-option (option)
1362  (case (car option)
1363    (:generic-function-class
1364     (list :generic-function-class `(find-class ',(cadr option))))
1365    (:method-class
1366     (list :method-class `(find-class ',(cadr option))))
1367    (:method-combination
1368     (list :method-combination `',(cdr option)))
1369    (:argument-precedence-order
1370     (list :argument-precedence-order `',(cdr option)))
1371    (t
1372     (list `',(car option) `',(cadr option)))))
1373
1374;; From OpenMCL.
1375(defun canonicalize-argument-precedence-order (apo req)
1376  (cond ((equal apo req) nil)
1377        ((not (eql (length apo) (length req)))
1378         (error 'program-error
1379                :format-control "Specified argument precedence order ~S does not match lambda list."
1380                :format-arguments (list apo)))
1381        (t (let ((res nil))
1382             (dolist (arg apo (nreverse res))
1383               (let ((index (position arg req)))
1384                 (if (or (null index) (memq index res))
1385                     (error 'program-error
1386                            :format-control "Specified argument precedence order ~S does not match lambda list."
1387                            :format-arguments (list apo)))
1388                 (push index res)))))))
1389
1390(defun find-generic-function (name &optional (errorp t))
1391  (let ((function (and (fboundp name) (fdefinition name))))
1392    (when function
1393      (when (typep function 'generic-function)
1394        (return-from find-generic-function function))
1395      (when (and *traced-names* (find name *traced-names* :test #'equal))
1396        (setf function (untraced-function name))
1397        (when (typep function 'generic-function)
1398          (return-from find-generic-function function)))))
1399  (if errorp
1400      (error "There is no generic function named ~S." name)
1401      nil))
1402
1403(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
1404  (let* ((plist1 (analyze-lambda-list lambda-list1))
1405         (args1 (getf plist1 :required-args))
1406         (plist2 (analyze-lambda-list lambda-list2))
1407         (args2 (getf plist2 :required-args)))
1408    (= (length args1) (length args2))))
1409
1410(defun %defgeneric (function-name &rest all-keys)
1411  (when (fboundp function-name)
1412    (let ((gf (fdefinition function-name)))
1413      (when (typep gf 'generic-function)
1414        ;; Remove methods defined by previous DEFGENERIC forms.
1415        (dolist (method (generic-function-initial-methods gf))
1416          (%remove-method gf method))
1417        (setf (generic-function-initial-methods gf) '()))))
1418  (apply 'ensure-generic-function function-name all-keys))
1419
1420(defun ensure-generic-function (function-name
1421                                &rest all-keys
1422                                &key
1423                                lambda-list
1424                                (generic-function-class +the-standard-generic-function-class+)
1425                                (method-class +the-standard-method-class+)
1426                                (method-combination 'standard)
1427                                (argument-precedence-order nil apo-p)
1428                                documentation
1429                                &allow-other-keys)
1430  (when (autoloadp function-name)
1431    (resolve function-name))
1432  (let ((gf (find-generic-function function-name nil)))
1433    (if gf
1434        (progn
1435          (unless (or (null (generic-function-methods gf))
1436                      (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
1437            (error 'simple-error
1438                   :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
1439                   :format-arguments (list lambda-list gf)))
1440          (setf (generic-function-lambda-list gf) lambda-list)
1441          (setf (generic-function-documentation gf) documentation)
1442          (let* ((plist (analyze-lambda-list lambda-list))
1443                 (required-args (getf plist ':required-args)))
1444            (%set-gf-required-args gf required-args)
1445            (%set-gf-optional-args gf (getf plist :optional-args))
1446            (when apo-p
1447              (setf (generic-function-argument-precedence-order gf)
1448                    (if argument-precedence-order
1449                        (canonicalize-argument-precedence-order argument-precedence-order
1450                                                                required-args)
1451                        nil)))
1452            (finalize-generic-function gf))
1453          gf)
1454        (progn
1455          (when (and (null *clos-booting*)
1456                     (fboundp function-name))
1457            (error 'program-error
1458                   :format-control "~A already names an ordinary function, macro, or special operator."
1459                   :format-arguments (list function-name)))
1460          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
1461                              #'make-instance-standard-generic-function
1462                              #'make-instance)
1463                          generic-function-class
1464                          :name function-name
1465                          :method-class method-class
1466                          :method-combination method-combination
1467                          all-keys))
1468          gf))))
1469
1470(defun initial-discriminating-function (gf args)
1471  (set-funcallable-instance-function
1472   gf
1473   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1474                #'std-compute-discriminating-function
1475                #'compute-discriminating-function)
1476            gf))
1477  (apply gf args))
1478
1479(defun collect-eql-specializer-objects (generic-function)
1480  (let ((result nil))
1481    (dolist (method (generic-function-methods generic-function))
1482      (dolist (specializer (%method-specializers method))
1483        (when (typep specializer 'eql-specializer)
1484          (pushnew (eql-specializer-object specializer)
1485                   result
1486                   :test 'eql))))
1487    result))
1488
1489(defun finalize-generic-function (gf)
1490  (%finalize-generic-function gf)
1491  (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
1492  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
1493  (set-funcallable-instance-function
1494   gf #'(lambda (&rest args)
1495          (initial-discriminating-function gf args)))
1496  ;; FIXME Do we need to warn on redefinition somewhere else?
1497  (let ((*warn-on-redefinition* nil))
1498    (setf (fdefinition (%generic-function-name gf)) gf))
1499  (values))
1500
1501(defun make-instance-standard-generic-function (generic-function-class
1502                                                &key name lambda-list
1503                                                method-class
1504                                                method-combination
1505                                                argument-precedence-order
1506                                                documentation)
1507  (declare (ignore generic-function-class))
1508  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1509    (%set-generic-function-name gf name)
1510    (setf (generic-function-lambda-list gf) lambda-list)
1511    (setf (generic-function-initial-methods gf) ())
1512    (setf (generic-function-methods gf) ())
1513    (setf (generic-function-method-class gf) method-class)
1514    (setf (generic-function-method-combination gf) method-combination)
1515    (setf (generic-function-documentation gf) documentation)
1516    (setf (classes-to-emf-table gf) nil)
1517    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1518           (required-args (getf plist ':required-args)))
1519      (%set-gf-required-args gf required-args)
1520      (%set-gf-optional-args gf (getf plist :optional-args))
1521      (setf (generic-function-argument-precedence-order gf)
1522            (if argument-precedence-order
1523                (canonicalize-argument-precedence-order argument-precedence-order
1524                                                        required-args)
1525                nil)))
1526    (finalize-generic-function gf)
1527    gf))
1528
1529(defun canonicalize-specializers (specializers)
1530  (mapcar #'canonicalize-specializer specializers))
1531
1532(defun canonicalize-specializer (specializer)
1533  (cond ((classp specializer)
1534         specializer)
1535        ((typep specializer 'eql-specializer)
1536         specializer)
1537        ((symbolp specializer)
1538         (find-class specializer))
1539        ((and (consp specializer)
1540              (eq (car specializer) 'eql))
1541         (let ((object (cadr specializer)))
1542           (when (and (consp object)
1543                      (eq (car object) 'quote))
1544             (setf object (cadr object)))
1545           (intern-eql-specializer object)))
1546        ((and (consp specializer)
1547              (eq (car specializer) 'java:jclass))
1548         (let ((jclass (eval specializer)))
1549           (java::ensure-java-class jclass)))
1550        (t
1551         (error "Unknown specializer: ~S" specializer))))
1552
1553(defun parse-defmethod (args)
1554  (let ((function-name (car args))
1555        (qualifiers ())
1556        (specialized-lambda-list ())
1557        (body ())
1558        (parse-state :qualifiers))
1559    (dolist (arg (cdr args))
1560      (ecase parse-state
1561        (:qualifiers
1562         (if (and (atom arg) (not (null arg)))
1563             (push arg qualifiers)
1564             (progn
1565               (setf specialized-lambda-list arg)
1566               (setf parse-state :body))))
1567        (:body (push arg body))))
1568    (setf qualifiers (nreverse qualifiers)
1569          body (nreverse body))
1570    (multiple-value-bind (real-body declarations documentation)
1571        (parse-body body)
1572      (values function-name
1573              qualifiers
1574              (extract-lambda-list specialized-lambda-list)
1575              (extract-specializer-names specialized-lambda-list)
1576              documentation
1577              declarations
1578              (list* 'block
1579                     (fdefinition-block-name function-name)
1580                     real-body)))))
1581
1582(defun required-portion (gf args)
1583  (let ((number-required (length (gf-required-args gf))))
1584    (when (< (length args) number-required)
1585      (error 'program-error
1586             :format-control "Not enough arguments for generic function ~S."
1587             :format-arguments (list (%generic-function-name gf))))
1588    (subseq args 0 number-required)))
1589
1590(defun extract-lambda-list (specialized-lambda-list)
1591  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1592         (requireds (getf plist :required-names))
1593         (rv (getf plist :rest-var))
1594         (ks (getf plist :key-args))
1595         (keysp (getf plist :keysp))
1596         (aok (getf plist :allow-other-keys))
1597         (opts (getf plist :optional-args))
1598         (auxs (getf plist :auxiliary-args)))
1599    `(,@requireds
1600      ,@(if rv `(&rest ,rv) ())
1601      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1602      ,@(if aok '(&allow-other-keys) ())
1603      ,@(if opts `(&optional ,@opts) ())
1604      ,@(if auxs `(&aux ,@auxs) ()))))
1605
1606(defun extract-specializer-names (specialized-lambda-list)
1607  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1608    (getf plist ':specializers)))
1609
1610(defun get-keyword-from-arg (arg)
1611  (if (listp arg)
1612      (if (listp (car arg))
1613          (caar arg)
1614          (make-keyword (car arg)))
1615      (make-keyword arg)))
1616
1617(defun analyze-lambda-list (lambda-list)
1618  (let ((keys ())           ; Just the keywords
1619        (key-args ())       ; Keywords argument specs
1620        (keysp nil)         ;
1621        (required-names ()) ; Just the variable names
1622        (required-args ())  ; Variable names & specializers
1623        (specializers ())   ; Just the specializers
1624        (rest-var nil)
1625        (optionals ())
1626        (auxs ())
1627        (allow-other-keys nil)
1628        (state :parsing-required))
1629    (dolist (arg lambda-list)
1630      (if (member arg lambda-list-keywords)
1631          (ecase arg
1632            (&optional
1633             (setq state :parsing-optional))
1634            (&rest
1635             (setq state :parsing-rest))
1636            (&key
1637             (setq keysp t)
1638             (setq state :parsing-key))
1639            (&allow-other-keys
1640             (setq allow-other-keys 't))
1641            (&aux
1642             (setq state :parsing-aux)))
1643          (case state
1644            (:parsing-required
1645             (push-on-end arg required-args)
1646             (if (listp arg)
1647                 (progn (push-on-end (car arg) required-names)
1648                   (push-on-end (cadr arg) specializers))
1649                 (progn (push-on-end arg required-names)
1650                   (push-on-end 't specializers))))
1651            (:parsing-optional (push-on-end arg optionals))
1652            (:parsing-rest (setq rest-var arg))
1653            (:parsing-key
1654             (push-on-end (get-keyword-from-arg arg) keys)
1655             (push-on-end arg key-args))
1656            (:parsing-aux (push-on-end arg auxs)))))
1657    (list  :required-names required-names
1658           :required-args required-args
1659           :specializers specializers
1660           :rest-var rest-var
1661           :keywords keys
1662           :key-args key-args
1663           :keysp keysp
1664           :auxiliary-args auxs
1665           :optional-args optionals
1666           :allow-other-keys allow-other-keys)))
1667
1668#+nil
1669(defun check-method-arg-info (gf arg-info method)
1670  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1671      (analyze-lambda-list (if (consp method)
1672                               (early-method-lambda-list method)
1673                               (method-lambda-list method)))
1674    (flet ((lose (string &rest args)
1675                 (error 'simple-program-error
1676                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1677                        to the generic function~2I~_~S;~I~_~
1678                        but ~?~:>"
1679                        :format-arguments (list method gf string args)))
1680           (comparison-description (x y)
1681                                   (if (> x y) "more" "fewer")))
1682      (let ((gf-nreq (arg-info-number-required arg-info))
1683            (gf-nopt (arg-info-number-optional arg-info))
1684            (gf-key/rest-p (arg-info-key/rest-p arg-info))
1685            (gf-keywords (arg-info-keys arg-info)))
1686        (unless (= nreq gf-nreq)
1687          (lose
1688           "the method has ~A required arguments than the generic function."
1689           (comparison-description nreq gf-nreq)))
1690        (unless (= nopt gf-nopt)
1691          (lose
1692           "the method has ~A optional arguments than the generic function."
1693           (comparison-description nopt gf-nopt)))
1694        (unless (eq (or keysp restp) gf-key/rest-p)
1695          (lose
1696           "the method and generic function differ in whether they accept~_~
1697            &REST or &KEY arguments."))
1698        (when (consp gf-keywords)
1699          (unless (or (and restp (not keysp))
1700                      allow-other-keys-p
1701                      (every (lambda (k) (memq k keywords)) gf-keywords))
1702            (lose "the method does not accept each of the &KEY arguments~2I~_~
1703            ~S."
1704                  gf-keywords)))))))
1705
1706(defun check-method-lambda-list (name method-lambda-list gf-lambda-list)
1707  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1708         (gf-plist (analyze-lambda-list gf-lambda-list))
1709         (gf-keysp (getf gf-plist :keysp))
1710         (gf-keywords (getf gf-plist :keywords))
1711         (method-plist (analyze-lambda-list method-lambda-list))
1712         (method-restp (not (null (memq '&rest method-lambda-list))))
1713         (method-keysp (getf method-plist :keysp))
1714         (method-keywords (getf method-plist :keywords))
1715         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1716    (unless (= (length (getf gf-plist :required-args))
1717               (length (getf method-plist :required-args)))
1718      (error "The method-lambda-list ~S ~
1719              has the wrong number of required arguments ~
1720              for the generic function ~S." method-lambda-list name))
1721    (unless (= (length (getf gf-plist :optional-args))
1722               (length (getf method-plist :optional-args)))
1723      (error "The method-lambda-list ~S ~
1724              has the wrong number of optional arguments ~
1725              for the generic function ~S." method-lambda-list name))
1726    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1727      (error "The method-lambda-list ~S ~
1728              and the generic function ~S ~
1729              differ in whether they accept &REST or &KEY arguments."
1730             method-lambda-list name))
1731    (when (consp gf-keywords)
1732      (unless (or (and method-restp (not method-keysp))
1733                  method-allow-other-keys-p
1734                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1735        (error "The method-lambda-list ~S does not accept ~
1736                all of the keyword arguments defined for the ~
1737                generic function." method-lambda-list name)))))
1738
1739(defvar *gf-initialize-instance* nil
1740  "Cached value of the INITIALIZE-INSTANCE generic function.
1741Initialized with the true value near the end of the file.")
1742(defvar *gf-allocate-instance* nil
1743  "Cached value of the ALLOCATE-INSTANCE generic function.
1744Initialized with the true value near the end of the file.")
1745(defvar *gf-shared-initialize* nil
1746  "Cached value of the SHARED-INITIALIZE generic function.
1747Initialized with the true value near the end of the file.")
1748(defvar *gf-reinitialize-instance* nil
1749  "Cached value of the REINITIALIZE-INSTANCE generic function.
1750Initialized with the true value near the end of the file.")
1751
1752(declaim (ftype (function * method) ensure-method))
1753(defun ensure-method (name &rest all-keys)
1754  (let ((method-lambda-list (getf all-keys :lambda-list))
1755        (gf (find-generic-function name nil)))
1756    (when (or (eq gf *gf-initialize-instance*)
1757              (eq gf *gf-allocate-instance*)
1758              (eq gf *gf-shared-initialize*)
1759              (eq gf *gf-reinitialize-instance*))
1760      ;; ### Clearly, this can be targeted much more exact
1761      ;; as we only need to remove the specializing class and all
1762      ;; its subclasses from the hash.
1763      (clrhash *make-instance-initargs-cache*)
1764      (clrhash *reinitialize-instance-initargs-cache*))
1765    (if gf
1766        (check-method-lambda-list name method-lambda-list
1767                                  (generic-function-lambda-list gf))
1768        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
1769    (let ((method
1770           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
1771               (apply #'make-instance-standard-method gf all-keys)
1772               (apply #'make-instance (generic-function-method-class gf) all-keys))))
1773      (%add-method gf method)
1774      method)))
1775
1776(defun make-instance-standard-method (gf
1777                                      &key
1778                                      lambda-list
1779                                      qualifiers
1780                                      specializers
1781                                      documentation
1782                                      function
1783                                      fast-function)
1784  (declare (ignore gf))
1785  (let ((method (std-allocate-instance +the-standard-method-class+))
1786        (analyzed-args (analyze-lambda-list lambda-list))
1787        )
1788    (setf (method-lambda-list method) lambda-list)
1789    (setf (method-qualifiers method) qualifiers)
1790    (%set-method-specializers method (canonicalize-specializers specializers))
1791    (setf (method-documentation method) documentation)
1792    (%set-method-generic-function method nil)
1793    (%set-method-function method function)
1794    (%set-method-fast-function method fast-function)
1795    (%set-function-keywords method
1796                            (getf analyzed-args :keywords)
1797                            (getf analyzed-args :allow-other-keys))
1798    method))
1799
1800(defun %add-method (gf method)
1801  (when (%method-generic-function method)
1802    (error 'simple-error
1803           :format-control "ADD-METHOD: ~S is a method of ~S."
1804           :format-arguments (list method (%method-generic-function method))))
1805  ;; Remove existing method with same qualifiers and specializers (if any).
1806  (let ((old-method (%find-method gf (method-qualifiers method)
1807                                 (%method-specializers method) nil)))
1808    (when old-method
1809      (%remove-method gf old-method)))
1810  (%set-method-generic-function method gf)
1811  (push method (generic-function-methods gf))
1812  (dolist (specializer (%method-specializers method))
1813    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1814      (pushnew method (class-direct-methods specializer))))
1815  (finalize-generic-function gf)
1816  gf)
1817
1818(defun %remove-method (gf method)
1819  (setf (generic-function-methods gf)
1820        (remove method (generic-function-methods gf)))
1821  (%set-method-generic-function method nil)
1822  (dolist (specializer (%method-specializers method))
1823    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1824      (setf (class-direct-methods specializer)
1825            (remove method (class-direct-methods specializer)))))
1826  (finalize-generic-function gf)
1827  gf)
1828
1829(defun %find-method (gf qualifiers specializers &optional (errorp t))
1830  ;; "If the specializers argument does not correspond in length to the number
1831  ;; of required arguments of the generic-function, an an error of type ERROR
1832  ;; is signaled."
1833  (unless (= (length specializers) (length (gf-required-args gf)))
1834    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
1835           (length specializers)
1836           gf
1837           (length (gf-required-args gf))))
1838  (let* ((canonical-specializers (canonicalize-specializers specializers))
1839         (method
1840          (find-if #'(lambda (method)
1841                      (and (equal qualifiers
1842                                  (method-qualifiers method))
1843                           (equal canonical-specializers
1844                                  (%method-specializers method))))
1845                   (generic-function-methods gf))))
1846    (if (and (null method) errorp)
1847        (error "No such method for ~S." (%generic-function-name gf))
1848        method)))
1849
1850(defun fast-callable-p (gf)
1851  (and (eq (generic-function-method-combination gf) 'standard)
1852       (null (intersection (%generic-function-lambda-list gf)
1853                           '(&rest &optional &key &allow-other-keys &aux)))))
1854
1855(declaim (ftype (function * t) slow-method-lookup-1))
1856
1857(declaim (ftype (function (t t t) t) slow-reader-lookup))
1858(defun slow-reader-lookup (gf layout slot-name)
1859  (let ((location (layout-slot-location layout slot-name)))
1860    (cache-slot-location gf layout location)
1861    location))
1862
1863(defun std-compute-discriminating-function (gf)
1864  ;; In this function, we know that gf is of class
1865  ;; standard-generic-function, so we call various
1866  ;; sys:%generic-function-foo readers to break circularities.
1867  (cond
1868    ((and (= (length (sys:%generic-function-methods gf)) 1)
1869          (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method))
1870     (let* ((method (%car (sys:%generic-function-methods gf)))
1871            (class (car (%method-specializers method)))
1872            (slot-name (reader-method-slot-name method)))
1873       #'(lambda (arg)
1874           (declare (optimize speed))
1875           (let* ((layout (std-instance-layout arg))
1876                  (location (get-cached-slot-location gf layout)))
1877             (unless location
1878               (unless (simple-typep arg class)
1879                 ;; FIXME no applicable method
1880                 (error 'simple-type-error
1881                        :datum arg
1882                        :expected-type class))
1883               (setf location (slow-reader-lookup gf layout slot-name)))
1884             (if (consp location)
1885                 ;; Shared slot.
1886                 (cdr location)
1887                 (standard-instance-access arg location))))))
1888
1889    (t
1890     (let* ((emf-table (classes-to-emf-table gf))
1891            (number-required (length (gf-required-args gf)))
1892            (lambda-list (%generic-function-lambda-list gf))
1893            (exact (null (intersection lambda-list
1894                                       '(&rest &optional &key
1895                                         &allow-other-keys &aux)))))
1896       (if exact
1897           (cond
1898             ((= number-required 1)
1899              (cond
1900                ((and (eq (sys:%generic-function-method-combination gf) 'standard)
1901                      (= (length (sys:%generic-function-methods gf)) 1))
1902                 (let* ((method (%car (sys:%generic-function-methods gf)))
1903                        (specializer (car (%method-specializers method)))
1904                        (function (or (%method-fast-function method)
1905                                      (%method-function method))))
1906                   (if (typep specializer 'eql-specializer)
1907                       (let ((specializer-object (eql-specializer-object specializer)))
1908                         #'(lambda (arg)
1909                             (declare (optimize speed))
1910                             (if (eql arg specializer-object)
1911                                 (funcall function arg)
1912                                 (no-applicable-method gf (list arg)))))
1913                       #'(lambda (arg)
1914                           (declare (optimize speed))
1915                           (unless (simple-typep arg specializer)
1916                             ;; FIXME no applicable method
1917                             (error 'simple-type-error
1918                                    :datum arg
1919                                    :expected-type specializer))
1920                           (funcall function arg)))))
1921                (t
1922                 #'(lambda (arg)
1923                     (declare (optimize speed))
1924                     (let* ((specialization
1925                             (%get-arg-specialization gf arg))
1926                            (emfun (or (gethash1 specialization
1927                                                 emf-table)
1928                                       (slow-method-lookup-1
1929                                        gf arg specialization))))
1930                       (if emfun
1931                           (funcall emfun (list arg))
1932                           (apply #'no-applicable-method gf (list arg))))))))
1933             ((= number-required 2)
1934              #'(lambda (arg1 arg2)
1935                  (declare (optimize speed))
1936                  (let* ((args (list arg1 arg2))
1937                         (emfun (get-cached-emf gf args)))
1938                    (if emfun
1939                        (funcall emfun args)
1940                        (slow-method-lookup gf args)))))
1941             ((= number-required 3)
1942              #'(lambda (arg1 arg2 arg3)
1943                  (declare (optimize speed))
1944                  (let* ((args (list arg1 arg2 arg3))
1945                         (emfun (get-cached-emf gf args)))
1946                    (if emfun
1947                        (funcall emfun args)
1948                        (slow-method-lookup gf args)))))
1949             (t
1950              #'(lambda (&rest args)
1951                  (declare (optimize speed))
1952                  (let ((len (length args)))
1953                    (unless (= len number-required)
1954                      (error 'program-error
1955                             :format-control "Not enough arguments for generic function ~S."
1956                             :format-arguments (list (%generic-function-name gf)))))
1957                  (let ((emfun (get-cached-emf gf args)))
1958                    (if emfun
1959                        (funcall emfun args)
1960                        (slow-method-lookup gf args))))))
1961;;           (let ((non-key-args (+ number-required
1962;;                                  (length (gf-optional-args gf))))))
1963           #'(lambda (&rest args)
1964               (declare (optimize speed))
1965               (let ((len (length args)))
1966                 (unless (>= len number-required)
1967                   (error 'program-error
1968                          :format-control "Not enough arguments for generic function ~S."
1969                          :format-arguments (list (%generic-function-name gf)))))
1970               (let ((emfun (get-cached-emf gf args)))
1971                 (if emfun
1972                     (funcall emfun args)
1973                     (slow-method-lookup gf args)))))))))
1974
1975(defun sort-methods (methods gf required-classes)
1976  (if (or (null methods) (null (%cdr methods)))
1977      methods
1978      (sort methods
1979      (if (eq (class-of gf) +the-standard-generic-function-class+)
1980    #'(lambda (m1 m2)
1981        (std-method-more-specific-p m1 m2 required-classes
1982            (generic-function-argument-precedence-order gf)))
1983    #'(lambda (m1 m2)
1984        (method-more-specific-p gf m1 m2 required-classes))))))
1985
1986(defun method-applicable-p (method args)
1987  (do* ((specializers (%method-specializers method) (cdr specializers))
1988        (args args (cdr args)))
1989       ((null specializers) t)
1990    (let ((specializer (car specializers)))
1991      (if (typep specializer 'eql-specializer)
1992          (unless (eql (car args) (eql-specializer-object specializer))
1993            (return nil))
1994          (unless (subclassp (class-of (car args)) specializer)
1995            (return nil))))))
1996
1997(defun %compute-applicable-methods (gf args)
1998  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1999        (methods '()))
2000    (dolist (method (generic-function-methods gf))
2001      (when (method-applicable-p method args)
2002        (push method methods)))
2003    (sort-methods methods gf required-classes)))
2004
2005;;; METHOD-APPLICABLE-USING-CLASSES-P
2006;;;
2007;;; If the first return value is T, METHOD is definitely applicable to
2008;;; arguments that are instances of CLASSES.  If the first value is
2009;;; NIL and the second value is T, METHOD is definitely not applicable
2010;;; to arguments that are instances of CLASSES; if the second value is
2011;;; NIL the applicability of METHOD cannot be determined by inspecting
2012;;; the classes of its arguments only.
2013;;;
2014(defun method-applicable-using-classes-p (method classes)
2015  (do* ((specializers (%method-specializers method) (cdr specializers))
2016  (classes classes (cdr classes))
2017  (knownp t))
2018       ((null specializers)
2019  (if knownp (values t t) (values nil nil)))
2020    (let ((specializer (car specializers)))
2021      (if (typep specializer 'eql-specializer)
2022    (if (eql (class-of (eql-specializer-object specializer)) 
2023       (car classes))
2024        (setf knownp nil)
2025        (return (values nil t)))
2026    (unless (subclassp (car classes) specializer)
2027      (return (values nil t)))))))
2028
2029(defun check-applicable-method-keyword-args (gf args
2030                                             keyword-args
2031                                             applicable-keywords)
2032  (when (oddp (length keyword-args))
2033    (error 'program-error
2034           :format-control "Odd number of keyword arguments in call to ~S ~
2035with arguments list ~S"
2036           :format-arguments (list gf args)))
2037  (unless (getf keyword-args :allow-other-keys)
2038    (loop for key in keyword-args by #'cddr
2039       unless (or (member key applicable-keywords)
2040                  (eq key :allow-other-keys))
2041       do (error 'program-error
2042                 :format-control "Invalid keyword argument ~S in call ~
2043to ~S with argument list ~S."
2044                 :format-arguments (list key gf args)))))
2045
2046(defun compute-applicable-keywords (gf applicable-methods)
2047  (let ((applicable-keywords
2048         (getf (analyze-lambda-list (generic-function-lambda-list gf))
2049               :keywords)))
2050    (loop for method in applicable-methods
2051       do (multiple-value-bind
2052                (keywords allow-other-keys)
2053              (function-keywords method)
2054            (when allow-other-keys
2055              (setf applicable-keywords :any)
2056              (return))
2057            (setf applicable-keywords
2058                  (union applicable-keywords keywords))))
2059    applicable-keywords))
2060
2061(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args
2062                                          applicable-keywords)
2063  #'(lambda (args)
2064      (check-applicable-method-keyword-args
2065         gf args
2066         (nthcdr non-keyword-args args) applicable-keywords)
2067      (funcall emfun args)))
2068
2069(defun slow-method-lookup (gf args)
2070  (let ((applicable-methods (%compute-applicable-methods gf args)))
2071    (if applicable-methods
2072        (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
2073                                   #'std-compute-effective-method-function
2074                                   #'compute-effective-method-function)
2075                               gf applicable-methods))
2076               (non-keyword-args
2077                (+ (length (gf-required-args gf))
2078                   (length (gf-optional-args gf))))
2079               (gf-lambda-list (generic-function-lambda-list gf))
2080               (checks-required (and (member '&key gf-lambda-list)
2081                                     (not (member '&allow-other-keys
2082                                                  gf-lambda-list)))
2083                 )
2084              (applicable-keywords
2085               (when checks-required
2086                 ;; Don't do applicable keyword checks when this is
2087                 ;; one of the 'exceptional four' or when the gf allows
2088                 ;; other keywords.
2089                 (compute-applicable-keywords gf applicable-methods))))
2090          (when (and checks-required
2091                     (not (eq applicable-keywords :any)))
2092            (setf emfun
2093                  (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args
2094                                                     applicable-keywords)))
2095          (cache-emf gf args emfun)
2096          (funcall emfun args))
2097        (apply #'no-applicable-method gf args))))
2098
2099(defun slow-method-lookup-1 (gf arg arg-specialization)
2100  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
2101    (if applicable-methods
2102        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
2103                                  #'std-compute-effective-method-function
2104                                  #'compute-effective-method-function)
2105                              gf applicable-methods)))
2106          (when emfun
2107            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
2108          emfun))))
2109
2110(defun sub-specializer-p (c1 c2 c-arg)
2111  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
2112
2113(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
2114  (if argument-precedence-order
2115      (let ((specializers-1 (%method-specializers method1))
2116            (specializers-2 (%method-specializers method2)))
2117        (dolist (index argument-precedence-order)
2118          (let ((spec1 (nth index specializers-1))
2119                (spec2 (nth index specializers-2)))
2120            (unless (eq spec1 spec2)
2121              (cond ((typep spec1 'eql-specializer)
2122                     (return t))
2123                    ((typep spec2 'eql-specializer)
2124                     (return nil))
2125                    (t
2126                     (return (sub-specializer-p spec1 spec2
2127                                                (nth index required-classes)))))))))
2128      (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
2129           (specializers-2 (%method-specializers method2) (cdr specializers-2))
2130           (classes required-classes (cdr classes)))
2131          ((null specializers-1) nil)
2132        (let ((spec1 (car specializers-1))
2133              (spec2 (car specializers-2)))
2134          (unless (eq spec1 spec2)
2135            (cond ((typep spec1 'eql-specializer)
2136                   (return t))
2137                  ((typep spec2 'eql-specializer)
2138                   (return nil))
2139                  (t
2140                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
2141
2142(defun primary-method-p (method)
2143  (null (intersection '(:before :after :around) (method-qualifiers method))))
2144
2145(defun before-method-p (method)
2146  (equal '(:before) (method-qualifiers method)))
2147
2148(defun after-method-p (method)
2149  (equal '(:after) (method-qualifiers method)))
2150
2151(defun around-method-p (method)
2152  (equal '(:around) (method-qualifiers method)))
2153
2154(defun process-next-method-list (next-method-list)
2155  (mapcar #'(lambda (next-method-form)
2156              (cond
2157                ((listp next-method-form)
2158                 (assert (eq (first next-method-form) 'make-method))
2159                 (let* ((rest-sym (gensym)))
2160                   (make-instance-standard-method
2161                    nil ;; ignored
2162                    :lambda-list (list '&rest rest-sym)
2163                    :function (compute-method-function `(lambda (&rest ,rest-sym)
2164                                                          ,(second next-method-form))))))
2165                (t
2166                 (assert (typep next-method-form 'method))
2167                 next-method-form)))
2168          next-method-list))
2169
2170(defun std-compute-effective-method-function (gf methods)
2171  (let* ((mc (generic-function-method-combination gf))
2172         (mc-name (if (atom mc) mc (%car mc)))
2173         (options (if (atom mc) '() (%cdr mc)))
2174         (order (car options))
2175         (primaries '())
2176         (arounds '())
2177         around
2178         emf-form
2179         (long-method-combination-p
2180          (typep (get mc-name 'method-combination-object) 'long-method-combination)))
2181    (unless long-method-combination-p
2182      (dolist (m methods)
2183        (let ((qualifiers (method-qualifiers m)))
2184          (cond ((null qualifiers)
2185                 (if (eq mc-name 'standard)
2186                     (push m primaries)
2187                     (error "Method combination type mismatch.")))
2188                ((cdr qualifiers)
2189                 (error "Invalid method qualifiers."))
2190                ((eq (car qualifiers) :around)
2191                 (push m arounds))
2192                ((eq (car qualifiers) mc-name)
2193                 (push m primaries))
2194                ((memq (car qualifiers) '(:before :after)))
2195                (t
2196                 (error "Invalid method qualifiers."))))))
2197    (unless (eq order :most-specific-last)
2198      (setf primaries (nreverse primaries)))
2199    (setf arounds (nreverse arounds))
2200    (setf around (car arounds))
2201    (when (and (null primaries) (not long-method-combination-p))
2202      (error "No primary methods for the generic function ~S." gf))
2203    (cond
2204      (around
2205       (let ((next-emfun
2206              (funcall
2207               (if (eq (class-of gf) +the-standard-generic-function-class+)
2208                   #'std-compute-effective-method-function
2209                   #'compute-effective-method-function)
2210               gf (remove around methods))))
2211         (setf emf-form
2212               (generate-emf-lambda (%method-function around) next-emfun))))
2213      ((eq mc-name 'standard)
2214       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
2215              (befores (remove-if-not #'before-method-p methods))
2216              (reverse-afters
2217               (reverse (remove-if-not #'after-method-p methods))))
2218         (setf emf-form
2219               (cond
2220                 ((and (null befores) (null reverse-afters))
2221                  (let ((fast-function (%method-fast-function (car primaries))))
2222                    (if fast-function
2223                        (ecase (length (gf-required-args gf))
2224                          (1
2225                           #'(lambda (args)
2226                               (declare (optimize speed))
2227                               (funcall fast-function (car args))))
2228                          (2
2229                           #'(lambda (args)
2230                               (declare (optimize speed))
2231                               (funcall fast-function (car args) (cadr args)))))
2232                        (generate-emf-lambda (%method-function (car primaries))
2233                                             next-emfun))))
2234                 (t
2235                  (let ((method-function (%method-function (car primaries))))
2236                    #'(lambda (args)
2237                        (declare (optimize speed))
2238                        (dolist (before befores)
2239                          (funcall (%method-function before) args nil))
2240                        (multiple-value-prog1
2241                            (funcall method-function args next-emfun)
2242                          (dolist (after reverse-afters)
2243                            (funcall (%method-function after) args nil))))))))))
2244      (long-method-combination-p
2245       (let* ((mc-obj (get mc-name 'method-combination-object))
2246              (function (long-method-combination-function mc-obj))
2247              (arguments (rest (slot-value gf 'method-combination))))
2248         (assert (typep mc-obj 'long-method-combination))
2249         (assert function)
2250         (setf emf-form
2251               (if arguments
2252                   (apply function gf methods arguments)
2253                   (funcall function gf methods)))))
2254      (t
2255       (let ((mc-obj (get mc-name 'method-combination-object)))
2256         (unless (typep mc-obj 'short-method-combination)
2257           (error "Unsupported method combination type ~A."
2258                  mc-name))
2259         (let* ((operator (short-method-combination-operator mc-obj))
2260                (ioa (short-method-combination-identity-with-one-argument mc-obj)))
2261           (setf emf-form
2262                 (if (and (null (cdr primaries))
2263                          (not (null ioa)))
2264                     (generate-emf-lambda (%method-function (car primaries)) nil)
2265                     `(lambda (args)
2266                        (,operator ,@(mapcar
2267                                      (lambda (primary)
2268                                        `(funcall ,(%method-function primary) args nil))
2269                                      primaries)))))))))
2270    (assert (not (null emf-form)))
2271    (or #+nil (ignore-errors (autocompile emf-form))
2272        (coerce-to-function emf-form))))
2273
2274(defun generate-emf-lambda (method-function next-emfun)
2275  #'(lambda (args)
2276      (declare (optimize speed))
2277      (funcall method-function args next-emfun)))
2278
2279;;; compute an effective method function from a list of primary methods:
2280
2281(defun compute-primary-emfun (methods)
2282  (if (null methods)
2283      nil
2284      (let ((next-emfun (compute-primary-emfun (cdr methods))))
2285        #'(lambda (args)
2286           (funcall (%method-function (car methods)) args next-emfun)))))
2287
2288(defvar *call-next-method-p*)
2289(defvar *next-method-p-p*)
2290
2291(defun walk-form (form)
2292  (cond ((atom form)
2293         (cond ((eq form 'call-next-method)
2294                (setf *call-next-method-p* t))
2295               ((eq form 'next-method-p)
2296                (setf *next-method-p-p* t))))
2297        (t
2298         (walk-form (%car form))
2299         (walk-form (%cdr form)))))
2300
2301(defun compute-method-function (lambda-expression)
2302  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
2303        (body (cddr lambda-expression))
2304        (*call-next-method-p* nil)
2305        (*next-method-p-p* nil))
2306    (multiple-value-bind (body declarations) (parse-body body)
2307      (let ((ignorable-vars '()))
2308        (dolist (var lambda-list)
2309          (if (memq var lambda-list-keywords)
2310              (return)
2311              (push var ignorable-vars)))
2312        (push `(declare (ignorable ,@ignorable-vars)) declarations))
2313      (walk-form body)
2314      (cond ((or *call-next-method-p* *next-method-p-p*)
2315             `(lambda (args next-emfun)
2316                (flet ((call-next-method (&rest cnm-args)
2317                         (if (null next-emfun)
2318                             (error "No next method for generic function.")
2319                             (funcall next-emfun (or cnm-args args))))
2320                       (next-method-p ()
2321                         (not (null next-emfun))))
2322                  (declare (ignorable (function call-next-method)
2323                                      (function next-method-p)))
2324                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
2325            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
2326             ;; Required parameters only.
2327             (case (length lambda-list)
2328               (1
2329                `(lambda (args next-emfun)
2330                   (declare (ignore next-emfun))
2331                   (let ((,(%car lambda-list) (%car args)))
2332                     (declare (ignorable ,(%car lambda-list)))
2333                     ,@declarations ,@body)))
2334               (2
2335                `(lambda (args next-emfun)
2336                   (declare (ignore next-emfun))
2337                   (let ((,(%car lambda-list) (%car args))
2338                         (,(%cadr lambda-list) (%cadr args)))
2339                     (declare (ignorable ,(%car lambda-list)
2340                                         ,(%cadr lambda-list)))
2341                     ,@declarations ,@body)))
2342               (3
2343                `(lambda (args next-emfun)
2344                   (declare (ignore next-emfun))
2345                   (let ((,(%car lambda-list) (%car args))
2346                         (,(%cadr lambda-list) (%cadr args))
2347                         (,(%caddr lambda-list) (%caddr args)))
2348                     (declare (ignorable ,(%car lambda-list)
2349                                         ,(%cadr lambda-list)
2350                                         ,(%caddr lambda-list)))
2351                     ,@declarations ,@body)))
2352               (t
2353                `(lambda (args next-emfun)
2354                   (declare (ignore next-emfun))
2355                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
2356            (t
2357             `(lambda (args next-emfun)
2358                (declare (ignore next-emfun))
2359                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
2360
2361(defun compute-method-fast-function (lambda-expression)
2362  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
2363    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
2364      (return-from compute-method-fast-function nil))
2365    ;; Only required args.
2366    (let ((body (cddr lambda-expression))
2367          (*call-next-method-p* nil)
2368          (*next-method-p-p* nil))
2369      (multiple-value-bind (body declarations) (parse-body body)
2370        (walk-form body)
2371        (when (or *call-next-method-p* *next-method-p-p*)
2372          (return-from compute-method-fast-function nil))
2373        (let ((decls `(declare (ignorable ,@lambda-list))))
2374          (setf lambda-expression
2375                (list* (car lambda-expression)
2376                       (cadr lambda-expression)
2377                       decls
2378                       (cddr lambda-expression))))
2379        (case (length lambda-list)
2380          (1
2381;;            `(lambda (args next-emfun)
2382;;               (let ((,(%car lambda-list) (%car args)))
2383;;                 (declare (ignorable ,(%car lambda-list)))
2384;;                 ,@declarations ,@body)))
2385           lambda-expression)
2386          (2
2387;;            `(lambda (args next-emfun)
2388;;               (let ((,(%car lambda-list) (%car args))
2389;;                     (,(%cadr lambda-list) (%cadr args)))
2390;;                 (declare (ignorable ,(%car lambda-list)
2391;;                                     ,(%cadr lambda-list)))
2392;;                 ,@declarations ,@body)))
2393           lambda-expression)
2394;;           (3
2395;;            `(lambda (args next-emfun)
2396;;               (let ((,(%car lambda-list) (%car args))
2397;;                     (,(%cadr lambda-list) (%cadr args))
2398;;                     (,(%caddr lambda-list) (%caddr args)))
2399;;                 (declare (ignorable ,(%car lambda-list)
2400;;                                     ,(%cadr lambda-list)
2401;;                                     ,(%caddr lambda-list)))
2402;;                 ,@declarations ,@body)))
2403          (t
2404           nil))))))
2405
2406;; From CLHS section 7.6.5:
2407;; "When a generic function or any of its methods mentions &key in a lambda
2408;; list, the specific set of keyword arguments accepted by the generic function
2409;; varies according to the applicable methods. The set of keyword arguments
2410;; accepted by the generic function for a particular call is the union of the
2411;; keyword arguments accepted by all applicable methods and the keyword
2412;; arguments mentioned after &key in the generic function definition, if any."
2413;; Adapted from Sacla.
2414(defun allow-other-keys (lambda-list)
2415  (if (and (member '&key lambda-list)
2416           (not (member '&allow-other-keys lambda-list)))
2417      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
2418             (aux-part (subseq lambda-list key-end)))
2419        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
2420      lambda-list))
2421
2422(defmacro defmethod (&rest args)
2423  (multiple-value-bind
2424      (function-name qualifiers lambda-list specializers documentation declarations body)
2425      (parse-defmethod args)
2426    (let* ((specializers-form '())
2427           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
2428           (method-function (compute-method-function lambda-expression))
2429           (fast-function (compute-method-fast-function lambda-expression))
2430           )
2431      (dolist (specializer specializers)
2432        (cond ((and (consp specializer) (eq (car specializer) 'eql))
2433               (push `(list 'eql ,(cadr specializer)) specializers-form))
2434              (t
2435               (push `',specializer specializers-form))))
2436      (setf specializers-form `(list ,@(nreverse specializers-form)))
2437      `(progn
2438         (ensure-method ',function-name
2439                        :lambda-list ',lambda-list
2440                        :qualifiers ',qualifiers
2441                        :specializers ,specializers-form
2442                        ,@(if documentation `(:documentation ,documentation))
2443                        :function (function ,method-function)
2444                        ,@(if fast-function `(:fast-function (function ,fast-function)))
2445                        )))))
2446
2447;;; Reader and writer methods
2448
2449(defun make-instance-standard-reader-method (gf
2450                                             &key
2451                                             lambda-list
2452                                             qualifiers
2453                                             specializers
2454                                             documentation
2455                                             function
2456                                             fast-function
2457                                             slot-name)
2458  (declare (ignore gf))
2459  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
2460    (setf (method-lambda-list method) lambda-list)
2461    (setf (method-qualifiers method) qualifiers)
2462    (%set-method-specializers method (canonicalize-specializers specializers))
2463    (setf (method-documentation method) documentation)
2464    (%set-method-generic-function method nil)
2465    (%set-method-function method function)
2466    (%set-method-fast-function method fast-function)
2467    (set-reader-method-slot-name method slot-name)
2468    (%set-function-keywords method nil nil)
2469    method))
2470
2471(defun add-reader-method (class function-name slot-name)
2472  (let* ((lambda-expression
2473          (if (eq (class-of class) +the-standard-class+)
2474              `(lambda (object) (std-slot-value object ',slot-name))
2475              `(lambda (object) (slot-value object ',slot-name))))
2476         (method-function (compute-method-function lambda-expression))
2477         (fast-function (compute-method-fast-function lambda-expression)))
2478    (let ((method-lambda-list '(object))
2479          (gf (find-generic-function function-name nil)))
2480      (if gf
2481          (check-method-lambda-list function-name
2482                                    method-lambda-list
2483                                    (generic-function-lambda-list gf))
2484        (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
2485      (let ((method
2486             (make-instance-standard-reader-method gf
2487                                                   :lambda-list '(object)
2488                                                   :qualifiers ()
2489                                                   :specializers (list class)
2490                                                   :function (if (autoloadp 'compile)
2491                                                                 method-function
2492                                                                 (autocompile method-function))
2493                                                   :fast-function (if (autoloadp 'compile)
2494                                                                      fast-function
2495                                                                      (autocompile fast-function))
2496                                                   :slot-name slot-name)))
2497        (%add-method gf method)
2498        method))))
2499
2500(defun add-writer-method (class function-name slot-name)
2501  (let* ((lambda-expression
2502          (if (eq (class-of class) +the-standard-class+)
2503              `(lambda (new-value object)
2504                 (setf (std-slot-value object ',slot-name) new-value))
2505              `(lambda (new-value object)
2506                 (setf (slot-value object ',slot-name) new-value))))
2507         (method-function (compute-method-function lambda-expression))
2508         (fast-function (compute-method-fast-function lambda-expression))
2509         )
2510    (ensure-method function-name
2511                   :lambda-list '(new-value object)
2512                   :qualifiers ()
2513                   :specializers (list +the-T-class+ class)
2514;;                    :function `(function ,method-function)
2515                   :function (if (autoloadp 'compile)
2516                                 method-function
2517                                 (autocompile method-function))
2518                   :fast-function (if (autoloadp 'compile)
2519                                      fast-function
2520                                      (autocompile fast-function))
2521                   )))
2522
2523(defmacro atomic-defgeneric (function-name &rest rest)
2524  "Macro to define a generic function and 'swap it into place' after
2525it's been fully defined with all its methods.
2526
2527Note: the user should really use the (:method ..) method description
2528way of defining methods; there's not much use in atomically defining
2529generic functions without providing sensible behaviour..."
2530  (let ((temp-sym (gensym)))
2531    `(progn
2532       (defgeneric ,temp-sym ,@rest)
2533       (let ((gf (symbol-function ',temp-sym)))
2534         (setf ,(if (and (consp function-name)
2535                         (eq (car function-name) 'setf))
2536                    `(get ',(second function-name) 'setf-function)
2537                  `(symbol-function ',function-name)) gf)
2538         (%set-generic-function-name gf ',function-name)
2539         gf))))
2540
2541(defmacro redefine-class-forwarder (name slot)
2542  "Define a generic function on a temporary symbol as an accessor
2543for the slot `slot'. Then, when definition is complete (including
2544allocation of methods), swap the definition in place.
2545
2546Without this approach, we can't depend the old forwarders to be
2547in place, while we still need them to "
2548  (let* (($name (if (consp name) (cadr name) name))
2549         (%name (intern (concatenate 'string
2550                                     "%"
2551                                     (if (consp name)
2552                                         (symbol-name 'set-) "")
2553                                     (symbol-name $name))
2554                        (find-package "SYS"))))
2555    `(atomic-defgeneric ,name (;; splice a new-value parameter for setters
2556                               ,@(when (consp name) (list 'new-value))
2557                               class)
2558         ,@(mapcar (if (consp name)
2559                       #'(lambda (class-name)
2560                           `(:method (new-value (class ,class-name))
2561                              (,%name new-value class)))
2562                       #'(lambda (class-name)
2563                           `(:method ((class ,class-name))
2564                              (,%name class))))
2565                   '(built-in-class forward-referenced-class structure-class))
2566         ,@(mapcar #'(lambda (class-name)
2567                       `(:method (,@(when (consp name) (list 'new-value))
2568                                  (class ,class-name))
2569                          ,(if (consp name)
2570                               `(setf (slot-value class ',slot) new-value)
2571                               `(slot-value class ',slot))))
2572                   '(standard-class funcallable-standard-class)))))
2573
2574
2575(redefine-class-forwarder class-name name)
2576(redefine-class-forwarder (setf class-name) name)
2577(redefine-class-forwarder class-slots slots)
2578(redefine-class-forwarder (setf class-slots) slots)
2579(redefine-class-forwarder class-direct-slots direct-slots)
2580(redefine-class-forwarder (setf class-direct-slots) direct-slots)
2581(redefine-class-forwarder class-layout layout)
2582(redefine-class-forwarder (setf class-layout) layout)
2583(redefine-class-forwarder class-direct-superclasses direct-superclasses)
2584(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
2585(redefine-class-forwarder class-direct-subclasses direct-subclasses)
2586(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
2587(redefine-class-forwarder class-direct-methods direct-methods)
2588(redefine-class-forwarder (setf class-direct-methods) direct-methods)
2589(redefine-class-forwarder class-precedence-list precedence-list)
2590(redefine-class-forwarder (setf class-precedence-list) precedence-list)
2591(redefine-class-forwarder class-finalized-p finalized-p)
2592(redefine-class-forwarder (setf class-finalized-p) finalized-p)
2593(redefine-class-forwarder class-default-initargs default-initargs)
2594(redefine-class-forwarder (setf class-default-initargs) default-initargs)
2595(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
2596(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
2597
2598(defgeneric direct-slot-definition-class (class &rest initargs))
2599
2600(defmethod direct-slot-definition-class ((class class) &rest initargs)
2601  (declare (ignore initargs))
2602  +the-standard-direct-slot-definition-class+)
2603
2604(defgeneric effective-slot-definition-class (class &rest initargs))
2605
2606(defmethod effective-slot-definition-class ((class class) &rest initargs)
2607  (declare (ignore initargs))
2608  +the-standard-effective-slot-definition-class+)
2609
2610(atomic-defgeneric documentation (x doc-type)
2611    (:method ((x symbol) doc-type)
2612        (%documentation x doc-type))
2613    (:method ((x function) doc-type)
2614        (%documentation x doc-type)))
2615
2616(atomic-defgeneric (setf documentation) (new-value x doc-type)
2617    (:method (new-value (x symbol) doc-type)
2618        (%set-documentation x doc-type new-value))
2619    (:method (new-value (x function) doc-type)
2620        (%set-documentation x doc-type new-value)))
2621
2622
2623;; FIXME This should be a weak hashtable!
2624(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
2625
2626(defmethod documentation ((x list) (doc-type (eql 'function)))
2627  (let ((alist (gethash x *list-documentation-hashtable*)))
2628    (and alist (cdr (assoc doc-type alist)))))
2629
2630(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
2631  (let ((alist (gethash x *list-documentation-hashtable*)))
2632    (and alist (cdr (assoc doc-type alist)))))
2633
2634(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
2635  (let* ((alist (gethash x *list-documentation-hashtable*))
2636         (entry (and alist (assoc doc-type alist))))
2637    (cond (entry
2638           (setf (cdr entry) new-value))
2639          (t
2640           (setf (gethash x *list-documentation-hashtable*)
2641                 (push (cons doc-type new-value) alist)))))
2642  new-value)
2643
2644(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
2645  (let* ((alist (gethash x *list-documentation-hashtable*))
2646         (entry (and alist (assoc doc-type alist))))
2647    (cond (entry
2648           (setf (cdr entry) new-value))
2649          (t
2650           (setf (gethash x *list-documentation-hashtable*)
2651                 (push (cons doc-type new-value) alist)))))
2652  new-value)
2653
2654(defmethod documentation ((x class) (doc-type (eql 't)))
2655  (class-documentation x))
2656
2657(defmethod documentation ((x class) (doc-type (eql 'type)))
2658  (class-documentation x))
2659
2660(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't)))
2661  (%set-class-documentation x new-value))
2662
2663(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type)))
2664  (%set-class-documentation x new-value))
2665
2666(defmethod documentation ((x structure-class) (doc-type (eql 't)))
2667  (%documentation x doc-type))
2668
2669(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
2670  (%documentation x doc-type))
2671
2672(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
2673  (%set-documentation x doc-type new-value))
2674
2675(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
2676  (%set-documentation x doc-type new-value))
2677
2678(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
2679  (generic-function-documentation x))
2680
2681(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
2682  (setf (generic-function-documentation x) new-value))
2683
2684(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
2685  (generic-function-documentation x))
2686
2687(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
2688  (setf (generic-function-documentation x) new-value))
2689
2690(defmethod documentation ((x standard-method) (doc-type (eql 't)))
2691  (method-documentation x))
2692
2693(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
2694  (setf (method-documentation x) new-value))
2695
2696(defmethod documentation ((x package) (doc-type (eql 't)))
2697  (%documentation x doc-type))
2698
2699(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
2700  (%set-documentation x doc-type new-value))
2701
2702(defmethod documentation ((x symbol) (doc-type (eql 'function)))
2703  (%documentation x doc-type))
2704
2705;;; Applicable methods
2706
2707(defgeneric compute-applicable-methods (gf args)
2708  (:method ((gf standard-generic-function) args)
2709    (%compute-applicable-methods gf args)))
2710
2711(defgeneric compute-applicable-methods-using-classes (gf classes)
2712  (:method ((gf standard-generic-function) classes)
2713    (let ((methods '()))
2714      (dolist (method (generic-function-methods gf))
2715  (multiple-value-bind (applicable knownp)
2716      (method-applicable-using-classes-p method classes)
2717    (cond (applicable
2718     (push method methods))
2719    ((not knownp)
2720     (return-from compute-applicable-methods-using-classes
2721       (values nil nil))))))
2722      (values (sort-methods methods gf classes)
2723        t))))
2724
2725(export '(compute-applicable-methods
2726    compute-applicable-methods-using-classes))
2727
2728
2729;;; Slot access
2730
2731(defun set-slot-value-using-class (new-value class instance slot-name)
2732  (declare (ignore class)) ; FIXME
2733  (setf (std-slot-value instance slot-name) new-value))
2734
2735(defgeneric slot-value-using-class (class instance slot-name))
2736
2737(defmethod slot-value-using-class ((class standard-class) instance slot-name)
2738  (std-slot-value instance slot-name))
2739(defmethod slot-value-using-class ((class funcallable-standard-class)
2740                                   instance slot-name)
2741  (std-slot-value instance slot-name))
2742(defmethod slot-value-using-class ((class structure-class) instance slot-name)
2743  (std-slot-value instance slot-name))
2744
2745(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
2746
2747(defmethod (setf slot-value-using-class) (new-value
2748                                          (class standard-class)
2749                                          instance
2750                                          slot-name)
2751  (setf (std-slot-value instance slot-name) new-value))
2752
2753(defmethod (setf slot-value-using-class) (new-value
2754                                          (class funcallable-standard-class)
2755                                          instance
2756                                          slot-name)
2757  (setf (std-slot-value instance slot-name) new-value))
2758
2759(defmethod (setf slot-value-using-class) (new-value
2760                                          (class structure-class)
2761                                          instance
2762                                          slot-name)
2763  (setf (std-slot-value instance slot-name) new-value))
2764
2765(defgeneric slot-exists-p-using-class (class instance slot-name))
2766
2767(defmethod slot-exists-p-using-class (class instance slot-name)
2768  nil)
2769
2770(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
2771  (std-slot-exists-p instance slot-name))
2772(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name)
2773  (std-slot-exists-p instance slot-name))
2774
2775(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
2776  (dolist (dsd (class-slots class))
2777    (when (eq (sys::dsd-name dsd) slot-name)
2778      (return-from slot-exists-p-using-class t)))
2779  nil)
2780
2781(defgeneric slot-boundp-using-class (class instance slot-name))
2782(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
2783  (std-slot-boundp instance slot-name))
2784(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name)
2785  (std-slot-boundp instance slot-name))
2786(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
2787  "Structure slots can't be unbound, so this method always returns T."
2788  (declare (ignore class instance slot-name))
2789  t)
2790
2791(defgeneric slot-makunbound-using-class (class instance slot-name))
2792(defmethod slot-makunbound-using-class ((class standard-class)
2793                                        instance
2794                                        slot-name)
2795  (std-slot-makunbound instance slot-name))
2796(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
2797                                        instance
2798                                        slot-name)
2799  (std-slot-makunbound instance slot-name))
2800(defmethod slot-makunbound-using-class ((class structure-class)
2801                                        instance
2802                                        slot-name)
2803  (declare (ignore class instance slot-name))
2804  (error "Structure slots can't be unbound"))
2805
2806(defgeneric slot-missing (class instance slot-name operation &optional new-value))
2807
2808(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
2809  (declare (ignore new-value))
2810  (error "The slot ~S is missing from the class ~S." slot-name class))
2811
2812(defgeneric slot-unbound (class instance slot-name))
2813
2814(defmethod slot-unbound ((class t) instance slot-name)
2815  (error 'unbound-slot :instance instance :name slot-name))
2816
2817;;; Instance creation and initialization
2818
2819(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
2820
2821(defmethod allocate-instance ((class standard-class) &rest initargs)
2822  (declare (ignore initargs))
2823  (std-allocate-instance class))
2824
2825(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
2826  (declare (ignore initargs))
2827  (allocate-funcallable-instance class))
2828
2829(defmethod allocate-instance ((class structure-class) &rest initargs)
2830  (declare (ignore initargs))
2831  (%make-structure (class-name class)
2832                   (make-list (length (class-slots class))
2833                              :initial-element +slot-unbound+)))
2834
2835;; "The set of valid initialization arguments for a class is the set of valid
2836;; initialization arguments that either fill slots or supply arguments to
2837;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
2838;; 7.1.2
2839
2840(defun calculate-allowable-initargs (gf-list args instance
2841                                             shared-initialize-param
2842                                             initargs)
2843  (let* ((methods
2844          (nconc
2845             (compute-applicable-methods #'shared-initialize
2846                                         (list* instance
2847                                                shared-initialize-param
2848                                                initargs))
2849             (mapcan #'(lambda (gf)
2850                         (compute-applicable-methods gf args))
2851                     gf-list)))
2852         (method-keyword-args
2853          (reduce #'merge-initargs-sets
2854                  (mapcar #'method-lambda-list methods)
2855                  :key #'extract-lambda-list-keywords
2856                  :initial-value nil))
2857         (slots-initargs
2858          (mapappend #'slot-definition-initargs
2859                     (class-slots (class-of instance)))))
2860    (merge-initargs-sets
2861     (merge-initargs-sets slots-initargs method-keyword-args)
2862     '(:allow-other-keys))))  ;; allow-other-keys is always allowed
2863
2864(defun check-initargs (gf-list args instance
2865                       shared-initialize-param initargs
2866                       cache call-site)
2867  "Checks the validity of `initargs' for the generic functions in `gf-list'
2868when called with `args' by calculating the applicable methods for each gf.
2869The applicable methods for SHARED-INITIALIZE based on `instance',
2870`shared-initialize-param' and `initargs' are added to the list of
2871applicable methods."
2872  (when (oddp (length initargs))
2873    (error 'program-error
2874           :format-control "Odd number of keyword arguments."))
2875  (unless (getf initargs :allow-other-keys)
2876    (multiple-value-bind (allowable-initargs present-p)
2877                         (when cache
2878                           (gethash (class-of instance) cache))
2879       (unless present-p
2880         (setf allowable-initargs
2881               (calculate-allowable-initargs gf-list args instance
2882                                             shared-initialize-param initargs))
2883         (when cache
2884           (setf (gethash (class-of instance) cache)
2885                 allowable-initargs)))
2886       (unless (eq t allowable-initargs)
2887         (do* ((tail initargs (cddr tail))
2888               (initarg (car tail) (car tail)))
2889              ((null tail))
2890              (unless (memq initarg allowable-initargs)
2891                (error 'program-error
2892                       :format-control "Invalid initarg ~S in call to ~S with arglist ~S."
2893                       :format-arguments (list initarg call-site args))))))))
2894
2895(defun merge-initargs-sets (list1 list2)
2896  (cond
2897   ((eq list1 t)  t)
2898   ((eq list2 t)  t)
2899   (t             (union list1 list2))))
2900
2901(defun extract-lambda-list-keywords (lambda-list)
2902  "Returns a list of keywords acceptable as keyword arguments,
2903or T when any keyword is acceptable due to presence of
2904&allow-other-keys."
2905  (when (member '&allow-other-keys lambda-list)
2906    (return-from extract-lambda-list-keywords t))
2907  (loop with keyword-args = (cdr (memq '&key lambda-list))
2908        for key in keyword-args
2909        when (eq key '&aux) do (loop-finish)
2910        when (eq key '&allow-other-keys) do (return t)
2911        when (listp key) do (setq key (car key))
2912        collect (if (symbolp key)
2913                    (make-keyword key)
2914                  (car key))))
2915
2916
2917(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
2918
2919(defmethod make-instance :before ((class class) &rest initargs)
2920  (when (oddp (length initargs))
2921    (error 'program-error :format-control "Odd number of keyword arguments."))
2922  (unless (class-finalized-p class)
2923    (finalize-inheritance class)))
2924
2925(defun augment-initargs-with-defaults (class initargs)
2926  (let ((default-initargs '()))
2927    (do* ((list (class-default-initargs class) (cddr list))
2928          (key (car list) (car list))
2929          (fn (cadr list) (cadr list)))
2930         ((null list))
2931      (when (eq (getf initargs key 'not-found) 'not-found)
2932        (setf default-initargs (append default-initargs (list key (funcall fn))))))
2933    (append initargs default-initargs)))
2934
2935(defmethod make-instance ((class standard-class) &rest initargs)
2936  (setf initargs (augment-initargs-with-defaults class initargs))
2937  (let ((instance (std-allocate-instance class)))
2938    (check-initargs (list #'allocate-instance #'initialize-instance)
2939                    (list* instance initargs)
2940                    instance t initargs
2941                    *make-instance-initargs-cache* 'make-instance)
2942    (apply #'initialize-instance instance initargs)
2943    instance))
2944
2945(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
2946  (setf initargs (augment-initargs-with-defaults class initargs))
2947  (let ((instance (allocate-funcallable-instance class)))
2948    (check-initargs (list #'allocate-instance #'initialize-instance)
2949                    (list* instance initargs)
2950                    instance t initargs
2951                    *make-instance-initargs-cache* 'make-instance)
2952    (apply #'initialize-instance instance initargs)
2953    instance))
2954
2955(defmethod make-instance ((class symbol) &rest initargs)
2956  (apply #'make-instance (find-class class) initargs))
2957
2958(defgeneric initialize-instance (instance &rest initargs
2959                                          &key &allow-other-keys))
2960
2961(defmethod initialize-instance ((instance standard-object) &rest initargs)
2962  (apply #'shared-initialize instance t initargs))
2963
2964(defgeneric reinitialize-instance (instance &rest initargs
2965                                            &key &allow-other-keys))
2966
2967;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
2968;; validity of initargs and signals an error if an initarg is supplied that is
2969;; not declared as valid. The method then calls the generic function SHARED-
2970;; INITIALIZE with the following arguments: the instance, nil (which means no
2971;; slots should be initialized according to their initforms), and the initargs
2972;; it received."
2973(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2974  (check-initargs (list #'reinitialize-instance) (list* instance initargs)
2975                  instance () initargs
2976                  *reinitialize-instance-initargs-cache* 'reinitialize-instance)
2977  (apply #'shared-initialize instance () initargs))
2978
2979(defun std-shared-initialize (instance slot-names all-keys)
2980  (when (oddp (length all-keys))
2981    (error 'program-error :format-control "Odd number of keyword arguments."))
2982  ;; do a quick scan of the arguments list to see if it's a real
2983  ;; 'initialization argument list' (which is not the same as
2984  ;; checking initarg validity
2985  (do* ((tail all-keys (cddr tail))
2986        (initarg (car tail) (car tail)))
2987      ((null tail))
2988    (unless (symbolp initarg)
2989      (error 'program-error
2990             :format-control "Initarg ~S not a symbol."
2991             :format-arguments (list initarg))))
2992  (dolist (slot (class-slots (class-of instance)))
2993    (let ((slot-name (slot-definition-name slot)))
2994      (multiple-value-bind (init-key init-value foundp)
2995          (get-properties all-keys (slot-definition-initargs slot))
2996        (if foundp
2997            (setf (std-slot-value instance slot-name) init-value)
2998            (unless (std-slot-boundp instance slot-name)
2999              (let ((initfunction (slot-definition-initfunction slot)))
3000                (when (and initfunction (or (eq slot-names t)
3001                                            (memq slot-name slot-names)))
3002                  (setf (std-slot-value instance slot-name)
3003                        (funcall initfunction)))))))))
3004  instance)
3005
3006(defgeneric shared-initialize (instance slot-names
3007                                        &rest initargs
3008                                        &key &allow-other-keys))
3009
3010(defmethod shared-initialize ((instance standard-object) slot-names
3011                              &rest initargs)
3012  (std-shared-initialize instance slot-names initargs))
3013
3014(defmethod shared-initialize ((slot slot-definition) slot-names
3015                              &rest args
3016                              &key name initargs initform initfunction
3017                              readers writers allocation
3018                              &allow-other-keys)
3019  ;;Keyword args are duplicated from init-slot-definition only to have
3020  ;;them checked.
3021  (declare (ignore slot-names)) ;;TODO?
3022  (declare (ignore name initargs initform initfunction readers writers allocation))
3023  ;;For built-in slots
3024  (apply #'init-slot-definition slot :allow-other-keys t args)
3025  ;;For user-defined slots
3026  (call-next-method))
3027
3028;;; change-class
3029
3030(defgeneric change-class (instance new-class &key &allow-other-keys))
3031
3032(defmethod change-class ((old-instance standard-object) (new-class standard-class)
3033                         &rest initargs)
3034  (let ((old-slots (class-slots (class-of old-instance)))
3035        (new-slots (class-slots new-class))
3036        (new-instance (allocate-instance new-class)))
3037    ;; "The values of local slots specified by both the class CTO and the class
3038    ;; CFROM are retained. If such a local slot was unbound, it remains
3039    ;; unbound."
3040    (dolist (new-slot new-slots)
3041      (when (instance-slot-p new-slot)
3042        (let* ((slot-name (slot-definition-name new-slot))
3043               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
3044          ;; "The values of slots specified as shared in the class CFROM and as
3045          ;; local in the class CTO are retained."
3046          (when (and old-slot (slot-boundp old-instance slot-name))
3047            (setf (slot-value new-instance slot-name)
3048                  (slot-value old-instance slot-name))))))
3049    (swap-slots old-instance new-instance)
3050    (rotatef (std-instance-layout new-instance)
3051             (std-instance-layout old-instance))
3052    (apply #'update-instance-for-different-class
3053           new-instance old-instance initargs)
3054    old-instance))
3055
3056(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
3057  (apply #'change-class instance (find-class new-class) initargs))
3058
3059(defgeneric update-instance-for-different-class (old new
3060                                                     &rest initargs
3061                                                     &key &allow-other-keys))
3062
3063(defmethod update-instance-for-different-class
3064  ((old standard-object) (new standard-object) &rest initargs)
3065  (let ((added-slots
3066         (remove-if #'(lambda (slot-name)
3067                       (slot-exists-p old slot-name))
3068                    (mapcar 'slot-definition-name
3069                            (class-slots (class-of new))))))
3070    (check-initargs (list #'update-instance-for-different-class)
3071                    (list old new initargs)
3072                    new added-slots initargs
3073                    nil 'update-instance-for-different-class)
3074    (apply #'shared-initialize new added-slots initargs)))
3075
3076;;; make-instances-obsolete
3077
3078(defgeneric make-instances-obsolete (class))
3079
3080(defmethod make-instances-obsolete ((class standard-class))
3081  (%make-instances-obsolete class))
3082(defmethod make-instances-obsolete ((class funcallable-standard-class))
3083  (%make-instances-obsolete class))
3084(defmethod make-instances-obsolete ((class symbol))
3085  (make-instances-obsolete (find-class class))
3086  class)
3087
3088;;; update-instance-for-redefined-class
3089
3090(defgeneric update-instance-for-redefined-class (instance
3091                                                 added-slots
3092                                                 discarded-slots
3093                                                 property-list
3094                                                 &rest initargs
3095                                                 &key
3096                                                 &allow-other-keys))
3097
3098(defmethod update-instance-for-redefined-class ((instance standard-object)
3099            added-slots
3100            discarded-slots
3101            property-list
3102            &rest initargs)
3103  (check-initargs (list #'update-instance-for-redefined-class)
3104                  (list* instance added-slots discarded-slots
3105                         property-list initargs)
3106                  instance added-slots initargs
3107                  nil 'update-instance-for-redefined-class)
3108  (apply #'shared-initialize instance added-slots initargs))
3109
3110;;;  Methods having to do with class metaobjects.
3111
3112(defmethod initialize-instance :after ((class standard-class) &rest args)
3113  (apply #'std-after-initialization-for-classes class args))
3114
3115(defmethod initialize-instance :after ((class funcallable-standard-class)
3116                                       &rest args)
3117  (apply #'std-after-initialization-for-classes class args))
3118
3119(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
3120  (remhash class *make-instance-initargs-cache*)
3121  (remhash class *reinitialize-instance-initargs-cache*)
3122  (%make-instances-obsolete class)
3123  (setf (class-finalized-p class) nil)
3124  (check-initargs (list #'allocate-instance
3125                        #'initialize-instance)
3126                  (list* class all-keys)
3127                  class t all-keys
3128                  nil 'reinitialize-instance)
3129  (apply #'std-after-initialization-for-classes class all-keys))
3130
3131;;; Finalize inheritance
3132
3133(atomic-defgeneric finalize-inheritance (class)
3134    (:method ((class standard-class))
3135       (std-finalize-inheritance class))
3136    (:method ((class funcallable-standard-class))
3137       (std-finalize-inheritance class)))
3138
3139;;; Class precedence lists
3140
3141(defgeneric compute-class-precedence-list (class))
3142(defmethod compute-class-precedence-list ((class standard-class))
3143  (std-compute-class-precedence-list class))
3144(defmethod compute-class-precedence-list ((class funcallable-standard-class))
3145  (std-compute-class-precedence-list class))
3146
3147;;; Slot inheritance
3148
3149(defgeneric compute-slots (class))
3150(defmethod compute-slots ((class standard-class))
3151  (std-compute-slots class))
3152(defmethod compute-slots ((class funcallable-standard-class))
3153  (std-compute-slots class))
3154
3155(defgeneric compute-effective-slot-definition (class name direct-slots))
3156(defmethod compute-effective-slot-definition
3157  ((class standard-class) name direct-slots)
3158  (std-compute-effective-slot-definition class name direct-slots))
3159(defmethod compute-effective-slot-definition
3160  ((class funcallable-standard-class) name direct-slots)
3161  (std-compute-effective-slot-definition class name direct-slots))
3162;;; Methods having to do with generic function metaobjects.
3163
3164(defmethod initialize-instance :after ((gf standard-generic-function) &key)
3165  (finalize-generic-function gf))
3166
3167;;; Methods having to do with generic function invocation.
3168
3169(defgeneric compute-discriminating-function (gf))
3170(defmethod compute-discriminating-function ((gf standard-generic-function))
3171  (std-compute-discriminating-function gf))
3172
3173(defgeneric method-more-specific-p (gf method1 method2 required-classes))
3174
3175(defmethod method-more-specific-p ((gf standard-generic-function)
3176                                   method1 method2 required-classes)
3177  (std-method-more-specific-p method1 method2 required-classes
3178                              (generic-function-argument-precedence-order gf)))
3179
3180;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD
3181(defgeneric compute-effective-method-function (gf methods))
3182(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
3183  (std-compute-effective-method-function gf methods))
3184
3185(defgeneric compute-applicable-methods (gf args))
3186(defmethod compute-applicable-methods ((gf standard-generic-function) args)
3187  (%compute-applicable-methods gf args))
3188
3189;;; Slot definition accessors
3190
3191(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
3192  `(let (($cl (class-of ,slot-definition)))
3193     (case $cl
3194       ((+the-standard-slot-definition-class+
3195         +the-standard-direct-slot-definition-class+
3196         +the-standard-effective-slot-definition-class+)
3197        ,std-form)
3198       (t ,generic-form))))
3199
3200(atomic-defgeneric slot-definition-allocation (slot-definition)
3201  (:method ((slot-definition slot-definition))
3202    (slot-definition-dispatch slot-definition
3203      (%slot-definition-allocation slot-definition)
3204      (slot-value slot-definition 'sys::allocation))))
3205
3206(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition)
3207  (:method (value (slot-definition slot-definition))
3208    (slot-definition-dispatch slot-definition
3209      (set-slot-definition-allocation slot-definition value)
3210      (setf (slot-value slot-definition 'sys::allocation) value))))
3211
3212(atomic-defgeneric slot-definition-initargs (slot-definition)
3213  (:method ((slot-definition slot-definition))
3214    (slot-definition-dispatch slot-definition
3215      (%slot-definition-initargs slot-definition)
3216      (slot-value slot-definition 'sys::initargs))))
3217
3218(atomic-defgeneric slot-definition-initform (slot-definition)
3219  (:method ((slot-definition slot-definition))
3220    (slot-definition-dispatch slot-definition
3221      (%slot-definition-initform slot-definition)
3222      (slot-value slot-definition 'sys::initform))))
3223
3224(atomic-defgeneric (setf slot-definition-initform) (value slot-definition)
3225  (:method (value (slot-definition slot-definition))
3226    (slot-definition-dispatch slot-definition
3227      (set-slot-definition-initform slot-definition value)
3228      (setf (slot-value slot-definition 'sys::initform) value))))
3229
3230(atomic-defgeneric slot-definition-initfunction (slot-definition)
3231  (:method ((slot-definition slot-definition))
3232    (slot-definition-dispatch slot-definition
3233      (%slot-definition-initfunction slot-definition)
3234      (slot-value slot-definition 'sys::initfunction))))
3235
3236(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition)
3237  (:method (value (slot-definition slot-definition))
3238    (slot-definition-dispatch slot-definition
3239      (set-slot-definition-initfunction slot-definition value)
3240      (setf (slot-value slot-definition 'sys::initfunction) value))))
3241
3242(atomic-defgeneric slot-definition-name (slot-definition)
3243  (:method ((slot-definition slot-definition))
3244    (slot-definition-dispatch slot-definition
3245      (%slot-definition-name slot-definition)
3246      (slot-value slot-definition 'sys::name))))
3247
3248(atomic-defgeneric (setf slot-definition-name) (value slot-definition)
3249  (:method (value (slot-definition slot-definition))
3250    (slot-definition-dispatch slot-definition
3251      (set-slot-definition-name slot-definition value)
3252      (setf (slot-value slot-definition 'sys::name) value))))
3253
3254(atomic-defgeneric slot-definition-readers (slot-definition)
3255  (:method ((slot-definition slot-definition))
3256    (slot-definition-dispatch slot-definition
3257      (%slot-definition-readers slot-definition)
3258      (slot-value slot-definition 'sys::readers))))
3259
3260(atomic-defgeneric (setf slot-definition-readers) (value slot-definition)
3261  (:method (value (slot-definition slot-definition))
3262    (slot-definition-dispatch slot-definition
3263      (set-slot-definition-readers slot-definition value)
3264      (setf (slot-value slot-definition 'sys::readers) value))))
3265
3266(atomic-defgeneric slot-definition-writers (slot-definition)
3267  (:method ((slot-definition slot-definition))
3268    (slot-definition-dispatch slot-definition
3269      (%slot-definition-writers slot-definition)
3270      (slot-value slot-definition 'sys::writers))))
3271
3272(atomic-defgeneric (setf slot-definition-writers) (value slot-definition)
3273  (:method (value (slot-definition slot-definition))
3274    (slot-definition-dispatch slot-definition
3275      (set-slot-definition-writers slot-definition value)
3276      (setf (slot-value slot-definition 'sys::writers) value))))
3277
3278(atomic-defgeneric slot-definition-allocation-class (slot-definition)
3279  (:method ((slot-definition slot-definition))
3280    (slot-definition-dispatch slot-definition
3281      (%slot-definition-allocation-class slot-definition)
3282      (slot-value slot-definition 'sys::allocation-class))))
3283
3284(atomic-defgeneric (setf slot-definition-allocation-class)
3285                       (value slot-definition)
3286  (:method (value (slot-definition slot-definition))
3287    (slot-definition-dispatch slot-definition
3288      (set-slot-definition-allocation-class slot-definition value)
3289      (setf (slot-value slot-definition 'sys::allocation-class) value))))
3290
3291(atomic-defgeneric slot-definition-location (slot-definition)
3292  (:method ((slot-definition slot-definition))
3293    (slot-definition-dispatch slot-definition
3294      (%slot-definition-location slot-definition)
3295      (slot-value slot-definition 'sys::location))))
3296
3297(atomic-defgeneric (setf slot-definition-location) (value slot-definition)
3298  (:method (value (slot-definition slot-definition))
3299    (slot-definition-dispatch slot-definition
3300      (set-slot-definition-location slot-definition value)
3301      (setf (slot-value slot-definition 'sys::location) value))))
3302
3303;;; No %slot-definition-type.
3304
3305
3306;;; Conditions.
3307
3308(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
3309  (let ((parent-types (or parent-types '(condition)))
3310        (report nil))
3311    (dolist (option options)
3312      (when (eq (car option) :report)
3313        (setf report (cadr option))
3314  (setf options (delete option options :test #'equal))
3315        (return)))
3316    (typecase report
3317      (null
3318       `(progn
3319          (defclass ,name ,parent-types ,slot-specs ,@options)
3320          ',name))
3321      (string
3322       `(progn
3323          (defclass ,name ,parent-types ,slot-specs ,@options)
3324          (defmethod print-object ((condition ,name) stream)
3325            (if *print-escape*
3326                (call-next-method)
3327                (progn (write-string ,report stream) condition)))
3328          ',name))
3329      (t
3330       `(progn
3331          (defclass ,name ,parent-types ,slot-specs ,@options)
3332          (defmethod print-object ((condition ,name) stream)
3333            (if *print-escape*
3334                (call-next-method)
3335                (funcall #',report condition stream)))
3336          ',name)))))
3337
3338(defun make-condition (type &rest initargs)
3339  (or (%make-condition type initargs)
3340      (let ((class (if (symbolp type) (find-class type) type)))
3341        (apply #'make-instance class initargs))))
3342
3343;; Adapted from SBCL.
3344;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
3345(defun coerce-to-condition (datum arguments default-type fun-name)
3346  (cond ((typep datum 'condition)
3347         (when arguments
3348           (error 'simple-type-error
3349                  :datum arguments
3350                  :expected-type 'null
3351                  :format-control "You may not supply additional arguments when giving ~S to ~S."
3352                  :format-arguments (list datum fun-name)))
3353         datum)
3354        ((symbolp datum)
3355         (apply #'make-condition datum arguments))
3356        ((or (stringp datum) (functionp datum))
3357         (make-condition default-type
3358                         :format-control datum
3359                         :format-arguments arguments))
3360        (t
3361         (error 'simple-type-error
3362                :datum datum
3363                :expected-type '(or symbol string)
3364                :format-control "Bad argument to ~S: ~S."
3365                :format-arguments (list fun-name datum)))))
3366
3367(defgeneric make-load-form (object &optional environment))
3368
3369(defmethod make-load-form ((object t) &optional environment)
3370  (declare (ignore environment))
3371  (apply #'no-applicable-method #'make-load-form (list object)))
3372
3373(defmethod make-load-form ((class class) &optional environment)
3374  (declare (ignore environment))
3375  (let ((name (class-name class)))
3376    (unless (and name (eq (find-class name nil) class))
3377      (error 'simple-type-error
3378             :format-control "Can't use anonymous or undefined class as a constant: ~S."
3379             :format-arguments (list class)))
3380    `(find-class ',name)))
3381
3382(defun invalid-method-error (method format-control &rest args)
3383  (let ((message (apply #'format nil format-control args)))
3384    (error "Invalid method error for ~S:~%    ~A" method message)))
3385
3386(defun method-combination-error (format-control &rest args)
3387  (let ((message (apply #'format nil format-control args)))
3388    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
3389
3390
3391(atomic-defgeneric no-applicable-method (generic-function &rest args)
3392  (:method (generic-function &rest args)
3393      (error "There is no applicable method for the generic function ~S ~
3394              when called with arguments ~S."
3395             generic-function
3396             args)))
3397
3398
3399
3400(defgeneric find-method (generic-function
3401                         qualifiers
3402                         specializers
3403                         &optional errorp))
3404
3405(defmethod find-method ((generic-function standard-generic-function)
3406                        qualifiers specializers &optional (errorp t))
3407  (%find-method generic-function qualifiers specializers errorp))
3408
3409(defgeneric add-method (generic-function method))
3410
3411(defmethod add-method ((generic-function standard-generic-function)
3412                       (method method))
3413  (let ((method-lambda-list (method-lambda-list method))
3414        (gf-lambda-list (generic-function-lambda-list generic-function)))
3415    (check-method-lambda-list (%generic-function-name generic-function)
3416                              method-lambda-list gf-lambda-list))
3417  (%add-method generic-function method))
3418
3419(defgeneric remove-method (generic-function method))
3420
3421(defmethod remove-method ((generic-function standard-generic-function) method)
3422  (%remove-method generic-function method))
3423
3424;; See describe.lisp.
3425(defgeneric describe-object (object stream))
3426
3427;; FIXME
3428(defgeneric no-next-method (generic-function method &rest args))
3429
3430(atomic-defgeneric function-keywords (method)
3431  (:method ((method standard-method))
3432    (%function-keywords method)))
3433
3434(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
3435(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
3436(setf *gf-shared-initialize* (symbol-function 'shared-initialize))
3437(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))
3438(setf *clos-booting* nil)
3439
3440(defgeneric class-prototype (class))
3441
3442(defmethod class-prototype :before (class)
3443  (unless (class-finalized-p class)
3444    (error "~@<~S is not finalized.~:@>" class)))
3445
3446(defmethod class-prototype ((class standard-class))
3447  (allocate-instance class))
3448
3449(defmethod class-prototype ((class funcallable-standard-class))
3450  (allocate-instance class))
3451
3452(defmethod class-prototype ((class structure-class))
3453  (allocate-instance class))
3454
3455;;; Readers for generic function metaobjects
3456;;; See AMOP pg. 216ff.
3457(atomic-defgeneric generic-function-argument-precedence-order (generic-function)
3458  (:method ((generic-function standard-generic-function))
3459    (sys:%generic-function-argument-precedence-order generic-function)))
3460
3461(atomic-defgeneric generic-function-declarations (generic-function)
3462  (:method ((generic-function standard-generic-function))
3463    ;; TODO: add slot to StandardGenericFunctionClass.java, use it
3464    nil))
3465
3466(atomic-defgeneric generic-function-lambda-list (generic-function)
3467  (:method ((generic-function standard-generic-function))
3468    (sys:%generic-function-lambda-list generic-function)))
3469
3470(atomic-defgeneric generic-function-method-class (generic-function)
3471  (:method ((generic-function standard-generic-function))
3472    (sys:%generic-function-method-class generic-function)))
3473
3474(atomic-defgeneric generic-function-method-combination (generic-function)
3475  (:method ((generic-function standard-generic-function))
3476    (sys:%generic-function-method-combination generic-function)))
3477
3478(atomic-defgeneric generic-function-methods (generic-function)
3479  (:method ((generic-function standard-generic-function))
3480    (sys:%generic-function-methods generic-function)))
3481
3482(atomic-defgeneric generic-function-name (generic-function)
3483  (:method ((generic-function standard-generic-function))
3484    (sys:%generic-function-name generic-function)))
3485
3486(eval-when (:compile-toplevel :load-toplevel :execute)
3487  (require "MOP"))
3488
3489(provide 'clos)
3490
Note: See TracBrowser for help on using the repository browser.