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

Last change on this file since 13857 was 13857, checked in by rschlatte, 9 years ago

Enable :generic-function-class keyword.

... full ensure-class-using-class protocol not implemented yet.

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