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

Last change on this file since 13220 was 13220, checked in by ehuelsmann, 13 years ago

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