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

Last change on this file since 13726 was 13726, checked in by ehuelsmann, 9 years ago

Patch by Rudi Schlatte: Make method combinations real classes.

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