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

Last change on this file since 5044 was 5044, checked in by piso, 18 years ago

CANONICALIZE-DIRECT-SLOT: check for duplicate :DOCUMENTATION options.

File size: 60.5 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: clos.lisp,v 1.25 2003-12-10 02:59:30 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-name %set-class-name)
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-class %set-std-instance-class)
81(defsetf std-instance-slots %set-std-instance-slots)
82
83(defun (setf find-class) (new-value symbol &optional errorp environment)
84  (%set-find-class symbol new-value))
85
86(defun canonicalize-direct-slots (direct-slots)
87  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
88
89(defun canonicalize-direct-slot (spec)
90  (if (symbolp spec)
91      `(list :name ',spec)
92      (let ((name (car spec))
93            (initfunction nil)
94            (initform nil)
95            (initargs ())
96            (type nil)
97            (documentation nil)
98            (readers ())
99            (writers ())
100            (other-options ()))
101        (do ((olist (cdr spec) (cddr olist)))
102            ((null olist))
103          (case (car olist)
104            (:initform
105             (when initform
106               (error 'program-error
107                      "duplicate slot option :INITFORM for slot named ~S"
108                      name))
109             (setq initfunction
110                   `(function (lambda () ,(cadr olist))))
111             (setq initform `',(cadr olist)))
112            (:initarg
113             (push-on-end (cadr olist) initargs))
114            (:type
115             (when type
116               (error 'program-error
117                      "duplicate slot option :TYPE for slot named ~S"
118                      name))
119             (setf type (cadr olist))) ;; FIXME type is ignored
120            (:documentation
121             (when documentation
122               (error 'program-error
123                      "duplicate slot option :DOCUMENTATION for slot named ~S"
124                      name))
125             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
126            (:reader
127             (push-on-end (cadr olist) readers))
128            (:writer
129             (push-on-end (cadr olist) writers))
130            (:accessor
131             (push-on-end (cadr olist) readers)
132             (push-on-end `(setf ,(cadr olist)) writers))
133            (otherwise
134             (push-on-end `',(car olist) other-options)
135             (push-on-end `',(cadr olist) other-options))))
136        `(list
137          :name ',name
138          ,@(when initfunction
139              `(:initform ,initform
140                          :initfunction ,initfunction))
141          ,@(when initargs `(:initargs ',initargs))
142          ,@(when readers `(:readers ',readers))
143          ,@(when writers `(:writers ',writers))
144          ,@other-options))))
145
146(defun canonicalize-direct-superclasses (direct-superclasses)
147  `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses)))
148
149(defun canonicalize-direct-superclass (class-name)
150  `(find-class ',class-name))
151
152(defun canonicalize-defclass-options (options)
153  (mapappend #'canonicalize-defclass-option options))
154
155(defun canonicalize-defclass-option (option)
156  (case (car option)
157    (:metaclass
158     (list ':metaclass
159           `(find-class ',(cadr option))))
160    (:default-initargs
161     (list
162      ':direct-default-initargs
163      `(list ,@(mapappend
164                #'(lambda (x) x)
165                (mapplist
166                 #'(lambda (key value)
167                    `(',key ,(make-initfunction value)))
168                 (cdr option))))))
169    (t
170     (list `',(car option) `',(cadr option)))))
171
172(defun make-initfunction (initform)
173  `(function (lambda () ,initform)))
174
175(defconstant +slot-unbound+ (make-symbol "SLOT-UNBOUND"))
176
177;;; Slot definition metaobjects
178
179(defstruct slot-definition
180  name
181  initfunction
182  initform
183  initargs
184  readers
185  writers
186  allocation
187  allocation-class
188  (location nil))
189
190(defun make-direct-slot-definition (class &rest properties
191                                          &key name
192                                          (initargs ())
193                                          (initform nil)
194                                          (initfunction nil)
195                                          (readers ())
196                                          (writers ())
197                                          (allocation :instance)
198                                          &allow-other-keys)
199  (let ((slot (make-slot-definition)))
200    (setf (slot-definition-name slot) name)
201    (setf (slot-definition-initargs slot) initargs)
202    (setf (slot-definition-initform slot) initform)
203    (setf (slot-definition-initfunction slot) initfunction)
204    (setf (slot-definition-readers slot) readers)
205    (setf (slot-definition-writers slot) writers)
206    (setf (slot-definition-allocation slot) allocation)
207    (setf (slot-definition-allocation-class slot) class)
208    slot))
209
210(defun make-effective-slot-definition (&rest properties
211                                             &key name
212                                             (initargs ())
213                                             (initform nil)
214                                             (initfunction nil)
215                                             (allocation :instance)
216                                             (allocation-class nil)
217                                             &allow-other-keys)
218  (let ((slot (make-slot-definition)))
219    (setf (slot-definition-name slot) name)
220    (setf (slot-definition-initargs slot) initargs)
221    (setf (slot-definition-initform slot) initform)
222    (setf (slot-definition-initfunction slot) initfunction)
223    (setf (slot-definition-allocation slot) allocation)
224    (setf (slot-definition-allocation-class slot) allocation-class)
225    slot))
226
227;;; finalize-inheritance
228
229(defun std-finalize-inheritance (class)
230  (setf (class-precedence-list class)
231        (funcall (if (eq (class-of class) the-class-standard-class)
232                     #'std-compute-class-precedence-list
233                     #'compute-class-precedence-list)
234                 class))
235  (setf (class-slots class)
236        (funcall (if (eq (class-of class) the-class-standard-class)
237                     #'std-compute-slots
238                     #'compute-slots)
239                 class))
240  (let ((location 0))
241    (dolist (slot (class-slots class))
242      (case (slot-definition-allocation slot)
243        (:instance
244         (setf (slot-definition-location slot) location)
245         (incf location))
246        (:class
247         (unless (slot-definition-location slot)
248           (let ((allocation-class (slot-definition-allocation-class slot)))
249             (setf (slot-definition-location slot)
250                   (if (eq class allocation-class)
251                       (cons (slot-definition-name slot) +slot-unbound+)
252                       (slot-location allocation-class (slot-definition-name slot))))))))))
253  (setf (class-default-initargs class)
254        (compute-class-default-initargs class))
255  (values))
256
257(defun compute-class-default-initargs (class)
258  (mapappend #'class-direct-default-initargs
259             (class-precedence-list class)))
260
261;;; Class precedence lists
262
263(defun std-compute-class-precedence-list (class)
264  (let ((classes-to-order (collect-superclasses* class)))
265    (topological-sort classes-to-order
266                      (remove-duplicates
267                       (mapappend #'local-precedence-ordering
268                                  classes-to-order))
269                      #'std-tie-breaker-rule)))
270
271;;; topological-sort implements the standard algorithm for topologically
272;;; sorting an arbitrary set of elements while honoring the precedence
273;;; constraints given by a set of (X,Y) pairs that indicate that element
274;;; X must precede element Y.  The tie-breaker procedure is called when it
275;;; is necessary to choose from multiple minimal elements; both a list of
276;;; candidates and the ordering so far are provided as arguments.
277
278(defun topological-sort (elements constraints tie-breaker)
279  (let ((remaining-constraints constraints)
280        (remaining-elements elements)
281        (result ()))
282    (loop
283      (let ((minimal-elements
284             (remove-if
285              #'(lambda (class)
286                 (member class remaining-constraints
287                         :key #'cadr))
288              remaining-elements)))
289        (when (null minimal-elements)
290          (if (null remaining-elements)
291              (return-from topological-sort result)
292              (error "Inconsistent precedence graph.")))
293        (let ((choice (if (null (cdr minimal-elements))
294                          (car minimal-elements)
295                          (funcall tie-breaker
296                                   minimal-elements
297                                   result))))
298          (setq result (append result (list choice)))
299          (setq remaining-elements
300                (remove choice remaining-elements))
301          (setq remaining-constraints
302                (remove choice
303                        remaining-constraints
304                        :test #'member)))))))
305
306;;; In the event of a tie while topologically sorting class precedence lists,
307;;; the CLOS Specification says to "select the one that has a direct subclass
308;;; rightmost in the class precedence list computed so far."  The same result
309;;; is obtained by inspecting the partially constructed class precedence list
310;;; from right to left, looking for the first minimal element to show up among
311;;; the direct superclasses of the class precedence list constituent.
312;;; (There's a lemma that shows that this rule yields a unique result.)
313
314(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
315  (dolist (cpl-constituent (reverse cpl-so-far))
316    (let* ((supers (class-direct-superclasses cpl-constituent))
317           (common (intersection minimal-elements supers)))
318      (when (not (null common))
319        (return-from std-tie-breaker-rule (car common))))))
320
321;;; This version of collect-superclasses* isn't bothered by cycles in the class
322;;; hierarchy, which sometimes happen by accident.
323
324(defun collect-superclasses* (class)
325  (labels ((all-superclasses-loop (seen superclasses)
326                                  (let ((to-be-processed
327                                         (set-difference superclasses seen)))
328                                    (if (null to-be-processed)
329                                        superclasses
330                                        (let ((class-to-process
331                                               (car to-be-processed)))
332                                          (all-superclasses-loop
333                                           (cons class-to-process seen)
334                                           (union (class-direct-superclasses
335                                                   class-to-process)
336                                                  superclasses)))))))
337          (all-superclasses-loop () (list class))))
338
339;;; The local precedence ordering of a class C with direct superclasses C_1,
340;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
341
342(defun local-precedence-ordering (class)
343  (mapcar #'list
344          (cons class
345                (butlast (class-direct-superclasses class)))
346          (class-direct-superclasses class)))
347
348;;; Slot inheritance
349
350(defun std-compute-slots (class)
351  (let* ((all-slots (mapappend #'class-direct-slots
352                               (class-precedence-list class)))
353         (all-names (remove-duplicates
354                     (mapcar #'slot-definition-name all-slots))))
355    (mapcar #'(lambda (name)
356               (funcall
357                (if (eq (class-of class) the-class-standard-class)
358                    #'std-compute-effective-slot-definition
359                    #'compute-effective-slot-definition)
360                class
361                (remove name all-slots
362                        :key #'slot-definition-name
363                        :test-not #'eq)))
364            all-names)))
365
366(defun std-compute-effective-slot-definition (class direct-slots)
367  (declare (ignore class))
368  (let ((initer (find-if-not #'null direct-slots
369                             :key #'slot-definition-initfunction)))
370    (make-effective-slot-definition
371     :name (slot-definition-name (car direct-slots))
372     :initform (if initer
373                   (slot-definition-initform initer)
374                   nil)
375     :initfunction (if initer
376                       (slot-definition-initfunction initer)
377                       nil)
378     :initargs (remove-duplicates
379                (mapappend #'slot-definition-initargs
380                           direct-slots))
381     :allocation (slot-definition-allocation (car direct-slots))
382     :allocation-class (slot-definition-allocation-class (car direct-slots)))))
383
384;;; Simple vectors are used for slot storage.
385
386(defun allocate-slot-storage (size initial-value)
387  (make-array size :initial-element initial-value))
388
389;;; Standard instance slot access
390
391;;; N.B. The location of the effective-slots slots in the class metaobject for
392;;; standard-class must be determined without making any further slot
393;;; references.
394
395(defvar the-slots-of-standard-class) ;standard-class's class-slots
396(defvar the-class-standard-class (find-class 'standard-class))
397
398(defun find-slot-definition (class slot-name)
399  (dolist (slot (class-slots class) nil)
400    (when (eq slot-name (slot-definition-name slot))
401      (return slot))))
402
403(defun slot-location (class slot-name)
404  (let ((slot (find-slot-definition class slot-name)))
405    (if slot
406        (slot-definition-location slot)
407        nil)))
408
409(defmacro slot-contents (slots location)
410  `(aref ,slots ,location))
411
412(defun (setf slot-contents) (new-value slots location)
413  (setf (svref slots location) new-value))
414
415(defun std-slot-value (instance slot-name)
416  (let* ((location (slot-location (class-of instance) slot-name))
417         (value (cond ((fixnump location)
418                       (slot-contents (std-instance-slots instance) location))
419                      ((consp location)
420                       (cdr location))
421                      (t
422                       (slot-missing (class-of instance) instance slot-name 'slot-value)))))
423    (if (eq +slot-unbound+ value)
424        (error "the slot ~S is unbound in the object ~S" slot-name instance)
425        value)))
426
427(defun slot-value (object slot-name)
428  (if (eq (class-of (class-of object)) the-class-standard-class)
429      (std-slot-value object slot-name)
430      (slot-value-using-class (class-of object) object slot-name)))
431
432(defun (setf std-slot-value) (new-value instance slot-name)
433  (let ((location (slot-location (class-of instance) slot-name)))
434    (cond ((fixnump location)
435           (setf (slot-contents (std-instance-slots instance) location) new-value))
436          ((consp location)
437           (setf (cdr location) new-value))
438          (t
439           (slot-missing (class-of instance) instance slot-name 'setf new-value))))
440  new-value)
441
442(defun (setf slot-value) (new-value object slot-name)
443  (if (eq (class-of (class-of object)) the-class-standard-class)
444      (setf (std-slot-value object slot-name) new-value)
445      (setf-slot-value-using-class
446       new-value (class-of object) object slot-name)))
447
448(defun std-slot-boundp (instance slot-name)
449  (let ((location (slot-location (class-of instance) slot-name)))
450    (cond ((fixnump location)
451           (neq +slot-unbound+ (slot-contents (std-instance-slots instance) location)))
452          ((consp location)
453           (neq +slot-unbound+ (cdr location)))
454          (t
455           (not (null (slot-missing (class-of instance) instance slot-name 'slot-boundp)))))))
456
457(defun slot-boundp (object slot-name)
458  (if (eq (class-of (class-of object)) the-class-standard-class)
459      (std-slot-boundp object slot-name)
460      (slot-boundp-using-class (class-of object) object slot-name)))
461
462(defun std-slot-makunbound (instance slot-name)
463  (let ((location (slot-location (class-of instance) slot-name)))
464    (cond ((fixnump location)
465           (setf (slot-contents (std-instance-slots instance) location) +slot-unbound+))
466          ((consp location)
467           (setf (cdr location) +slot-unbound+))
468          (t
469           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
470  instance)
471
472(defun slot-makunbound (object slot-name)
473  (if (eq (class-of (class-of object)) the-class-standard-class)
474      (std-slot-makunbound object slot-name)
475      (slot-makunbound-using-class (class-of object) object slot-name)))
476
477(defun std-slot-exists-p (instance slot-name)
478  (not (null (find slot-name (class-slots (class-of instance))
479                   :key #'slot-definition-name))))
480(defun slot-exists-p (object slot-name)
481  (if (eq (class-of (class-of object)) the-class-standard-class)
482      (std-slot-exists-p object slot-name)
483      (slot-exists-p-using-class (class-of object) object slot-name)))
484
485;;; Standard instance allocation
486
487(defun instance-slot-p (slot)
488  (eq (slot-definition-allocation slot) :instance))
489
490(defun std-allocate-instance (class)
491  (allocate-std-instance
492   class
493   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
494                          +slot-unbound+)))
495
496(defun allocate-instance (class)
497  (std-allocate-instance class))
498
499(defun make-instance-standard-class (metaclass
500                                     &key name direct-superclasses direct-slots
501                                     direct-default-initargs
502                                     &allow-other-keys)
503  (declare (ignore metaclass))
504  (let ((class (std-allocate-instance (find-class 'standard-class))))
505    (setf (class-name class) name)
506    (setf (class-direct-subclasses class) ())
507    (setf (class-direct-methods class) ())
508    (std-after-initialization-for-classes class
509                                          :direct-superclasses direct-superclasses
510                                          :direct-slots direct-slots
511                                          :direct-default-initargs direct-default-initargs)
512    class))
513
514(defun std-after-initialization-for-classes (class
515                                             &key direct-superclasses direct-slots
516                                             direct-default-initargs
517                                             &allow-other-keys)
518  (let ((supers (or direct-superclasses
519                    (list (find-class 'standard-object)))))
520    (setf (class-direct-superclasses class) supers)
521    (dolist (superclass supers)
522      (push class (class-direct-subclasses superclass))))
523  (let ((slots (mapcar #'(lambda (slot-properties)
524                          (apply #'make-direct-slot-definition class slot-properties))
525                       direct-slots)))
526    (setf (class-direct-slots class) slots)
527    (dolist (direct-slot slots)
528      (dolist (reader (slot-definition-readers direct-slot))
529        (add-reader-method
530         class reader (slot-definition-name direct-slot)))
531      (dolist (writer (slot-definition-writers direct-slot))
532        (add-writer-method
533         class writer (slot-definition-name direct-slot)))))
534  (setf (class-direct-default-initargs class) direct-default-initargs)
535  (funcall (if (eq (class-of class) (find-class 'standard-class))
536               #'std-finalize-inheritance
537               #'finalize-inheritance)
538           class)
539  (values))
540
541(defun canonical-slot-name (canonical-slot)
542  (getf canonical-slot :name))
543
544(defun ensure-class (name &rest all-keys &allow-other-keys)
545  ;; Check for duplicate slots.
546  (let ((slots (getf all-keys :direct-slots)))
547    (dolist (s1 slots)
548      (let ((name1 (canonical-slot-name s1)))
549        (dolist (s2 (cdr (memq s1 slots)))
550    (when (eq name1 (canonical-slot-name s2))
551            (error 'program-error "duplicate slot ~S" name1))))))
552  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
553  (let ((names ()))
554    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
555          (name (car initargs) (car initargs)))
556         ((null initargs))
557      (push name names))
558    (do* ((names names (cdr names))
559          (name (car names) (car names)))
560         ((null names))
561      (when (memq name (cdr names))
562        (error 'program-error
563               "duplicate initialization argument name ~S in :DEFAULT-INITARGS"
564               name))))
565  (let ((class (find-class name nil)))
566    (unless class
567      (setf class (apply #'make-instance-standard-class (find-class 'standard-class)
568                         :name name all-keys))
569      (%set-find-class name class))
570    class))
571
572(defmacro defclass (name direct-superclasses direct-slots
573                         &rest options)
574  `(ensure-class ',name
575                 :direct-superclasses
576                 ,(canonicalize-direct-superclasses direct-superclasses)
577                 :direct-slots
578                 ,(canonicalize-direct-slots direct-slots)
579                 ,@(canonicalize-defclass-options options)))
580
581;;; Generic function metaobjects and standard-generic-function
582
583(defun method-combination-type (method-combination)
584  (if (atom method-combination)
585      method-combination
586      (car method-combination)))
587
588(defun method-combination-options (method-combination)
589  (if (atom method-combination)
590      nil
591      (cdr method-combination)))
592
593(defclass standard-generic-function (generic-function)
594  ((name :initarg :name)      ; :accessor generic-function-name
595   (lambda-list               ; :accessor generic-function-lambda-list
596    :initarg :lambda-list)
597   (methods :initform ())     ; :accessor generic-function-methods
598   (method-class              ; :accessor generic-function-method-class
599    :initarg :method-class)
600   (method-combination
601    :initarg :method-combination)
602   (classes-to-emf-table      ; :accessor classes-to-emf-table
603    :initform (make-hash-table :test #'equal))
604   (required-args :initform ())))
605
606(defvar the-class-standard-gf (find-class 'standard-generic-function))
607
608(defvar *sgf-required-args-index*
609  (slot-location the-class-standard-gf 'required-args))
610
611(defvar *sgf-classes-to-emf-table-index*
612  (slot-location the-class-standard-gf 'classes-to-emf-table))
613
614(defun generic-function-name (gf)
615  (slot-value gf 'name))
616(defun (setf generic-function-name) (new-value gf)
617  (setf (slot-value gf 'name) new-value))
618
619(defun generic-function-lambda-list (gf)
620  (slot-value gf 'lambda-list))
621(defun (setf generic-function-lambda-list) (new-value gf)
622  (setf (slot-value gf 'lambda-list) new-value))
623
624(defun generic-function-methods (gf)
625  (slot-value gf 'methods))
626(defun (setf generic-function-methods) (new-value gf)
627  (setf (slot-value gf 'methods) new-value))
628
629(defsetf generic-function-discriminating-function
630  %set-generic-function-discriminating-function)
631
632(defun generic-function-method-class (gf)
633  (slot-value gf 'method-class))
634(defun (setf generic-function-method-class) (new-value gf)
635  (setf (slot-value gf 'method-class) new-value))
636
637(defun generic-function-method-combination (gf)
638  (slot-value gf 'method-combination))
639(defun (setf generic-function-method-combination) (new-value gf)
640  (setf (slot-value gf 'method-combination) new-value))
641
642;;; Internal accessor for effective method function table
643
644(defun classes-to-emf-table (gf)
645;;   (slot-value gf 'classes-to-emf-table))
646  (slot-contents (std-instance-slots gf) *sgf-classes-to-emf-table-index*))
647(defun (setf classes-to-emf-table) (new-value gf)
648  (setf (slot-value gf 'classes-to-emf-table) new-value))
649
650;;; Method metaobjects and standard-method
651
652(defclass standard-method (method)
653  ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
654   (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
655   (specializers :initarg :specializers)   ; :accessor method-specializers
656   (body :initarg :body)                   ; :accessor method-body
657   (environment :initarg :environment)     ; :accessor method-environment
658   (generic-function :initform nil)        ; :accessor method-generic-function
659   (function)))                            ; :accessor method-function
660
661(defvar the-class-standard-method (find-class 'standard-method))
662
663(defvar *sm-function-index*
664  (slot-location the-class-standard-method 'function))
665
666(defun method-lambda-list (method) (slot-value method 'lambda-list))
667(defun (setf method-lambda-list) (new-value method)
668  (setf (slot-value method 'lambda-list) new-value))
669
670(defun method-qualifiers (method) (slot-value method 'qualifiers))
671(defun (setf method-qualifiers) (new-value method)
672  (setf (slot-value method 'qualifiers) new-value))
673
674(defun method-specializers (method) (slot-value method 'specializers))
675(defun (setf method-specializers) (new-value method)
676  (setf (slot-value method 'specializers) new-value))
677
678(defun method-body (method) (slot-value method 'body))
679(defun (setf method-body) (new-value method)
680  (setf (slot-value method 'body) new-value))
681
682(defun method-environment (method) (slot-value method 'environment))
683(defun (setf method-environment) (new-value method)
684  (setf (slot-value method 'environment) new-value))
685
686(defun method-generic-function (method)
687  (slot-value method 'generic-function))
688(defun (setf method-generic-function) (new-value method)
689  (setf (slot-value method 'generic-function) new-value))
690
691(defun method-function (method)
692;;   (slot-value method 'function))
693  (slot-contents (std-instance-slots method) *sm-function-index*))
694(defun (setf method-function) (new-value method)
695  (setf (slot-value method 'function) new-value))
696
697;;; defgeneric
698
699(defmacro defgeneric (function-name lambda-list
700                                    &rest options-and-method-descriptions)
701  (let ((options ())
702        (methods ()))
703    (dolist (item options-and-method-descriptions)
704      (case (car item)
705        (declare) ; FIXME
706        (:documentation) ; FIXME
707        (:method
708         (push `(defmethod ,function-name ,@(cdr item)) methods))
709        (t
710         (push item options))))
711    (setf options (nreverse options)
712          methods (nreverse methods))
713    `(prog1
714       (ensure-generic-function
715        ',function-name
716        :lambda-list ',lambda-list
717        ,@(canonicalize-defgeneric-options options))
718       ,@methods)))
719
720(defun canonicalize-defgeneric-options (options)
721  (mapappend #'canonicalize-defgeneric-option options))
722
723(defun canonicalize-defgeneric-option (option)
724  (case (car option)
725    (:generic-function-class
726     (list ':generic-function-class `(find-class ',(cadr option))))
727    (:method-class
728     (list ':method-class `(find-class ',(cadr option))))
729    (:method-combination
730     (list `',(car option) `',(cdr option)))
731    (t
732     (list `',(car option) `',(cadr option)))))
733
734(defparameter generic-function-table (make-hash-table :test #'equal))
735
736(defun find-generic-function (symbol &optional (errorp t))
737  (let ((gf (gethash symbol generic-function-table nil)))
738    (if (and (null gf) errorp)
739        (error "no generic function named ~S" symbol)
740        gf)))
741
742(defun (setf find-generic-function) (new-value symbol)
743  (setf (gethash symbol generic-function-table) new-value))
744
745;;; ensure-generic-function
746
747(defun ensure-generic-function (function-name
748                                &rest all-keys
749                                &key
750                                (generic-function-class the-class-standard-gf)
751                                (method-class the-class-standard-method)
752                                (method-combination 'standard)
753                                &allow-other-keys)
754  (when (autoloadp function-name)
755    (resolve function-name))
756  (if (find-generic-function function-name nil)
757      (find-generic-function function-name)
758      (progn
759        (when (fboundp function-name)
760          (error 'program-error
761                 "~A already names an ordinary function, macro, or special operator"
762                 function-name))
763        (let ((gf (apply (if (eq generic-function-class the-class-standard-gf)
764                             #'make-instance-standard-generic-function
765                             #'make-instance)
766                         generic-function-class
767                         :name function-name
768                         :method-class method-class
769                         :method-combination method-combination
770                         all-keys)))
771          (setf (find-generic-function function-name) gf)
772          gf))))
773
774;;; finalize-generic-function
775
776(defun finalize-generic-function (gf)
777  (setf (generic-function-discriminating-function gf)
778        (funcall (if (eq (class-of gf) the-class-standard-gf)
779                     #'std-compute-discriminating-function
780                     #'compute-discriminating-function)
781                 gf))
782  (setf (fdefinition (generic-function-name gf)) gf)
783  (clrhash (classes-to-emf-table gf))
784  (values))
785
786(defun gf-required-args (gf)
787  (slot-contents (std-instance-slots gf) *sgf-required-args-index*))
788
789(defun make-instance-standard-generic-function (generic-function-class
790                                                &key name lambda-list
791                                                method-class
792                                                method-combination)
793  (declare (ignore generic-function-class))
794  (let ((gf (std-allocate-instance the-class-standard-gf)))
795    (setf (generic-function-name gf) name)
796    (setf (generic-function-lambda-list gf) lambda-list)
797    (setf (generic-function-methods gf) ())
798    (setf (generic-function-method-class gf) method-class)
799    (setf (generic-function-method-combination gf) method-combination)
800    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
801    (setf (slot-value gf 'required-args)
802          (let ((plist (analyze-lambda-list (generic-function-lambda-list gf))))
803            (getf plist ':required-args)))
804    (finalize-generic-function gf)
805    gf))
806
807;;; Run-time environment hacking (Common Lisp ain't got 'em).
808
809(defun top-level-environment ()
810  nil) ; Bogus top level lexical environment
811
812(defvar compile-methods nil)      ; by default, run everything interpreted
813
814(defun compile-in-lexical-environment (env lambda-expr)
815  (declare (ignore env))
816  (if compile-methods
817      (compile nil lambda-expr)
818      (eval `(function ,lambda-expr))))
819
820;;; defmethod
821
822(defmacro defmethod (&rest args)
823  (multiple-value-bind (function-name qualifiers lambda-list specializers body)
824    (parse-defmethod args)
825    `(progn
826      (ensure-generic-function
827       ',function-name
828       :lambda-list ',lambda-list)
829      (ensure-method (find-generic-function ',function-name)
830                     :lambda-list ',lambda-list
831                     :qualifiers ',qualifiers
832                     :specializers ,(canonicalize-specializers specializers)
833                     :body ',body
834                     :environment (top-level-environment)))))
835
836(defun canonicalize-specializers (specializers)
837  `(list ,@(mapcar #'canonicalize-specializer specializers)))
838
839(defun canonicalize-specializer (specializer)
840  ;; FIXME (EQL specializers)
841  `(if (atom ',specializer) (find-class ',specializer) (find-class 't)))
842
843(defun parse-defmethod (args)
844  (let ((fn-spec (car args))
845        (qualifiers ())
846        (specialized-lambda-list nil)
847        (body ())
848        (parse-state :qualifiers))
849    (dolist (arg (cdr args))
850      (ecase parse-state
851        (:qualifiers
852         (if (and (atom arg) (not (null arg)))
853             (push-on-end arg qualifiers)
854             (progn (setq specialized-lambda-list arg)
855               (setq parse-state :body))))
856        (:body (push-on-end arg body))))
857    (values fn-spec
858            qualifiers
859            (extract-lambda-list specialized-lambda-list)
860            (extract-specializers specialized-lambda-list)
861            (list* 'block
862                   (if (consp fn-spec)
863                       (cadr fn-spec)
864                       fn-spec)
865                   body))))
866
867;;; Several tedious functions for analyzing lambda lists
868
869(defun required-portion (gf args)
870  (let ((number-required (length (gf-required-args gf))))
871    (when (< (length args) number-required)
872      (error 'program-error "not enough arguments for generic function ~S" gf))
873    (subseq args 0 number-required)))
874
875(defun extract-lambda-list (specialized-lambda-list)
876  (let* ((plist (analyze-lambda-list specialized-lambda-list))
877         (requireds (getf plist :required-names))
878         (rv (getf plist :rest-var))
879         (ks (getf plist :key-args))
880         (keysp (getf plist :keysp))
881         (aok (getf plist :allow-other-keys))
882         (opts (getf plist :optional-args))
883         (auxs (getf plist :auxiliary-args)))
884    `(,@requireds
885      ,@(if rv `(&rest ,rv) ())
886      ,@(if (or ks keysp aok) `(&key ,@ks) ())
887      ,@(if aok '(&allow-other-keys) ())
888      ,@(if opts `(&optional ,@opts) ())
889      ,@(if auxs `(&aux ,@auxs) ()))))
890
891(defun extract-specializers (specialized-lambda-list)
892  (let ((plist (analyze-lambda-list specialized-lambda-list)))
893    (getf plist ':specializers)))
894
895(defun analyze-lambda-list (lambda-list)
896  (labels ((make-keyword (symbol)
897                         (intern (symbol-name symbol)
898                                 (find-package 'keyword)))
899           (get-keyword-from-arg (arg)
900                                 (if (listp arg)
901                                     (if (listp (car arg))
902                                         (caar arg)
903                                         (make-keyword (car arg)))
904                                     (make-keyword arg))))
905          (let ((keys ())           ; Just the keywords
906                (key-args ())       ; Keywords argument specs
907                (keysp nil)         ;
908                (required-names ()) ; Just the variable names
909                (required-args ())  ; Variable names & specializers
910                (specializers ())   ; Just the specializers
911                (rest-var nil)
912                (optionals ())
913                (auxs ())
914                (allow-other-keys nil)
915                (state :parsing-required))
916            (dolist (arg lambda-list)
917              (if (member arg lambda-list-keywords)
918                  (ecase arg
919                    (&optional
920                     (setq state :parsing-optional))
921                    (&rest
922                     (setq state :parsing-rest))
923                    (&key
924                     (setq keysp t)
925                     (setq state :parsing-key))
926                    (&allow-other-keys
927                     (setq allow-other-keys 't))
928                    (&aux
929                     (setq state :parsing-aux)))
930                  (case state
931                    (:parsing-required
932                     (push-on-end arg required-args)
933                     (if (listp arg)
934                         (progn (push-on-end (car arg) required-names)
935                           (push-on-end (cadr arg) specializers))
936                         (progn (push-on-end arg required-names)
937                           (push-on-end 't specializers))))
938                    (:parsing-optional (push-on-end arg optionals))
939                    (:parsing-rest (setq rest-var arg))
940                    (:parsing-key
941                     (push-on-end (get-keyword-from-arg arg) keys)
942                     (push-on-end arg key-args))
943                    (:parsing-aux (push-on-end arg auxs)))))
944            (list  :required-names required-names
945                   :required-args required-args
946                   :specializers specializers
947                   :rest-var rest-var
948                   :keywords keys
949                   :key-args key-args
950                   :keysp keysp
951                   :auxiliary-args auxs
952                   :optional-args optionals
953                   :allow-other-keys allow-other-keys))))
954
955;;; ensure method
956
957#+nil
958(defun check-method-arg-info (gf arg-info method)
959  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
960    (analyze-lambda-list (if (consp method)
961                             (early-method-lambda-list method)
962                             (method-lambda-list method)))
963    (flet ((lose (string &rest args)
964                 (error 'simple-program-error
965                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
966                        to the generic function~2I~_~S;~I~_~
967                        but ~?~:>"
968                        :format-arguments (list method gf string args)))
969     (comparison-description (x y)
970                                   (if (> x y) "more" "fewer")))
971      (let ((gf-nreq (arg-info-number-required arg-info))
972      (gf-nopt (arg-info-number-optional arg-info))
973      (gf-key/rest-p (arg-info-key/rest-p arg-info))
974      (gf-keywords (arg-info-keys arg-info)))
975  (unless (= nreq gf-nreq)
976    (lose
977     "the method has ~A required arguments than the generic function."
978     (comparison-description nreq gf-nreq)))
979  (unless (= nopt gf-nopt)
980    (lose
981     "the method has ~A optional arguments than the generic function."
982     (comparison-description nopt gf-nopt)))
983  (unless (eq (or keysp restp) gf-key/rest-p)
984    (lose
985     "the method and generic function differ in whether they accept~_~
986      &REST or &KEY arguments."))
987  (when (consp gf-keywords)
988    (unless (or (and restp (not keysp))
989          allow-other-keys-p
990          (every (lambda (k) (memq k keywords)) gf-keywords))
991      (lose "the method does not accept each of the &KEY arguments~2I~_~
992            ~S."
993      gf-keywords)))))))
994
995(defun ensure-method (gf &rest all-keys)
996  (let* ((gf-lambda-list (generic-function-lambda-list gf))
997         (gf-restp (not (null (memq '&rest gf-lambda-list))))
998         (gf-plist (analyze-lambda-list gf-lambda-list))
999         (gf-keysp (getf gf-plist :keysp))
1000         (gf-keywords (getf gf-plist :keywords))
1001         (method-lambda-list (getf all-keys :lambda-list))
1002         (method-plist (analyze-lambda-list method-lambda-list))
1003         (method-restp (not (null (memq '&rest method-lambda-list))))
1004         (method-keysp (getf method-plist :keysp))
1005         (method-keywords (getf method-plist :keywords))
1006         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1007    (unless (= (length (getf gf-plist :required-args))
1008               (length (getf method-plist :required-args)))
1009      (error "the method has the wrong number of required arguments for the generic function"))
1010    (unless (= (length (getf gf-plist :optional-args))
1011               (length (getf method-plist :optional-args)))
1012      (error "the method has the wrong number of optional arguments for the generic function"))
1013    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1014      (error "the method and the generic function differ in whether they accept &REST or &KEY arguments"))
1015    (when (consp gf-keywords)
1016      (unless (or (and method-restp (not method-keysp))
1017                  method-allow-other-keys-p
1018                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1019        (error "the method does not accept all of the keyword arguments defined for the generic function"))))
1020  (let ((new-method
1021         (apply
1022          (if (eq (generic-function-method-class gf) the-class-standard-method)
1023              #'make-instance-standard-method
1024              #'make-instance)
1025          (generic-function-method-class gf)
1026          all-keys)))
1027    (add-method gf new-method)
1028    new-method))
1029
1030(defun make-instance-standard-method (method-class
1031                                      &key lambda-list qualifiers
1032                                      specializers body environment)
1033  (declare (ignore method-class))
1034  (let ((method (std-allocate-instance the-class-standard-method)))
1035    (setf (method-lambda-list method) lambda-list)
1036    (setf (method-qualifiers method) qualifiers)
1037    (setf (method-specializers method) specializers)
1038    (setf (method-body method) (precompile-form body nil))
1039    (setf (method-environment method) environment)
1040    (setf (method-generic-function method) nil)
1041    (setf (method-function method)
1042          (std-compute-method-function method))
1043    method))
1044
1045(defun check-congruent (gf method)
1046  (let* ((plist1 (analyze-lambda-list (generic-function-lambda-list gf)))
1047         (args1 (getf plist1 :required-args))
1048         (plist2 (analyze-lambda-list (method-lambda-list method)))
1049         (args2 (getf plist2 :required-args)))
1050    (unless (= (length args1) (length args2))
1051      (error "lambda lists are not congruent"))))
1052
1053(defun add-method (gf method)
1054  (check-congruent gf method)
1055  ;; Remove existing method with same qualifiers and specializers (if any).
1056  (let ((old-method (find-method gf (method-qualifiers method)
1057                                 (method-specializers method) nil)))
1058    (when old-method
1059      (remove-method gf old-method)))
1060  (setf (method-generic-function method) gf)
1061  (push method (generic-function-methods gf))
1062  (dolist (specializer (method-specializers method))
1063    (pushnew method (class-direct-methods specializer)))
1064  (finalize-generic-function gf)
1065  gf)
1066
1067(defun remove-method (gf method)
1068  (setf (generic-function-methods gf)
1069        (remove method (generic-function-methods gf)))
1070  (setf (method-generic-function method) nil)
1071;;   (format t "remove-method method-specializers = ~S~%" (method-specializers method))
1072  (dolist (class (method-specializers method))
1073    (setf (class-direct-methods class)
1074          (remove method (class-direct-methods class))))
1075  (finalize-generic-function gf)
1076  gf)
1077
1078(defun find-method (gf qualifiers specializers &optional (errorp t))
1079  (let ((method
1080         (find-if #'(lambda (method)
1081                     (and (equal qualifiers
1082                                 (method-qualifiers method))
1083                          (equal specializers
1084                                 (method-specializers method))))
1085                  (generic-function-methods gf))))
1086    (if (and (null method) errorp)
1087        (error "no such method for ~S" (generic-function-name gf))
1088        method)))
1089
1090;;; Reader and writer methods
1091
1092(defun add-reader-method (class fn-name slot-name)
1093  (ensure-method
1094   (ensure-generic-function fn-name :lambda-list '(object))
1095   :lambda-list '(object)
1096   :qualifiers ()
1097   :specializers (list class)
1098   :body `(slot-value object ',slot-name)
1099   :environment (top-level-environment))
1100  (values))
1101
1102(defun add-writer-method (class fn-name slot-name)
1103  (ensure-method
1104   (ensure-generic-function
1105    fn-name :lambda-list '(new-value object))
1106   :lambda-list '(new-value object)
1107   :qualifiers ()
1108   :specializers (list (find-class 't) class)
1109   :body `(setf (slot-value object ',slot-name)
1110                new-value)
1111   :environment (top-level-environment))
1112  (values))
1113
1114;;; subclassp and sub-specializer-p
1115
1116(defun subclassp (c1 c2)
1117  (not (null (find c2 (class-precedence-list c1)))))
1118
1119(defun sub-specializer-p (c1 c2 c-arg)
1120  (let ((cpl (class-precedence-list c-arg)))
1121    (not (null (find c2 (cdr (member c1 cpl)))))))
1122
1123;;;
1124;;; Generic function invocation
1125;;;
1126
1127;;; apply-generic-function
1128
1129(defun apply-generic-function (gf args)
1130  (apply (generic-function-discriminating-function gf) args))
1131
1132;;; compute-discriminating-function
1133
1134(defun std-compute-discriminating-function (gf)
1135  #'(lambda (&rest args)
1136     (let* ((classes (mapcar #'class-of
1137                             (required-portion gf args)))
1138            (emfun (gethash classes (classes-to-emf-table gf) nil)))
1139       (if emfun
1140           (funcall emfun args)
1141           (slow-method-lookup gf args classes)))))
1142
1143(defun slow-method-lookup (gf args classes)
1144  (let ((applicable-methods
1145         (compute-applicable-methods-using-classes gf classes)))
1146    (if applicable-methods
1147        (let ((emfun
1148               (funcall
1149                (if (eq (class-of gf) the-class-standard-gf)
1150                    #'std-compute-effective-method-function
1151                  #'compute-effective-method-function)
1152                gf applicable-methods)))
1153          (setf (gethash classes (classes-to-emf-table gf)) emfun)
1154          (funcall emfun args))
1155        (error "no applicable methods for generic function ~S with arguments ~S of classes ~S" gf args classes))))
1156
1157;;; compute-applicable-methods-using-classes
1158
1159(defun compute-applicable-methods-using-classes (gf required-classes)
1160  (sort
1161   (copy-list
1162    (remove-if-not #'(lambda (method)
1163                      (every #'subclassp
1164                             required-classes
1165                             (method-specializers method)))
1166                   (generic-function-methods gf)))
1167   #'(lambda (m1 m2)
1168      (funcall
1169       (if (eq (class-of gf) the-class-standard-gf)
1170           #'std-method-more-specific-p
1171           #'method-more-specific-p)
1172       gf m1 m2 required-classes))))
1173
1174;;; method-more-specific-p
1175
1176(defun std-method-more-specific-p (gf method1 method2 required-classes)
1177  (declare (ignore gf))
1178  (mapc #'(lambda (spec1 spec2 arg-class)
1179           (unless (eq spec1 spec2)
1180             (return-from std-method-more-specific-p
1181                          (sub-specializer-p spec1 spec2 arg-class))))
1182        (method-specializers method1)
1183        (method-specializers method2)
1184        required-classes)
1185  nil)
1186
1187;;; apply-methods and compute-effective-method-function
1188
1189(defun apply-methods (gf args methods)
1190  (funcall (compute-effective-method-function gf methods)
1191           args))
1192
1193(defun primary-method-p (method)
1194  (null (intersection '(:before :after :around) (method-qualifiers method))))
1195
1196(defun before-method-p (method)
1197  (equal '(:before) (method-qualifiers method)))
1198
1199(defun after-method-p (method)
1200  (equal '(:after) (method-qualifiers method)))
1201
1202(defun around-method-p (method)
1203  (equal '(:around) (method-qualifiers method)))
1204
1205(defun std-compute-effective-method-function (gf methods)
1206  (let* ((mc (generic-function-method-combination gf))
1207         (type (method-combination-type mc))
1208         (options (method-combination-options mc))
1209         (order (car options))
1210         (primaries ())
1211         (arounds ())
1212         around)
1213    (dolist (m methods)
1214      (let ((qualifiers (method-qualifiers m)))
1215        (cond ((null qualifiers)
1216               (if (eq type 'standard)
1217                   (push m primaries)
1218                   (error "method combination type mismatch")))
1219              ((cdr qualifiers)
1220               (error "invalid method qualifiers"))
1221              ((eq (car qualifiers) :around)
1222               (push m arounds))
1223              ((eq (car qualifiers) type)
1224               (push m primaries))
1225              ((memq (car qualifiers) '(:before :after)))
1226              (t
1227               (invalid generic-function combin m)))))
1228    (unless (eq order :most-specific-last)
1229      (setq primaries (nreverse primaries)))
1230    (setq arounds (nreverse arounds))
1231    (setq around (car arounds))
1232    (when (null primaries)
1233      (error "no primary methods for the generic function ~S" gf))
1234    (if around
1235        (let ((next-emfun
1236               (funcall
1237                (if (eq (class-of gf) the-class-standard-gf)
1238                    #'std-compute-effective-method-function
1239                    #'compute-effective-method-function)
1240                gf (remove around methods))))
1241          #'(lambda (args)
1242             (funcall (method-function around) args next-emfun)))
1243        (case type
1244          (STANDARD
1245           (let ((next-emfun (compute-primary-emfun (cdr primaries)))
1246                 (befores (remove-if-not #'before-method-p methods))
1247                 (reverse-afters
1248                  (reverse (remove-if-not #'after-method-p methods))))
1249             #'(lambda (args)
1250                (dolist (before befores)
1251                  (funcall (method-function before) args nil))
1252                (multiple-value-prog1
1253                 (funcall (method-function (car primaries)) args next-emfun)
1254                 (dolist (after reverse-afters)
1255                   (funcall (method-function after) args nil))))))
1256          (LIST
1257           #'(lambda (args)
1258              (let ((result ()))
1259                (dolist (primary primaries)
1260                  (push (funcall (method-function primary) args nil) result))
1261                (nreverse result))))
1262          (APPEND
1263           #'(lambda (args)
1264              (let ((result ()))
1265                (dolist (primary primaries)
1266                  (setf result (append result (funcall (method-function primary) args nil))))
1267                result)))
1268          (NCONC
1269           #'(lambda (args)
1270              (let ((result ()))
1271                (dolist (primary primaries)
1272                  (setf result (nconc result (funcall (method-function primary) args nil))))
1273                result)))
1274          (PROGN
1275           #'(lambda (args)
1276              (let ((result nil))
1277                (dolist (primary primaries)
1278                  (setf result (funcall (method-function primary) args nil)))
1279                result)))
1280          (AND
1281           #'(lambda (args)
1282              (let ((result t))
1283                (dolist (primary primaries)
1284                  (setf result
1285                        (and result
1286                             (funcall (method-function primary) args nil)))
1287                  (unless result (return)))
1288                result)))
1289          (OR
1290           #'(lambda (args)
1291              (let ((result nil))
1292                (dolist (primary primaries)
1293                  (setf result
1294                        (or result
1295                            (funcall (method-function primary) args nil)))
1296                  (when result (return)))
1297                result)))
1298          (+
1299           #'(lambda (args)
1300              (let ((result 0))
1301                (dolist (primary primaries)
1302                  (incf result (funcall (method-function primary) args nil)))
1303                result)))
1304          (MAX
1305           #'(lambda (args)
1306              (let ((result ()))
1307                (dolist (primary primaries)
1308                  (push (funcall (method-function primary) args nil) result))
1309                (apply #'max result))))
1310          (MIN
1311           #'(lambda (args)
1312              (let ((result ()))
1313                (dolist (primary primaries)
1314                  (push (funcall (method-function primary) args nil) result))
1315                (apply #'min result))))
1316          (t
1317           (error "unsupported method combination type ~S" type))))))
1318
1319;;; compute an effective method function from a list of primary methods:
1320
1321(defun compute-primary-emfun (methods)
1322  (if (null methods)
1323      nil
1324      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1325        #'(lambda (args)
1326           (funcall (method-function (car methods)) args next-emfun)))))
1327
1328;;; apply-method and compute-method-function
1329
1330(defun apply-method (method args next-methods)
1331  (funcall (method-function method)
1332           args
1333           (if (null next-methods)
1334               nil
1335               (compute-effective-method-function
1336                (method-generic-function method) next-methods))))
1337
1338(defun std-compute-method-function (method)
1339  (let ((form (method-body method))
1340        (lambda-list (method-lambda-list method)))
1341    (compile-in-lexical-environment
1342     (method-environment method)
1343     `(lambda (args next-emfun)
1344        (flet ((call-next-method (&rest cnm-args)
1345                                 (if (null next-emfun)
1346                                     (error "no next method for generic function ~S"
1347                                            (method-generic-function ',method))
1348                                     (funcall next-emfun (or cnm-args args))))
1349               (next-method-p ()
1350                              (not (null next-emfun))))
1351          (apply #'(lambda ,(kludge-arglist lambda-list)
1352                    ,form)
1353                 args))))))
1354
1355;;; N.B. The function kludge-arglist is used to pave over the differences
1356;;; between argument keyword compatibility for regular functions versus
1357;;; generic functions.
1358
1359(defun kludge-arglist (lambda-list)
1360  (if (and (member '&key lambda-list)
1361           (not (member '&allow-other-keys lambda-list)))
1362      (append lambda-list '(&allow-other-keys))
1363      (if (and (not (member '&rest lambda-list))
1364               (not (member '&key lambda-list)))
1365          (append lambda-list '(&key &allow-other-keys))
1366          lambda-list)))
1367
1368;;; Slot access
1369
1370(defun setf-slot-value-using-class (new-value class instance slot-name)
1371  (setf (std-slot-value instance slot-name) new-value))
1372
1373(defgeneric slot-value-using-class (class instance slot-name))
1374(defmethod slot-value-using-class ((class standard-class) instance slot-name)
1375  (std-slot-value instance slot-name))
1376
1377(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
1378(defmethod (setf slot-value-using-class)
1379  (new-value (class standard-class) instance slot-name)
1380  (setf (std-slot-value instance slot-name) new-value))
1381
1382(defgeneric slot-exists-p-using-class (class instance slot-name))
1383(defmethod slot-exists-p-using-class
1384  ((class standard-class) instance slot-name)
1385  (std-slot-exists-p instance slot-name))
1386
1387(defgeneric slot-boundp-using-class (class instance slot-name))
1388(defmethod slot-boundp-using-class
1389  ((class standard-class) instance slot-name)
1390  (std-slot-boundp instance slot-name))
1391
1392(defgeneric slot-makunbound-using-class (class instance slot-name))
1393(defmethod slot-makunbound-using-class
1394  ((class standard-class) instance slot-name)
1395  (std-slot-makunbound instance slot-name))
1396
1397(defgeneric slot-missing (class instance slot-name operation &optional new-value))
1398(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
1399  (error "the slot ~S is missing from the class ~S" slot-name class))
1400
1401;;; Instance creation and initialization
1402
1403(defgeneric make-instance (class &key))
1404
1405(defmethod make-instance ((class standard-class) &rest initargs)
1406  (let ((class-default-initargs (class-default-initargs class)))
1407    (when class-default-initargs
1408      (let ((default-initargs ())
1409            (not-found (gensym)))
1410        (do* ((list class-default-initargs (cddr list))
1411              (key (car list) (car list))
1412              (fn (cadr list) (cadr list)))
1413             ((null list))
1414          (when (eq (getf initargs key not-found) not-found)
1415            (setf default-initargs (append default-initargs (list key (funcall fn))))))
1416        (setf initargs (append initargs default-initargs)))))
1417  (let ((instance (allocate-instance class)))
1418    (apply #'initialize-instance instance initargs)
1419    instance))
1420
1421(defmethod make-instance ((class symbol) &rest initargs)
1422  (apply #'make-instance (find-class class) initargs))
1423
1424(defgeneric initialize-instance (instance &key))
1425
1426(defmethod initialize-instance ((instance standard-object) &rest initargs)
1427  (apply #'shared-initialize instance t initargs))
1428
1429(defgeneric reinitialize-instance (instance &key))
1430
1431(defmethod reinitialize-instance
1432  ((instance standard-object) &rest initargs)
1433  (apply #'shared-initialize instance () initargs))
1434
1435(defgeneric shared-initialize (instance slot-names &key))
1436
1437(defmethod shared-initialize ((instance standard-object)
1438                              slot-names &rest all-keys)
1439  (dolist (slot (class-slots (class-of instance)))
1440    (let ((slot-name (slot-definition-name slot)))
1441      (multiple-value-bind (init-key init-value foundp)
1442        (get-properties all-keys (slot-definition-initargs slot))
1443        (declare (ignore init-key))
1444        (if foundp
1445            (setf (slot-value instance slot-name) init-value)
1446            (when (and (not (slot-boundp instance slot-name))
1447                       (not (null (slot-definition-initfunction slot)))
1448                       (or (eq slot-names t)
1449                           (member slot-name slot-names)))
1450              (setf (slot-value instance slot-name)
1451                    (funcall (slot-definition-initfunction slot))))))))
1452  instance)
1453
1454;;; change-class
1455
1456(defgeneric change-class (instance new-class &key))
1457(defmethod change-class
1458  ((old-instance standard-object)
1459   (new-class standard-class)
1460   &rest initargs)
1461  (let ((new-instance (allocate-instance new-class)))
1462    (dolist (slot-name (mapcar #'slot-definition-name
1463                               (class-slots new-class)))
1464      (when (and (slot-exists-p old-instance slot-name)
1465                 (slot-boundp old-instance slot-name))
1466        (setf (slot-value new-instance slot-name)
1467              (slot-value old-instance slot-name))))
1468    (rotatef (std-instance-slots new-instance)
1469             (std-instance-slots old-instance))
1470    (rotatef (std-instance-class new-instance)
1471             (std-instance-class old-instance))
1472    (apply #'update-instance-for-different-class
1473           new-instance old-instance initargs)
1474    old-instance))
1475
1476(defmethod change-class
1477  ((instance standard-object) (new-class symbol) &rest initargs)
1478  (apply #'change-class instance (find-class new-class) initargs))
1479
1480(defgeneric update-instance-for-different-class (old new &key))
1481(defmethod update-instance-for-different-class
1482  ((old standard-object) (new standard-object) &rest initargs)
1483  (let ((added-slots
1484         (remove-if #'(lambda (slot-name)
1485                       (slot-exists-p old slot-name))
1486                    (mapcar #'slot-definition-name
1487                            (class-slots (class-of new))))))
1488    (apply #'shared-initialize new added-slots initargs)))
1489
1490;;;  Methods having to do with class metaobjects.
1491
1492(defmethod initialize-instance :after ((class standard-class) &rest args)
1493  (apply #'std-after-initialization-for-classes class args))
1494
1495;;; Finalize inheritance
1496
1497(defgeneric finalize-inheritance (class))
1498(defmethod finalize-inheritance ((class standard-class))
1499  (std-finalize-inheritance class)
1500  (values))
1501
1502;;; Class precedence lists
1503
1504(defgeneric compute-class-precedence-list (class))
1505(defmethod compute-class-precedence-list ((class standard-class))
1506  (std-compute-class-precedence-list class))
1507
1508;;; Slot inheritance
1509
1510(defgeneric compute-slots (class))
1511(defmethod compute-slots ((class standard-class))
1512  (std-compute-slots class))
1513
1514(defgeneric compute-effective-slot-definition (class direct-slots))
1515(defmethod compute-effective-slot-definition
1516  ((class standard-class) direct-slots)
1517  (std-compute-effective-slot-definition class direct-slots))
1518
1519;;; Methods having to do with generic function metaobjects.
1520
1521(defmethod initialize-instance :after ((gf standard-generic-function) &key)
1522  (finalize-generic-function gf))
1523
1524;;; Methods having to do with method metaobjects.
1525
1526(defmethod initialize-instance :after ((method standard-method) &key)
1527  (setf (method-function method) (compute-method-function method)))
1528
1529;;; Methods having to do with generic function invocation.
1530
1531(defgeneric compute-discriminating-function (gf))
1532(defmethod compute-discriminating-function ((gf standard-generic-function))
1533  (std-compute-discriminating-function gf))
1534
1535(defgeneric method-more-specific-p (gf method1 method2 required-classes))
1536(defmethod method-more-specific-p
1537  ((gf standard-generic-function) method1 method2 required-classes)
1538  (std-method-more-specific-p gf method1 method2 required-classes))
1539
1540(defgeneric compute-effective-method-function (gf methods))
1541(defmethod compute-effective-method-function
1542  ((gf standard-generic-function) methods)
1543  (std-compute-effective-method-function gf methods))
1544
1545(defgeneric compute-method-function (method))
1546(defmethod compute-method-function ((method standard-method))
1547  (std-compute-method-function method))
1548
1549(defgeneric compute-applicable-methods (gf args))
1550(defmethod compute-applicable-methods ((gf standard-generic-function) args)
1551  (compute-applicable-methods-using-classes gf (mapcar #'class-of args)))
1552
1553(provide 'clos)
Note: See TracBrowser for help on using the repository browser.