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

Last change on this file since 13787 was 13787, checked in by ehuelsmann, 10 years ago

Implement keyword argument verification in the method invocation protocol.

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