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

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

Implement ensure-class-using-class.

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