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

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

Handle metaclasses given as symbols.

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