source: trunk/j/src/org/armedbear/lisp/clos.lisp @ 5814

Last change on this file since 5814 was 5814, checked in by piso, 17 years ago

DEFMETHOD: support declarations.

File size: 73.7 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: clos.lisp,v 1.85 2004-02-14 00:20:26 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from Closette.
21
22;;; Closette Version 1.0 (February 10, 1991)
23;;;
24;;; Copyright (c) 1990, 1991 Xerox Corporation.
25;;; All rights reserved.
26;;;
27;;; Use and copying of this software and preparation of derivative works
28;;; based upon this software are permitted.  Any distribution of this
29;;; software or derivative works must comply with all applicable United
30;;; States export control laws.
31;;;
32;;; This software is made available AS IS, and Xerox Corporation makes no
33;;; warranty about the software, its performance or its conformity to any
34;;; specification.
35;;;
36;;; Closette is an implementation of a subset of CLOS with a metaobject
37;;; protocol as described in "The Art of The Metaobject Protocol",
38;;; MIT Press, 1991.
39
40(in-package "SYSTEM")
41
42(defmacro push-on-end (value location)
43  `(setf ,location (nconc ,location (list ,value))))
44
45;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
46;;; which must be non-nil.
47
48(defun (setf getf*) (new-value plist key)
49  (block body
50    (do ((x plist (cddr x)))
51        ((null x))
52      (when (eq (car x) key)
53        (setf (car (cdr x)) new-value)
54        (return-from body new-value)))
55    (push-on-end key plist)
56    (push-on-end new-value plist)
57    new-value))
58
59(defun mapappend (fun &rest args)
60  (if (some #'null args)
61      ()
62      (append (apply fun (mapcar #'car args))
63              (apply #'mapappend fun (mapcar #'cdr args)))))
64
65(defun mapplist (fun x)
66  (if (null x)
67      ()
68      (cons (funcall fun (car x) (cadr x))
69            (mapplist fun (cddr x)))))
70
71(defsetf class-layout %set-class-layout)
72(defsetf class-direct-superclasses %set-class-direct-superclasses)
73(defsetf class-direct-subclasses %set-class-direct-subclasses)
74(defsetf class-direct-methods %set-class-direct-methods)
75(defsetf class-direct-slots %set-class-direct-slots)
76(defsetf class-slots %set-class-slots)
77(defsetf class-direct-default-initargs %set-class-direct-default-initargs)
78(defsetf class-default-initargs %set-class-default-initargs)
79(defsetf class-precedence-list %set-class-precedence-list)
80(defsetf std-instance-layout %set-std-instance-layout)
81(defsetf std-instance-slots %set-std-instance-slots)
82(defsetf instance-ref %set-instance-ref)
83
84(defun (setf find-class) (new-value symbol &optional errorp environment)
85  (%set-find-class symbol new-value))
86
87(defun canonicalize-direct-slots (direct-slots)
88  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
89
90(defun canonicalize-direct-slot (spec)
91  (if (symbolp spec)
92      `(list :name ',spec)
93      (let ((name (car spec))
94            (initfunction nil)
95            (initform nil)
96            (initargs ())
97            (type nil)
98            (allocation nil)
99            (documentation nil)
100            (readers ())
101            (writers ())
102            (other-options ()))
103        (do ((olist (cdr spec) (cddr olist)))
104            ((null olist))
105          (case (car olist)
106            (:initform
107             (when initform
108               (error 'program-error
109                      "duplicate slot option :INITFORM for slot named ~S"
110                      name))
111             (setq initfunction
112                   `(function (lambda () ,(cadr olist))))
113             (setq initform `',(cadr olist)))
114            (:initarg
115             (push-on-end (cadr olist) initargs))
116            (:allocation
117             (when allocation
118               (error 'program-error
119                      "duplicate slot option :ALLOCATION for slot named ~S"
120                      name))
121             (setf allocation (cadr olist))
122             (push-on-end (car olist) other-options)
123             (push-on-end (cadr olist) other-options))
124            (:type
125             (when type
126               (error 'program-error
127                      "duplicate slot option :TYPE for slot named ~S"
128                      name))
129             (setf type (cadr olist))) ;; FIXME type is ignored
130            (:documentation
131             (when documentation
132               (error 'program-error
133                      "duplicate slot option :DOCUMENTATION for slot named ~S"
134                      name))
135             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
136            (:reader
137             (push-on-end (cadr olist) readers))
138            (:writer
139             (push-on-end (cadr olist) writers))
140            (:accessor
141             (push-on-end (cadr olist) readers)
142             (push-on-end `(setf ,(cadr olist)) writers))
143            (t
144             (error 'program-error
145                    "invalid initialization argument ~S for slot named ~S"
146                    (car olist) name))))
147        `(list
148          :name ',name
149          ,@(when initfunction
150              `(:initform ,initform
151                          :initfunction ,initfunction))
152          ,@(when initargs `(:initargs ',initargs))
153          ,@(when readers `(:readers ',readers))
154          ,@(when writers `(:writers ',writers))
155          ,@other-options))))
156
157(defun canonicalize-direct-superclasses (direct-superclasses)
158  `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses)))
159
160(defun canonicalize-direct-superclass (class-name)
161  `(find-class ',class-name))
162
163(defun canonicalize-defclass-options (options)
164  (mapappend #'canonicalize-defclass-option options))
165
166(defun canonicalize-defclass-option (option)
167  (case (car option)
168    (:metaclass
169     (list ':metaclass
170           `(find-class ',(cadr option))))
171    (:default-initargs
172     (list
173      ':direct-default-initargs
174      `(list ,@(mapappend
175                #'(lambda (x) x)
176                (mapplist
177                 #'(lambda (key value)
178                    `(',key ,(make-initfunction value)))
179                 (cdr option))))))
180    ((:documentation :report)
181     (list (car option) `',(cadr option)))
182    (t
183     (error 'program-error
184            :format-control "invalid DEFCLASS option ~S"
185            :format-arguments (list (car option))))))
186
187(defun make-initfunction (initform)
188  `(function (lambda () ,initform)))
189
190(defconstant +slot-unbound+ (make-symbol "SLOT-UNBOUND"))
191
192;;; Slot definition metaobjects
193
194(defstruct slot-definition
195  name
196  initfunction
197  initform
198  initargs
199  readers
200  writers
201  allocation
202  allocation-class
203  (location nil))
204
205(defun make-direct-slot-definition (class &rest properties
206                                          &key name
207                                          (initargs ())
208                                          (initform nil)
209                                          (initfunction nil)
210                                          (readers ())
211                                          (writers ())
212                                          (allocation :instance)
213                                          &allow-other-keys)
214  (let ((slot (make-slot-definition)))
215    (setf (slot-definition-name slot) name)
216    (setf (slot-definition-initargs slot) initargs)
217    (setf (slot-definition-initform slot) initform)
218    (setf (slot-definition-initfunction slot) initfunction)
219    (setf (slot-definition-readers slot) readers)
220    (setf (slot-definition-writers slot) writers)
221    (setf (slot-definition-allocation slot) allocation)
222    (setf (slot-definition-allocation-class slot) class)
223    slot))
224
225(defun make-effective-slot-definition (&rest properties
226                                             &key name
227                                             (initargs ())
228                                             (initform nil)
229                                             (initfunction nil)
230                                             (allocation :instance)
231                                             (allocation-class nil)
232                                             &allow-other-keys)
233  (let ((slot (make-slot-definition)))
234    (setf (slot-definition-name slot) name)
235    (setf (slot-definition-initargs slot) initargs)
236    (setf (slot-definition-initform slot) initform)
237    (setf (slot-definition-initfunction slot) initfunction)
238    (setf (slot-definition-allocation slot) allocation)
239    (setf (slot-definition-allocation-class slot) allocation-class)
240    slot))
241
242;;; finalize-inheritance
243
244(defun std-finalize-inheritance (class)
245  (setf (class-precedence-list class)
246        (funcall (if (eq (class-of class) the-class-standard-class)
247                     #'std-compute-class-precedence-list
248                     #'compute-class-precedence-list)
249                 class))
250  (setf (class-slots class)
251        (funcall (if (eq (class-of class) the-class-standard-class)
252                     #'std-compute-slots
253                     #'compute-slots)
254                 class))
255  (let ((length 0)
256        (instance-slots ()))
257    (dolist (slot (class-slots class))
258      (case (slot-definition-allocation slot)
259        (:instance
260         (setf (slot-definition-location slot) length)
261         (incf length)
262         (push (slot-definition-name slot) instance-slots))
263        (:class
264         (unless (slot-definition-location slot)
265           (let ((allocation-class (slot-definition-allocation-class slot)))
266             (setf (slot-definition-location slot)
267                   (if (eq class allocation-class)
268                       (cons (slot-definition-name slot) +slot-unbound+)
269                       (slot-location allocation-class (slot-definition-name slot)))))))))
270    (setf (class-layout class)
271          (make-layout class length (nreverse instance-slots))))
272  (setf (class-default-initargs class)
273        (compute-class-default-initargs class)))
274
275(defun compute-class-default-initargs (class)
276  (mapappend #'class-direct-default-initargs
277             (class-precedence-list class)))
278
279;;; Class precedence lists
280
281(defun std-compute-class-precedence-list (class)
282  (let ((classes-to-order (collect-superclasses* class)))
283    (topological-sort classes-to-order
284                      (remove-duplicates
285                       (mapappend #'local-precedence-ordering
286                                  classes-to-order))
287                      #'std-tie-breaker-rule)))
288
289;;; topological-sort implements the standard algorithm for topologically
290;;; sorting an arbitrary set of elements while honoring the precedence
291;;; constraints given by a set of (X,Y) pairs that indicate that element
292;;; X must precede element Y.  The tie-breaker procedure is called when it
293;;; is necessary to choose from multiple minimal elements; both a list of
294;;; candidates and the ordering so far are provided as arguments.
295
296(defun topological-sort (elements constraints tie-breaker)
297  (let ((remaining-constraints constraints)
298        (remaining-elements elements)
299        (result ()))
300    (loop
301      (let ((minimal-elements
302             (remove-if
303              #'(lambda (class)
304                 (member class remaining-constraints
305                         :key #'cadr))
306              remaining-elements)))
307        (when (null minimal-elements)
308          (if (null remaining-elements)
309              (return-from topological-sort result)
310              (error "Inconsistent precedence graph.")))
311        (let ((choice (if (null (cdr minimal-elements))
312                          (car minimal-elements)
313                          (funcall tie-breaker
314                                   minimal-elements
315                                   result))))
316          (setq result (append result (list choice)))
317          (setq remaining-elements
318                (remove choice remaining-elements))
319          (setq remaining-constraints
320                (remove choice
321                        remaining-constraints
322                        :test #'member)))))))
323
324;;; In the event of a tie while topologically sorting class precedence lists,
325;;; the CLOS Specification says to "select the one that has a direct subclass
326;;; rightmost in the class precedence list computed so far."  The same result
327;;; is obtained by inspecting the partially constructed class precedence list
328;;; from right to left, looking for the first minimal element to show up among
329;;; the direct superclasses of the class precedence list constituent.
330;;; (There's a lemma that shows that this rule yields a unique result.)
331
332(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
333  (dolist (cpl-constituent (reverse cpl-so-far))
334    (let* ((supers (class-direct-superclasses cpl-constituent))
335           (common (intersection minimal-elements supers)))
336      (when (not (null common))
337        (return-from std-tie-breaker-rule (car common))))))
338
339;;; This version of collect-superclasses* isn't bothered by cycles in the class
340;;; hierarchy, which sometimes happen by accident.
341
342(defun collect-superclasses* (class)
343  (labels ((all-superclasses-loop (seen superclasses)
344                                  (let ((to-be-processed
345                                         (set-difference superclasses seen)))
346                                    (if (null to-be-processed)
347                                        superclasses
348                                        (let ((class-to-process
349                                               (car to-be-processed)))
350                                          (all-superclasses-loop
351                                           (cons class-to-process seen)
352                                           (union (class-direct-superclasses
353                                                   class-to-process)
354                                                  superclasses)))))))
355          (all-superclasses-loop () (list class))))
356
357;;; The local precedence ordering of a class C with direct superclasses C_1,
358;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
359
360(defun local-precedence-ordering (class)
361  (mapcar #'list
362          (cons class
363                (butlast (class-direct-superclasses class)))
364          (class-direct-superclasses class)))
365
366;;; Slot inheritance
367
368(defun std-compute-slots (class)
369  (let* ((all-slots (mapappend #'class-direct-slots
370                               (class-precedence-list class)))
371         (all-names (remove-duplicates
372                     (mapcar #'slot-definition-name all-slots))))
373    (mapcar #'(lambda (name)
374               (funcall
375                (if (eq (class-of class) the-class-standard-class)
376                    #'std-compute-effective-slot-definition
377                    #'compute-effective-slot-definition)
378                class
379                (remove name all-slots
380                        :key #'slot-definition-name
381                        :test-not #'eq)))
382            all-names)))
383
384(defun std-compute-effective-slot-definition (class direct-slots)
385  (declare (ignore class))
386  (let ((initer (find-if-not #'null direct-slots
387                             :key #'slot-definition-initfunction)))
388    (make-effective-slot-definition
389     :name (slot-definition-name (car direct-slots))
390     :initform (if initer
391                   (slot-definition-initform initer)
392                   nil)
393     :initfunction (if initer
394                       (slot-definition-initfunction initer)
395                       nil)
396     :initargs (remove-duplicates
397                (mapappend #'slot-definition-initargs
398                           direct-slots))
399     :allocation (slot-definition-allocation (car direct-slots))
400     :allocation-class (slot-definition-allocation-class (car direct-slots)))))
401
402;;; Standard instance slot access
403
404;;; N.B. The location of the effective-slots slots in the class metaobject for
405;;; standard-class must be determined without making any further slot
406;;; references.
407
408(defvar the-slots-of-standard-class) ;standard-class's class-slots
409(defvar the-class-standard-class (find-class 'standard-class))
410
411(defun find-slot-definition (class slot-name)
412  (dolist (slot (class-slots class) nil)
413    (when (eq slot-name (slot-definition-name slot))
414      (return slot))))
415
416(defun slot-location (class slot-name)
417  (let ((slot (find-slot-definition class slot-name)))
418    (if slot
419        (slot-definition-location slot)
420        nil)))
421
422(defun instance-slot-location (instance slot-name)
423  (let* ((layout (std-instance-layout instance))
424         (location (and layout (instance-slot-index layout slot-name))))
425    (if location
426        location
427        (slot-location (class-of instance) slot-name))))
428
429(defun std-slot-value (instance slot-name)
430  (let* ((location (instance-slot-location instance slot-name))
431         (value (cond ((fixnump location)
432                       (instance-ref instance location))
433                      ((consp location)
434                       (cdr location))
435                      (t
436                       (slot-missing (class-of instance) instance slot-name 'slot-value)))))
437    (if (eq +slot-unbound+ value)
438        (slot-unbound (class-of instance) instance slot-name)
439        value)))
440
441(defun slot-value (object slot-name)
442  (if (eq (class-of (class-of object)) the-class-standard-class)
443      (std-slot-value object slot-name)
444      (slot-value-using-class (class-of object) object slot-name)))
445
446(defun %set-std-slot-value (instance slot-name new-value)
447  (let ((location (instance-slot-location instance slot-name)))
448    (cond ((fixnump location)
449           (setf (instance-ref instance location) new-value))
450          ((consp location)
451           (setf (cdr location) new-value))
452          (t
453           (slot-missing (class-of instance) instance slot-name 'setf new-value))))
454  new-value)
455
456(defsetf std-slot-value %set-std-slot-value)
457
458(defun (setf slot-value) (new-value object slot-name)
459  (if (eq (class-of (class-of object)) the-class-standard-class)
460      (setf (std-slot-value object slot-name) new-value)
461      (setf-slot-value-using-class
462       new-value (class-of object) object slot-name)))
463
464(defun std-slot-boundp (instance slot-name)
465  (let ((location (instance-slot-location instance slot-name)))
466    (cond ((fixnump location)
467           (neq +slot-unbound+ (instance-ref instance location)))
468          ((consp location)
469           (neq +slot-unbound+ (cdr location)))
470          (t
471           (not (null (slot-missing (class-of instance) instance slot-name 'slot-boundp)))))))
472
473(defun slot-boundp (object slot-name)
474  (if (eq (class-of (class-of object)) the-class-standard-class)
475      (std-slot-boundp object slot-name)
476      (slot-boundp-using-class (class-of object) object slot-name)))
477
478(defun std-slot-makunbound (instance slot-name)
479  (let ((location (instance-slot-location instance slot-name)))
480    (cond ((fixnump location)
481           (setf (instance-ref instance location) +slot-unbound+))
482          ((consp location)
483           (setf (cdr location) +slot-unbound+))
484          (t
485           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
486  instance)
487
488(defun slot-makunbound (object slot-name)
489  (if (eq (class-of (class-of object)) the-class-standard-class)
490      (std-slot-makunbound object slot-name)
491      (slot-makunbound-using-class (class-of object) object slot-name)))
492
493(defun std-slot-exists-p (instance slot-name)
494  (not (null (find slot-name (class-slots (class-of instance))
495                   :key #'slot-definition-name))))
496
497(defun slot-exists-p (object slot-name)
498  (if (eq (class-of (class-of object)) the-class-standard-class)
499      (std-slot-exists-p object slot-name)
500      (slot-exists-p-using-class (class-of object) object slot-name)))
501
502(defun instance-slot-p (slot)
503  (eq (slot-definition-allocation slot) :instance))
504
505(defun std-allocate-instance (class)
506  (let* ((layout (class-layout class))
507         (length (and layout (layout-length layout))))
508    (unless layout
509      (format t "no layout for class ~S~%" class)
510      (backtrace))
511    (unless length
512      (format t "no layout length for class ~S~%" class)
513      (setf length (count-if #'instance-slot-p (class-slots class))))
514    (allocate-std-instance class
515                           (allocate-slot-storage length +slot-unbound+))))
516
517(defun make-instance-standard-class (metaclass
518                                     &key name direct-superclasses direct-slots
519                                     direct-default-initargs
520                                     documentation
521                                     &allow-other-keys)
522  (declare (ignore metaclass))
523  (let ((class (std-allocate-instance (find-class 'standard-class))))
524    (%set-class-name class name)
525    (setf (class-direct-subclasses class) ())
526    (setf (class-direct-methods class) ())
527    (%set-class-documentation class documentation)
528    (std-after-initialization-for-classes class
529                                          :direct-superclasses direct-superclasses
530                                          :direct-slots direct-slots
531                                          :direct-default-initargs direct-default-initargs)
532    class))
533
534(defun std-after-initialization-for-classes (class
535                                             &key direct-superclasses direct-slots
536                                             direct-default-initargs
537                                             &allow-other-keys)
538  (let ((supers (or direct-superclasses
539                    (list (find-class 'standard-object)))))
540    (setf (class-direct-superclasses class) supers)
541    (dolist (superclass supers)
542      (push class (class-direct-subclasses superclass))))
543  (let ((slots (mapcar #'(lambda (slot-properties)
544                          (apply #'make-direct-slot-definition class slot-properties))
545                       direct-slots)))
546    (setf (class-direct-slots class) slots)
547    (dolist (direct-slot slots)
548      (dolist (reader (slot-definition-readers direct-slot))
549        (add-reader-method
550         class reader (slot-definition-name direct-slot)))
551      (dolist (writer (slot-definition-writers direct-slot))
552        (add-writer-method
553         class writer (slot-definition-name direct-slot)))))
554  (setf (class-direct-default-initargs class) direct-default-initargs)
555  (funcall (if (eq (class-of class) (find-class 'standard-class))
556               #'std-finalize-inheritance
557               #'finalize-inheritance)
558           class)
559  (values))
560
561(defun canonical-slot-name (canonical-slot)
562  (getf canonical-slot :name))
563
564(defun ensure-class (name &rest all-keys &allow-other-keys)
565  ;; Check for duplicate slots.
566  (let ((slots (getf all-keys :direct-slots)))
567    (dolist (s1 slots)
568      (let ((name1 (canonical-slot-name s1)))
569        (dolist (s2 (cdr (memq s1 slots)))
570    (when (eq name1 (canonical-slot-name s2))
571            (error 'program-error "duplicate slot ~S" name1))))))
572  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
573  (let ((names ()))
574    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
575          (name (car initargs) (car initargs)))
576         ((null initargs))
577      (push name names))
578    (do* ((names names (cdr names))
579          (name (car names) (car names)))
580         ((null names))
581      (when (memq name (cdr names))
582        (error 'program-error
583               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
584               :format-arguments (list name)))))
585  (let ((class (find-class name nil)))
586    (unless class
587      (setf class (apply #'make-instance-standard-class (find-class 'standard-class)
588                         :name name all-keys))
589      (%set-find-class name class))
590    class))
591
592(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
593  (unless (>= (length form) 3)
594    (error 'program-error "Wrong number of arguments for DEFCLASS."))
595  `(ensure-class ',name
596                 :direct-superclasses
597                 ,(canonicalize-direct-superclasses direct-superclasses)
598                 :direct-slots
599                 ,(canonicalize-direct-slots direct-slots)
600                 ,@(canonicalize-defclass-options options)))
601
602(defstruct method-combination
603  name
604  operator
605  identity-with-one-argument
606  documentation)
607
608(defmacro define-method-combination (&whole form &rest args)
609  (declare (ignore args))
610  (if (and (cddr form)
611           (listp (caddr form)))
612      (expand-long-defcombin form)
613      (expand-short-defcombin form)))
614
615(defun expand-short-defcombin (whole)
616  (let* ((name (cadr whole))
617   (documentation
618          (getf (cddr whole) :documentation ""))
619   (identity-with-one-arg
620          (getf (cddr whole) :identity-with-one-argument nil))
621   (operator
622          (getf (cddr whole) :operator name)))
623    `(progn
624       (setf (get ',name 'method-combination-object)
625             (make-method-combination :name ',name
626                                      :operator ',operator
627                                      :identity-with-one-argument ',identity-with-one-arg
628                                      :documentation ',documentation))
629       ',name)))
630
631(defun expand-long-defcombin (whole)
632  (error "The long form of DEFINE-METHOD-COMBINATION is not yet supported."))
633
634(define-method-combination +      :identity-with-one-argument t)
635(define-method-combination and    :identity-with-one-argument t)
636(define-method-combination append :identity-with-one-argument nil)
637(define-method-combination list   :identity-with-one-argument nil)
638(define-method-combination max    :identity-with-one-argument t)
639(define-method-combination min    :identity-with-one-argument t)
640(define-method-combination nconc  :identity-with-one-argument t)
641(define-method-combination or     :identity-with-one-argument t)
642(define-method-combination progn  :identity-with-one-argument t)
643
644(defstruct eql-specializer
645  object)
646
647(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
648
649(defun intern-eql-specializer (object)
650  (or (gethash object *eql-specializer-table*)
651      (setf (gethash object *eql-specializer-table*)
652      (make-eql-specializer :object object))))
653
654(defclass standard-generic-function (generic-function)
655  ((name :initarg :name)      ; :accessor generic-function-name
656   (lambda-list               ; :accessor generic-function-lambda-list
657    :initarg :lambda-list)
658   (documentation
659    :initarg :documentation)  ; :accessor generic-function-documentation
660   (methods :initform ())     ; :accessor generic-function-methods
661   (method-class              ; :accessor generic-function-method-class
662    :initarg :method-class)
663   ;; The method-combination slot contains either the name of the method
664   ;; combination type or a list whose car is the name of the method
665   ;; combination type and whose cdr is a list of options.
666   (method-combination
667    :initarg :method-combination)
668   (argument-precedence-order
669    :initarg :argument-precedence-order)
670   (classes-to-emf-table      ; :accessor classes-to-emf-table
671    :initform (make-hash-table :test #'equal))
672   (required-args :initform ())))
673
674(defvar the-class-standard-gf (find-class 'standard-generic-function))
675
676(defvar *sgf-required-args-index*
677  (slot-location the-class-standard-gf 'required-args))
678
679(defvar *sgf-classes-to-emf-table-index*
680  (slot-location the-class-standard-gf 'classes-to-emf-table))
681
682(defun generic-function-name (gf)
683  (slot-value gf 'name))
684(defun (setf generic-function-name) (new-value gf)
685  (setf (slot-value gf 'name) new-value))
686
687(defun generic-function-lambda-list (gf)
688  (slot-value gf 'lambda-list))
689(defun (setf generic-function-lambda-list) (new-value gf)
690  (setf (slot-value gf 'lambda-list) new-value))
691
692(defun generic-function-documentation (gf)
693  (slot-value gf 'documentation))
694(defun (setf generic-function-documentation) (new-value gf)
695  (setf (slot-value gf 'documentation) new-value))
696
697(defun generic-function-methods (gf)
698  (slot-value gf 'methods))
699(defun (setf generic-function-methods) (new-value gf)
700  (setf (slot-value gf 'methods) new-value))
701
702(defsetf generic-function-discriminating-function
703  %set-generic-function-discriminating-function)
704
705(defun generic-function-method-class (gf)
706  (slot-value gf 'method-class))
707(defun (setf generic-function-method-class) (new-value gf)
708  (setf (slot-value gf 'method-class) new-value))
709
710(defun generic-function-method-combination (gf)
711  (slot-value gf 'method-combination))
712(defun (setf generic-function-method-combination) (new-value gf)
713  (setf (slot-value gf 'method-combination) new-value))
714
715(defun generic-function-argument-precedence-order (gf)
716  (slot-value gf 'argument-precedence-order))
717(defun (setf generic-function-argument-precedence-order) (new-value gf)
718  (setf (slot-value gf 'argument-precedence-order) new-value))
719
720;;; Internal accessor for effective method function table
721
722(defun classes-to-emf-table (gf)
723  (instance-ref gf *sgf-classes-to-emf-table-index*))
724
725(defun (setf classes-to-emf-table) (new-value gf)
726  (setf (slot-value gf 'classes-to-emf-table) new-value))
727
728;;; Method metaobjects and standard-method
729
730(defclass standard-method (method)
731  ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
732   (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
733   (specializers :initarg :specializers)   ; :accessor method-specializers
734   (declarations :initarg :declarations)   ; :accessir method-declarations
735   (body :initarg :body)                   ; :accessor method-body
736   (environment :initarg :environment)     ; :accessor method-environment
737   (generic-function :initform nil)        ; :accessor method-generic-function
738   (function)                              ; :accessor method-function
739   (documentation)))                       ; :accessor method-documentation
740
741(defvar the-class-standard-method (find-class 'standard-method))
742
743(defvar *sm-function-index*
744  (slot-location the-class-standard-method 'function))
745
746(defun method-lambda-list (method) (slot-value method 'lambda-list))
747(defun (setf method-lambda-list) (new-value method)
748  (setf (slot-value method 'lambda-list) new-value))
749
750(defun method-qualifiers (method) (slot-value method 'qualifiers))
751(defun (setf method-qualifiers) (new-value method)
752  (setf (slot-value method 'qualifiers) new-value))
753
754(defun method-specializers (method) (slot-value method 'specializers))
755(defun (setf method-specializers) (new-value method)
756  (setf (slot-value method 'specializers) new-value))
757
758(defun method-declarations (method) (slot-value method 'declarations))
759(defun (setf method-declarations) (new-value method)
760  (setf (slot-value method 'declarations) new-value))
761
762(defun method-body (method) (slot-value method 'body))
763(defun (setf method-body) (new-value method)
764  (setf (slot-value method 'body) new-value))
765
766(defun method-environment (method) (slot-value method 'environment))
767(defun (setf method-environment) (new-value method)
768  (setf (slot-value method 'environment) new-value))
769
770(defun method-generic-function (method)
771  (slot-value method 'generic-function))
772(defun (setf method-generic-function) (new-value method)
773  (setf (slot-value method 'generic-function) new-value))
774
775(defun method-function (method)
776  (instance-ref method *sm-function-index*))
777
778(defun (setf method-function) (new-value method)
779  (setf (slot-value method 'function) new-value))
780
781(defun method-documentation (method)
782  (slot-value method 'documentation))
783
784(defun (setf method-documentation) (new-value method)
785  (setf (slot-value method 'documentation) new-value))
786
787;;; defgeneric
788
789(defmacro defgeneric (function-name lambda-list
790                                    &rest options-and-method-descriptions)
791  (let ((options ())
792        (methods ())
793        (documentation nil))
794    (dolist (item options-and-method-descriptions)
795      (case (car item)
796        (declare) ; FIXME
797        (:documentation
798         (when documentation
799           (error 'program-error
800                  :format-control "Documentation option was specified twice for generic function ~S."
801                  :format-arguments (list function-name)))
802         (setf documentation t)
803         (push item options))
804        (:method
805         (push `(defmethod ,function-name ,@(cdr item)) methods))
806        (t
807         (push item options))))
808    (setf options (nreverse options)
809          methods (nreverse methods))
810    `(prog1
811       (ensure-generic-function
812        ',function-name
813        :lambda-list ',lambda-list
814        ,@(canonicalize-defgeneric-options options))
815       ,@methods)))
816
817(defun canonicalize-defgeneric-options (options)
818  (mapappend #'canonicalize-defgeneric-option options))
819
820(defun canonicalize-defgeneric-option (option)
821  (case (car option)
822    (:generic-function-class
823     (list :generic-function-class `(find-class ',(cadr option))))
824    (:method-class
825     (list :method-class `(find-class ',(cadr option))))
826    (:method-combination
827     (list :method-combination `',(cdr option)))
828    (:argument-precedence-order
829     (list :argument-precedence-order `',(cdr option)))
830    (t
831     (list `',(car option) `',(cadr option)))))
832
833;; From OpenMCL.
834(defun canonicalize-argument-precedence-order (apo req)
835  (cond ((equal apo req) nil)
836        ((not (eql (length apo) (length req)))
837         (error 'program-error
838                :format-control "Specified argument precedence order ~S does not match lambda list."
839                :format-arguments (list apo)))
840        (t (let ((res nil))
841             (dolist (arg apo (nreverse res))
842               (let ((index (position arg req)))
843                 (if (or (null index) (memq index res))
844                     (error 'program-error
845                            :format-control "Specified argument precedence order ~S does not match lambda list."
846                            :format-arguments (list apo)))
847                 (push index res)))))))
848
849(defparameter generic-function-table (make-hash-table :test #'equal))
850
851;; FIXME Do we still need this?
852(defun find-generic-function (symbol &optional (errorp t))
853  (let ((gf (gethash symbol generic-function-table nil)))
854    (if (and (null gf) errorp)
855        (error "no generic function named ~S" symbol)
856        gf)))
857
858(defun (setf find-generic-function) (new-value symbol)
859  (setf (gethash symbol generic-function-table) new-value))
860
861(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
862  (let* ((plist1 (analyze-lambda-list lambda-list1))
863         (args1 (getf plist1 :required-args))
864         (plist2 (analyze-lambda-list lambda-list2))
865         (args2 (getf plist2 :required-args)))
866    (= (length args1) (length args2))))
867
868(defun ensure-generic-function (function-name
869                                &rest all-keys
870                                &key
871                                lambda-list
872                                (generic-function-class the-class-standard-gf)
873                                (method-class the-class-standard-method)
874                                (method-combination 'standard)
875                                documentation
876                                &allow-other-keys)
877  (when (autoloadp function-name)
878    (resolve function-name))
879  (let ((gf (find-generic-function function-name nil)))
880    (if gf
881        (progn
882          (unless (or (null (generic-function-methods gf))
883                      (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
884            (error 'simple-error
885                   :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
886                   :format-arguments (list lambda-list gf)))
887          (setf (generic-function-lambda-list gf) lambda-list)
888          (setf (generic-function-documentation gf) documentation)
889          gf)
890        (progn
891          (when (fboundp function-name)
892            (error 'program-error
893                   :format-control "~A already names an ordinary function, macro, or special operator."
894                   :format-arguments (list function-name)))
895          (setf gf (apply (if (eq generic-function-class the-class-standard-gf)
896                              #'make-instance-standard-generic-function
897                              #'make-instance)
898                          generic-function-class
899                          :name function-name
900                          :method-class method-class
901                          :method-combination method-combination
902                          all-keys))
903          (setf (find-generic-function function-name) gf)
904          gf))))
905
906(defun finalize-generic-function (gf)
907  (setf (generic-function-discriminating-function gf)
908        (funcall (if (eq (class-of gf) the-class-standard-gf)
909                     #'std-compute-discriminating-function
910                     #'compute-discriminating-function)
911                 gf))
912  (setf (fdefinition (generic-function-name gf)) gf)
913  (clrhash (classes-to-emf-table gf))
914  (values))
915
916(defun gf-required-args (gf)
917  (instance-ref gf *sgf-required-args-index*))
918
919(defun make-instance-standard-generic-function (generic-function-class
920                                                &key name lambda-list
921                                                method-class
922                                                method-combination
923                                                argument-precedence-order
924                                                documentation)
925  (declare (ignore generic-function-class))
926  (let ((gf (std-allocate-instance the-class-standard-gf)))
927    (setf (generic-function-name gf) name)
928    (setf (generic-function-lambda-list gf) lambda-list)
929    (setf (generic-function-methods gf) ())
930    (setf (generic-function-method-class gf) method-class)
931    (setf (generic-function-method-combination gf) method-combination)
932    (setf (generic-function-documentation gf) documentation)
933    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
934    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
935           (required-args (getf plist ':required-args)))
936      (setf (slot-value gf 'required-args) required-args)
937      (setf (slot-value gf 'argument-precedence-order)
938            (if argument-precedence-order
939                (canonicalize-argument-precedence-order argument-precedence-order
940                                                        required-args)
941                nil)))
942    (finalize-generic-function gf)
943    gf))
944
945;;; Run-time environment hacking (Common Lisp ain't got 'em).
946
947(defun top-level-environment ()
948  nil) ; Bogus top level lexical environment
949
950(defvar compile-methods nil)      ; by default, run everything interpreted
951
952(defun compile-in-lexical-environment (env lambda-expr)
953  (declare (ignore env))
954  (if compile-methods
955      (compile nil lambda-expr)
956      (eval `(function ,lambda-expr))))
957
958(defmacro defmethod (&rest args)
959  (multiple-value-bind
960    (function-name qualifiers lambda-list specializers documentation declarations body)
961    (parse-defmethod args)
962    `(progn
963       (unless (find-generic-function ',function-name nil)
964         (ensure-generic-function
965          ',function-name
966          :lambda-list ',lambda-list))
967       (ensure-method (find-generic-function ',function-name)
968                      :lambda-list ',lambda-list
969                      :qualifiers ',qualifiers
970                      :specializers ',specializers
971                      :documentation ,documentation
972                      :declarations ',declarations
973                      :body ',body
974                      :environment (top-level-environment)))))
975
976(defun canonicalize-specializers (specializers)
977  (mapcar #'canonicalize-specializer specializers))
978
979(defun canonicalize-specializer (specializer)
980  (cond ((classp specializer)
981         specializer)
982        ((eql-specializer-p specializer)
983         specializer)
984        ((symbolp specializer)
985         (find-class specializer))
986        ((and (consp specializer)
987              (eq (car specializer) 'eql))
988         (let ((object (cadr specializer)))
989           (when (and (consp object)
990                      (eq (car object) 'quote))
991             (setf object (cadr object)))
992           (intern-eql-specializer object)))
993        (t
994         (error "Unknown specializer: ~S~%." specializer))))
995
996(defun parse-defmethod (args)
997  (let ((function-name (car args))
998        (qualifiers ())
999        (specialized-lambda-list ())
1000        (specializers ())
1001        (body ())
1002        (parse-state :qualifiers))
1003    (dolist (arg (cdr args))
1004      (ecase parse-state
1005        (:qualifiers
1006         (if (and (atom arg) (not (null arg)))
1007             (push-on-end arg qualifiers)
1008             (progn (setf specialized-lambda-list arg)
1009               (setf parse-state :body))))
1010        (:body (push-on-end arg body))))
1011    (setf specializers
1012          (canonicalize-specializers (extract-specializers specialized-lambda-list)))
1013    (multiple-value-bind (real-body declarations documentation)
1014      (parse-body body)
1015        (values function-name
1016                qualifiers
1017                (extract-lambda-list specialized-lambda-list)
1018                specializers
1019                documentation
1020                declarations
1021                (list* 'block
1022                         (if (consp function-name)
1023                             (cadr function-name)
1024                             function-name)
1025                         real-body)))))
1026
1027(defun required-portion (gf args)
1028  (let ((number-required (length (gf-required-args gf))))
1029    (when (< (length args) number-required)
1030      (error 'program-error
1031             :format-control "Not enough arguments for generic function ~S."
1032             :format-arguments (list gf)))
1033    (subseq args 0 number-required)))
1034
1035(defun extract-lambda-list (specialized-lambda-list)
1036  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1037         (requireds (getf plist :required-names))
1038         (rv (getf plist :rest-var))
1039         (ks (getf plist :key-args))
1040         (keysp (getf plist :keysp))
1041         (aok (getf plist :allow-other-keys))
1042         (opts (getf plist :optional-args))
1043         (auxs (getf plist :auxiliary-args)))
1044    `(,@requireds
1045      ,@(if rv `(&rest ,rv) ())
1046      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1047      ,@(if aok '(&allow-other-keys) ())
1048      ,@(if opts `(&optional ,@opts) ())
1049      ,@(if auxs `(&aux ,@auxs) ()))))
1050
1051(defun extract-specializers (specialized-lambda-list)
1052  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1053    (getf plist ':specializers)))
1054
1055(defun analyze-lambda-list (lambda-list)
1056  (labels ((make-keyword (symbol)
1057                         (intern (symbol-name symbol)
1058                                 (find-package 'keyword)))
1059           (get-keyword-from-arg (arg)
1060                                 (if (listp arg)
1061                                     (if (listp (car arg))
1062                                         (caar arg)
1063                                         (make-keyword (car arg)))
1064                                     (make-keyword arg))))
1065          (let ((keys ())           ; Just the keywords
1066                (key-args ())       ; Keywords argument specs
1067                (keysp nil)         ;
1068                (required-names ()) ; Just the variable names
1069                (required-args ())  ; Variable names & specializers
1070                (specializers ())   ; Just the specializers
1071                (rest-var nil)
1072                (optionals ())
1073                (auxs ())
1074                (allow-other-keys nil)
1075                (state :parsing-required))
1076            (dolist (arg lambda-list)
1077              (if (member arg lambda-list-keywords)
1078                  (ecase arg
1079                    (&optional
1080                     (setq state :parsing-optional))
1081                    (&rest
1082                     (setq state :parsing-rest))
1083                    (&key
1084                     (setq keysp t)
1085                     (setq state :parsing-key))
1086                    (&allow-other-keys
1087                     (setq allow-other-keys 't))
1088                    (&aux
1089                     (setq state :parsing-aux)))
1090                  (case state
1091                    (:parsing-required
1092                     (push-on-end arg required-args)
1093                     (if (listp arg)
1094                         (progn (push-on-end (car arg) required-names)
1095                           (push-on-end (cadr arg) specializers))
1096                         (progn (push-on-end arg required-names)
1097                           (push-on-end 't specializers))))
1098                    (:parsing-optional (push-on-end arg optionals))
1099                    (:parsing-rest (setq rest-var arg))
1100                    (:parsing-key
1101                     (push-on-end (get-keyword-from-arg arg) keys)
1102                     (push-on-end arg key-args))
1103                    (:parsing-aux (push-on-end arg auxs)))))
1104            (list  :required-names required-names
1105                   :required-args required-args
1106                   :specializers specializers
1107                   :rest-var rest-var
1108                   :keywords keys
1109                   :key-args key-args
1110                   :keysp keysp
1111                   :auxiliary-args auxs
1112                   :optional-args optionals
1113                   :allow-other-keys allow-other-keys))))
1114
1115#+nil
1116(defun check-method-arg-info (gf arg-info method)
1117  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1118    (analyze-lambda-list (if (consp method)
1119                             (early-method-lambda-list method)
1120                             (method-lambda-list method)))
1121    (flet ((lose (string &rest args)
1122                 (error 'simple-program-error
1123                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1124                        to the generic function~2I~_~S;~I~_~
1125                        but ~?~:>"
1126                        :format-arguments (list method gf string args)))
1127     (comparison-description (x y)
1128                                   (if (> x y) "more" "fewer")))
1129      (let ((gf-nreq (arg-info-number-required arg-info))
1130      (gf-nopt (arg-info-number-optional arg-info))
1131      (gf-key/rest-p (arg-info-key/rest-p arg-info))
1132      (gf-keywords (arg-info-keys arg-info)))
1133  (unless (= nreq gf-nreq)
1134    (lose
1135     "the method has ~A required arguments than the generic function."
1136     (comparison-description nreq gf-nreq)))
1137  (unless (= nopt gf-nopt)
1138    (lose
1139     "the method has ~A optional arguments than the generic function."
1140     (comparison-description nopt gf-nopt)))
1141  (unless (eq (or keysp restp) gf-key/rest-p)
1142    (lose
1143     "the method and generic function differ in whether they accept~_~
1144      &REST or &KEY arguments."))
1145  (when (consp gf-keywords)
1146    (unless (or (and restp (not keysp))
1147          allow-other-keys-p
1148          (every (lambda (k) (memq k keywords)) gf-keywords))
1149      (lose "the method does not accept each of the &KEY arguments~2I~_~
1150            ~S."
1151      gf-keywords)))))))
1152
1153(defun check-method-lambda-list (method-lambda-list gf-lambda-list)
1154  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1155         (gf-plist (analyze-lambda-list gf-lambda-list))
1156         (gf-keysp (getf gf-plist :keysp))
1157         (gf-keywords (getf gf-plist :keywords))
1158         (method-plist (analyze-lambda-list method-lambda-list))
1159         (method-restp (not (null (memq '&rest method-lambda-list))))
1160         (method-keysp (getf method-plist :keysp))
1161         (method-keywords (getf method-plist :keywords))
1162         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1163    (unless (= (length (getf gf-plist :required-args))
1164               (length (getf method-plist :required-args)))
1165      (error "The method has the wrong number of required arguments for the generic function."))
1166    (unless (= (length (getf gf-plist :optional-args))
1167               (length (getf method-plist :optional-args)))
1168      (error "The method has the wrong number of optional arguments for the generic function."))
1169    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1170      (error "The method and the generic function differ in whether they accept &REST or &KEY arguments."))
1171    (when (consp gf-keywords)
1172      (unless (or (and method-restp (not method-keysp))
1173                  method-allow-other-keys-p
1174                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1175        (error "The method does not accept all of the keyword arguments defined for the generic function.")))))
1176
1177(defun ensure-method (gf &rest all-keys)
1178  (let ((method-lambda-list (getf all-keys :lambda-list))
1179        (gf-lambda-list (generic-function-lambda-list gf)))
1180    (check-method-lambda-list method-lambda-list gf-lambda-list))
1181  (let ((method
1182         (apply
1183          (if (eq (generic-function-method-class gf) the-class-standard-method)
1184              #'make-instance-standard-method
1185              #'make-instance)
1186          (generic-function-method-class gf)
1187          all-keys)))
1188    (%add-method gf method)
1189    method))
1190
1191(defun make-instance-standard-method (method-class
1192                                      &key
1193                                      lambda-list qualifiers specializers
1194                                      documentation declarations body
1195                                      environment)
1196  (declare (ignore method-class))
1197  (let ((method (std-allocate-instance the-class-standard-method)))
1198    (setf (method-lambda-list method) lambda-list)
1199    (setf (method-qualifiers method) qualifiers)
1200    (setf (method-specializers method) specializers)
1201    (setf (method-documentation method) documentation)
1202    (setf (method-declarations method) declarations)
1203    (setf (method-body method) (precompile-form body nil))
1204    (setf (method-environment method) environment)
1205    (setf (method-generic-function method) nil)
1206    (setf (method-function method) (std-compute-method-function method))
1207    method))
1208
1209(defun add-method (gf method)
1210  (let ((method-lambda-list (method-lambda-list method))
1211        (gf-lambda-list (generic-function-lambda-list gf)))
1212    (check-method-lambda-list method-lambda-list gf-lambda-list))
1213  (%add-method gf method))
1214
1215(defun %add-method (gf method)
1216  (when (method-generic-function method)
1217    (error 'simple-error
1218           :format-control "ADD-METHOD: ~S is a method of ~S."
1219           :format-arguments (list method (method-generic-function method))))
1220  ;; Remove existing method with same qualifiers and specializers (if any).
1221  (let ((old-method (find-method gf (method-qualifiers method)
1222                                 (method-specializers method) nil)))
1223    (when old-method
1224      (remove-method gf old-method)))
1225  (setf (method-generic-function method) gf)
1226  (push method (generic-function-methods gf))
1227  (dolist (specializer (method-specializers method))
1228    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1229      (pushnew method (class-direct-methods specializer))))
1230  (finalize-generic-function gf)
1231  gf)
1232
1233(defun remove-method (gf method)
1234  (setf (generic-function-methods gf)
1235        (remove method (generic-function-methods gf)))
1236  (setf (method-generic-function method) nil)
1237  (dolist (specializer (method-specializers method))
1238    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1239      (setf (class-direct-methods specializer)
1240            (remove method (class-direct-methods specializer)))))
1241  (finalize-generic-function gf)
1242  gf)
1243
1244(defun find-method (gf qualifiers specializers &optional (errorp t))
1245  (let* ((canonical-specializers (canonicalize-specializers specializers))
1246         (method
1247          (find-if #'(lambda (method)
1248                      (and (equal qualifiers
1249                                  (method-qualifiers method))
1250                           (equal canonical-specializers
1251                                  (method-specializers method))))
1252                   (generic-function-methods gf))))
1253    (if (and (null method) errorp)
1254        (error "No such method for ~S." (generic-function-name gf))
1255        method)))
1256
1257;;; Reader and writer methods
1258
1259(defun add-reader-method (class fn-name slot-name)
1260  (ensure-method
1261   (ensure-generic-function fn-name :lambda-list '(object))
1262   :lambda-list '(object)
1263   :qualifiers ()
1264   :specializers (list class)
1265   :body `(slot-value object ',slot-name)
1266   :environment (top-level-environment))
1267  (values))
1268
1269(defun add-writer-method (class fn-name slot-name)
1270  (ensure-method
1271   (ensure-generic-function
1272    fn-name :lambda-list '(new-value object))
1273   :lambda-list '(new-value object)
1274   :qualifiers ()
1275   :specializers (list (find-class 't) class)
1276   :body `(setf (slot-value object ',slot-name)
1277                new-value)
1278   :environment (top-level-environment))
1279  (values))
1280
1281(defun subclassp (c1 c2)
1282  (not (null (find c2 (class-precedence-list c1)))))
1283
1284(defun methods-contain-eql-specializer-p (methods)
1285  (dolist (method methods nil)
1286    (when (dolist (spec (method-specializers method) nil)
1287            (when (eql-specializer-p spec) (return t)))
1288      (return t))))
1289
1290(defun std-compute-discriminating-function (gf)
1291  (if (methods-contain-eql-specializer-p (generic-function-methods gf))
1292      #'(lambda (&rest args)
1293         (slow-method-lookup gf args nil))
1294      #'(lambda (&rest args)
1295         (let* ((classes (mapcar #'class-of
1296                                 (required-portion gf args)))
1297                (emfun (gethash classes (classes-to-emf-table gf) nil)))
1298           (if emfun
1299               (funcall emfun args)
1300               (slow-method-lookup gf args classes))))))
1301
1302(defun method-applicable-p (method args)
1303  (do* ((specializers (method-specializers method) (cdr specializers))
1304        (args args (cdr args)))
1305       ((null specializers) t)
1306    (let ((specializer (car specializers)))
1307      (if (typep specializer 'eql-specializer)
1308          (unless (eql (car args) (eql-specializer-object specializer))
1309            (return nil))
1310          (unless (subclassp (class-of (car args)) specializer)
1311            (return nil))))))
1312
1313(defun %compute-applicable-methods (gf args)
1314  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1315        (methods ()))
1316    (dolist (method (generic-function-methods gf))
1317      (when (method-applicable-p method args)
1318        (push method methods)))
1319    (sort methods
1320          (if (eq (class-of gf) the-class-standard-gf)
1321              #'(lambda (m1 m2)
1322                 (std-method-more-specific-p m1 m2 required-classes
1323                                             (generic-function-argument-precedence-order gf)))
1324              #'(lambda (m1 m2)
1325                 (method-more-specific-p gf m1 m2 required-classes))))))
1326
1327(defun slow-method-lookup (gf args classes)
1328  (let ((applicable-methods (%compute-applicable-methods gf args)))
1329    (if applicable-methods
1330        (let ((emfun (funcall (if (eq (class-of gf) the-class-standard-gf)
1331                                  #'std-compute-effective-method-function
1332                                  #'compute-effective-method-function)
1333                              gf applicable-methods)))
1334          (when classes
1335            (setf (gethash classes (classes-to-emf-table gf)) emfun))
1336          (funcall emfun args))
1337        (error "No applicable methods for generic function ~A with arguments ~S of classes ~S."
1338               (generic-function-name gf) args classes))))
1339
1340(defun sub-specializer-p (c1 c2 c-arg)
1341  (find c2 (cdr (memq c1 (class-precedence-list c-arg)))))
1342
1343(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
1344  (if argument-precedence-order
1345      (let ((specializers-1 (method-specializers method1))
1346            (specializers-2 (method-specializers method2)))
1347        (dolist (index argument-precedence-order)
1348          (let ((spec1 (nth index specializers-1))
1349                (spec2 (nth index specializers-2)))
1350            (unless (eq spec1 spec2)
1351              (cond ((eql-specializer-p spec1)
1352                     (return t))
1353                    ((eql-specializer-p spec2)
1354                     (return nil))
1355                    (t
1356                     (return (sub-specializer-p spec1 spec2
1357                                                (nth index required-classes)))))))))
1358      (do ((specializers-1 (method-specializers method1) (cdr specializers-1))
1359           (specializers-2 (method-specializers method2) (cdr specializers-2))
1360           (classes required-classes (cdr classes)))
1361          ((null specializers-1) nil)
1362        (let ((spec1 (car specializers-1))
1363              (spec2 (car specializers-2)))
1364          (unless (eq spec1 spec2)
1365            (cond ((eql-specializer-p spec1)
1366                   (return t))
1367                  ((eql-specializer-p spec2)
1368                   (return nil))
1369                  (t
1370                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
1371
1372(defun primary-method-p (method)
1373  (null (intersection '(:before :after :around) (method-qualifiers method))))
1374
1375(defun before-method-p (method)
1376  (equal '(:before) (method-qualifiers method)))
1377
1378(defun after-method-p (method)
1379  (equal '(:after) (method-qualifiers method)))
1380
1381(defun around-method-p (method)
1382  (equal '(:around) (method-qualifiers method)))
1383
1384(defun std-compute-effective-method-function (gf methods)
1385  (let* ((mc (generic-function-method-combination gf))
1386         (mc-name (if (atom mc) mc (car mc)))
1387         (options (if (atom mc) () (cdr mc)))
1388         (order (car options))
1389         (primaries ())
1390         (arounds ())
1391         around)
1392    (dolist (m methods)
1393      (let ((qualifiers (method-qualifiers m)))
1394        (cond ((null qualifiers)
1395               (if (eq mc-name 'standard)
1396                   (push m primaries)
1397                   (error "Method combination type mismatch.")))
1398              ((cdr qualifiers)
1399               (error "Invalid method qualifiers."))
1400              ((eq (car qualifiers) :around)
1401               (push m arounds))
1402              ((eq (car qualifiers) mc-name)
1403               (push m primaries))
1404              ((memq (car qualifiers) '(:before :after)))
1405              (t
1406               (error "Invalid method qualifiers.")))))
1407    (unless (eq order :most-specific-last)
1408      (setf primaries (nreverse primaries)))
1409    (setf arounds (nreverse arounds))
1410    (setf around (car arounds))
1411    (when (null primaries)
1412      (error "No primary methods for the generic function ~S." gf))
1413    (cond (around
1414           (let ((next-emfun
1415                  (funcall
1416                   (if (eq (class-of gf) the-class-standard-gf)
1417                       #'std-compute-effective-method-function
1418                       #'compute-effective-method-function)
1419                   gf (remove around methods))))
1420             #'(lambda (args)
1421                (funcall (method-function around) args next-emfun))))
1422          ((eq mc-name 'standard)
1423           (let ((next-emfun (compute-primary-emfun (cdr primaries)))
1424                 (befores (remove-if-not #'before-method-p methods))
1425                 (reverse-afters
1426                  (reverse (remove-if-not #'after-method-p methods))))
1427             #'(lambda (args)
1428                (dolist (before befores)
1429                  (funcall (method-function before) args nil))
1430                (multiple-value-prog1
1431                 (funcall (method-function (car primaries)) args next-emfun)
1432                 (dolist (after reverse-afters)
1433                   (funcall (method-function after) args nil))))))
1434          (t
1435           (let ((mc-obj (get mc-name 'method-combination-object)))
1436             (unless mc-obj
1437               (error "Unsupported method combination type ~A." mc-name))
1438             (let* ((operator (method-combination-operator mc-obj))
1439                    (ioa (method-combination-identity-with-one-argument mc-obj))
1440                    (form
1441                     (if (and (null (cdr primaries))
1442                              (not (null ioa)))
1443                         `(lambda (args)
1444                            (funcall ,(method-function (car primaries)) args nil))
1445                         `(lambda (args)
1446                            (,operator ,@(mapcar
1447                                          (lambda (primary)
1448                                            `(funcall ,(method-function primary) args nil))
1449                                          primaries))))))
1450               (coerce-to-function form)))))))
1451
1452;;; compute an effective method function from a list of primary methods:
1453
1454(defun compute-primary-emfun (methods)
1455  (if (null methods)
1456      nil
1457      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1458        #'(lambda (args)
1459           (funcall (method-function (car methods)) args next-emfun)))))
1460
1461(defvar *call-next-method-p*)
1462(defvar *next-method-p-p*)
1463
1464(defun walk-form (form)
1465  (cond ((atom form)
1466         (cond ((eq form 'call-next-method)
1467                (setf *call-next-method-p* t))
1468               ((eq form 'next-method-p)
1469                (setf *next-method-p-p* t))))
1470        (t
1471         (walk-form (car form))
1472         (walk-form (cdr form)))))
1473
1474(defun std-compute-method-function (method)
1475  (let ((body (method-body method))
1476        (declarations (method-declarations method))
1477        (lambda-list (method-lambda-list method))
1478        (*call-next-method-p* nil)
1479        (*next-method-p-p* nil))
1480    (walk-form body)
1481    (setf lambda-list (kludge-arglist lambda-list))
1482    (compile-in-lexical-environment
1483     (method-environment method)
1484     (if (or *call-next-method-p* *next-method-p-p*)
1485         `(lambda (args next-emfun)
1486            (flet ((call-next-method (&rest cnm-args)
1487                                     (if (null next-emfun)
1488                                         (error "No next method for generic function ~S."
1489                                                (method-generic-function ',method))
1490                                         (funcall next-emfun (or cnm-args args))))
1491                   (next-method-p ()
1492                                  (not (null next-emfun))))
1493              (apply #'(lambda ,lambda-list ,@declarations ,body) args)))
1494         `(lambda (args next-emfun)
1495            (apply #'(lambda ,lambda-list ,@declarations ,body) args))))))
1496
1497;;; N.B. The function kludge-arglist is used to pave over the differences
1498;;; between argument keyword compatibility for regular functions versus
1499;;; generic functions.
1500
1501;; FIXME
1502;; From CLHS section 7.6.5:
1503;; "When a generic function or any of its methods mentions &key in a lambda
1504;; list, the specific set of keyword arguments accepted by the generic function
1505;; varies according to the applicable methods. The set of keyword arguments
1506;; accepted by the generic function for a particular call is the union of the
1507;; keyword arguments accepted by all applicable methods and the keyword
1508;; arguments mentioned after &key in the generic function definition, if any."
1509
1510(defun kludge-arglist (lambda-list)
1511  (if (and (member '&key lambda-list)
1512           (not (member '&allow-other-keys lambda-list)))
1513      (append lambda-list '(&allow-other-keys))
1514      (if (and (not (member '&rest lambda-list))
1515               (not (member '&key lambda-list)))
1516          (append lambda-list '(&key &allow-other-keys))
1517          lambda-list)))
1518
1519(fmakunbound 'class-name)
1520
1521(defgeneric class-name (class))
1522
1523(defmethod class-name ((class class))
1524  (%class-name class))
1525
1526(defgeneric (setf class-name) (new-value class))
1527
1528(defmethod (setf class-name) (new-value (class class))
1529  (%set-class-name class new-value))
1530
1531(fmakunbound 'documentation)
1532
1533(defgeneric documentation (x doc-type))
1534
1535(defgeneric (setf documentation) (new-value x doc-type))
1536
1537(defmethod documentation ((x symbol) doc-type)
1538  (case doc-type
1539    (FUNCTION
1540     (get x '%function-documentation))
1541    (VARIABLE
1542     (get x '%variable-documentation))
1543    (STRUCTURE
1544     (get x '%structure-documentation))))
1545
1546(defmethod (setf documentation) (new-value (x symbol) doc-type)
1547  (case doc-type
1548    (FUNCTION
1549     (setf (get x '%function-documentation) docstring))
1550    (VARIABLE
1551     (setf (get x '%variable-documentation) docstring))
1552    (STRUCTURE
1553     (setf (get x '%structure-documentation) docstring))))
1554
1555(defmethod documentation ((x standard-class) (doc-type (eql 't)))
1556  (class-documentation x))
1557
1558(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
1559  (class-documentation x))
1560
1561(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
1562  (%set-class-documentation x new-value))
1563
1564(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
1565  (%set-class-documentation x new-value))
1566
1567(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
1568  (generic-function-documentation x))
1569
1570(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
1571  (setf (generic-function-documentation x) new-value))
1572
1573(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
1574  (generic-function-documentation x))
1575
1576(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
1577  (setf (generic-function-documentation x) new-value))
1578
1579(defmethod documentation ((x standard-method) (doc-type (eql 't)))
1580  (method-documentation x))
1581
1582(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
1583  (setf (method-documentation x) new-value))
1584
1585;; FIXME
1586(defmethod documentation ((x package) (doc-type (eql 't)))
1587  nil)
1588
1589;; FIXME
1590(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
1591  new-value)
1592
1593;;; Slot access
1594
1595(defun setf-slot-value-using-class (new-value class instance slot-name)
1596  (setf (std-slot-value instance slot-name) new-value))
1597
1598(defgeneric slot-value-using-class (class instance slot-name))
1599
1600(defmethod slot-value-using-class ((class standard-class) instance slot-name)
1601  (std-slot-value instance slot-name))
1602
1603(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
1604(defmethod (setf slot-value-using-class)
1605  (new-value (class standard-class) instance slot-name)
1606  (setf (std-slot-value instance slot-name) new-value))
1607
1608(defgeneric slot-exists-p-using-class (class instance slot-name))
1609
1610(defmethod slot-exists-p-using-class (class instance slot-name)
1611  nil)
1612
1613(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
1614  (std-slot-exists-p instance slot-name))
1615
1616(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
1617  (dolist (dsd (class-slots class))
1618    (when (eq (dsd-name dsd) slot-name)
1619      (return-from slot-exists-p-using-class t)))
1620  nil)
1621
1622(defgeneric slot-boundp-using-class (class instance slot-name))
1623(defmethod slot-boundp-using-class
1624  ((class standard-class) instance slot-name)
1625  (std-slot-boundp instance slot-name))
1626
1627(defgeneric slot-makunbound-using-class (class instance slot-name))
1628(defmethod slot-makunbound-using-class
1629  ((class standard-class) instance slot-name)
1630  (std-slot-makunbound instance slot-name))
1631
1632(defgeneric slot-missing (class instance slot-name operation &optional new-value))
1633
1634(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
1635  (error "The slot ~S is missing from the class ~S." slot-name class))
1636
1637(defgeneric slot-unbound (class instance slot-name))
1638
1639(defmethod slot-unbound ((class t) instance slot-name)
1640  (error 'unbound-slot :instance instance :name slot-name))
1641
1642;;; Instance creation and initialization
1643
1644(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
1645
1646(defmethod allocate-instance ((class standard-class) &rest initargs)
1647  (std-allocate-instance class))
1648
1649(defmethod allocate-instance ((class structure-class) &rest initargs)
1650  (%make-structure (%class-name class)
1651                   (make-list (length (class-slots class))
1652                              :initial-element +slot-unbound+)))
1653
1654(defgeneric make-instance (class &key))
1655
1656(defmethod make-instance ((class standard-class) &rest initargs)
1657  (when (oddp (length initargs))
1658    (error 'program-error
1659           :format-control "Odd number of keyword arguments."))
1660  (let ((class-default-initargs (class-default-initargs class)))
1661    (when class-default-initargs
1662      (let ((default-initargs ()))
1663        (do* ((list class-default-initargs (cddr list))
1664              (key (car list) (car list))
1665              (fn (cadr list) (cadr list)))
1666             ((null list))
1667          (when (eq (getf initargs key 'not-found) 'not-found)
1668            (setf default-initargs (append default-initargs (list key (funcall fn))))))
1669        (setf initargs (append initargs default-initargs)))))
1670  (let ((instance (std-allocate-instance class)))
1671    (apply #'initialize-instance instance initargs)
1672    instance))
1673
1674(defmethod make-instance ((class symbol) &rest initargs)
1675  (apply #'make-instance (find-class class) initargs))
1676
1677(defgeneric initialize-instance (instance &key))
1678
1679(defmethod initialize-instance ((instance standard-object) &rest initargs)
1680  (apply #'shared-initialize instance t initargs))
1681
1682(defgeneric reinitialize-instance (instance &key))
1683
1684(defmethod reinitialize-instance
1685  ((instance standard-object) &rest initargs)
1686  (apply #'shared-initialize instance () initargs))
1687
1688(defun std-shared-initialize (instance slot-names all-keys)
1689  (dolist (slot (class-slots (class-of instance)))
1690    (let ((slot-name (slot-definition-name slot)))
1691      (multiple-value-bind (init-key init-value foundp)
1692        (get-properties all-keys (slot-definition-initargs slot))
1693        (if foundp
1694            (setf (std-slot-value instance slot-name) init-value)
1695            (when (and (not (std-slot-boundp instance slot-name))
1696                       (slot-definition-initfunction slot)
1697                       (or (eq slot-names t)
1698                           (member slot-name slot-names)))
1699              (setf (std-slot-value instance slot-name)
1700                    (funcall (slot-definition-initfunction slot))))))))
1701  instance)
1702
1703(defgeneric shared-initialize (instance slot-names &key))
1704
1705(defmethod shared-initialize ((instance standard-object)
1706                              slot-names &rest all-keys)
1707  (std-shared-initialize instance slot-names all-keys))
1708
1709;;; change-class
1710
1711(defgeneric change-class (instance new-class &key))
1712
1713(defmethod change-class ((old-instance standard-object) (new-class standard-class)
1714                         &rest initargs)
1715  (let ((new-instance (allocate-instance new-class)))
1716    (dolist (slot-name (mapcar #'slot-definition-name
1717                               (class-slots new-class)))
1718      (when (and (slot-exists-p old-instance slot-name)
1719                 (slot-boundp old-instance slot-name))
1720        (setf (slot-value new-instance slot-name)
1721              (slot-value old-instance slot-name))))
1722    (rotatef (std-instance-slots new-instance)
1723             (std-instance-slots old-instance))
1724    (rotatef (std-instance-layout new-instance)
1725             (std-instance-layout old-instance))
1726    (apply #'update-instance-for-different-class
1727           new-instance old-instance initargs)
1728    old-instance))
1729
1730(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
1731  (apply #'change-class instance (find-class new-class) initargs))
1732
1733(defgeneric update-instance-for-different-class (old new &key))
1734
1735(defmethod update-instance-for-different-class
1736  ((old standard-object) (new standard-object) &rest initargs)
1737  (let ((added-slots
1738         (remove-if #'(lambda (slot-name)
1739                       (slot-exists-p old slot-name))
1740                    (mapcar #'slot-definition-name
1741                            (class-slots (class-of new))))))
1742    (apply #'shared-initialize new added-slots initargs)))
1743
1744;;;  Methods having to do with class metaobjects.
1745
1746(defmethod initialize-instance :after ((class standard-class) &rest args)
1747  (apply #'std-after-initialization-for-classes class args))
1748
1749;;; Finalize inheritance
1750
1751(defgeneric finalize-inheritance (class))
1752
1753(defmethod finalize-inheritance ((class standard-class))
1754  (std-finalize-inheritance class))
1755
1756;;; Class precedence lists
1757
1758(defgeneric compute-class-precedence-list (class))
1759(defmethod compute-class-precedence-list ((class standard-class))
1760  (std-compute-class-precedence-list class))
1761
1762;;; Slot inheritance
1763
1764(defgeneric compute-slots (class))
1765(defmethod compute-slots ((class standard-class))
1766  (std-compute-slots class))
1767
1768(defgeneric compute-effective-slot-definition (class direct-slots))
1769(defmethod compute-effective-slot-definition
1770  ((class standard-class) direct-slots)
1771  (std-compute-effective-slot-definition class direct-slots))
1772
1773;;; Methods having to do with generic function metaobjects.
1774
1775(defmethod initialize-instance :after ((gf standard-generic-function) &key)
1776  (finalize-generic-function gf))
1777
1778;;; Methods having to do with generic function invocation.
1779
1780(defgeneric compute-discriminating-function (gf))
1781(defmethod compute-discriminating-function ((gf standard-generic-function))
1782  (std-compute-discriminating-function gf))
1783
1784(defgeneric method-more-specific-p (gf method1 method2 required-classes))
1785
1786(defmethod method-more-specific-p ((gf standard-generic-function)
1787                                   method1 method2 required-classes)
1788  (std-method-more-specific-p method1 method2 required-classes
1789                              (generic-function-argument-precedence-order gf)))
1790
1791(defgeneric compute-effective-method-function (gf methods))
1792(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
1793  (std-compute-effective-method-function gf methods))
1794
1795(defgeneric compute-applicable-methods (gf args))
1796(defmethod compute-applicable-methods ((gf standard-generic-function) args)
1797  (%compute-applicable-methods gf args))
1798
1799;;; Conditions.
1800
1801(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
1802         &body options)
1803  (let ((parent-types (or parent-types '(condition)))
1804        (report nil))
1805    (dolist (option options)
1806      (when (eq (car option) :report)
1807        (let ((arg (cadr option)))
1808          (setf report
1809                (if (stringp arg)
1810                    `#'(lambda (condition stream)
1811                        (declare (ignore condition))
1812                        (write-string ,arg stream))
1813                    `#'(lambda (condition stream)
1814                        (funcall #',arg condition stream)))))))
1815    `(progn
1816       (defclass ,name ,parent-types ,slot-specs ,@options)
1817       (defmethod print-object ((condition ,name) stream)
1818         (if *print-escape*
1819             (call-next-method)
1820             (funcall ,report condition stream)))
1821       ',name)))
1822
1823(defun make-condition (type &rest initargs)
1824  (or (%make-condition type initargs)
1825      (apply #'make-instance (find-class type) initargs)))
1826
1827(defgeneric make-load-form (object &optional environment))
1828
1829(defmethod make-load-form ((object t) &optional environment)
1830  (error 'simple-error
1831         :format-control "No applicable method for MAKE-LOAD-FORM."))
1832
1833(defmethod make-load-form ((class class) &optional environment)
1834  (let ((name (class-name class)))
1835    (unless (and name (eq (find-class name nil) class))
1836      (error 'simple-type-error
1837             :format-control "Can't use anonymous or undefined class as a constant: ~S."
1838             :format-arguments (list class)))
1839    `(find-class ',name)))
1840
1841(provide 'clos)
Note: See TracBrowser for help on using the repository browser.