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

Last change on this file since 14499 was 14499, checked in by rschlatte, 11 years ago

Move standard-generic-function definition into Lisp

Slightly tricky since we need to avoid redefining
standard-generic-function during compilation of abcl itself, hence
make-or-find-instance-funcallable-standard-class

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