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

Last change on this file since 4645 was 4645, checked in by piso, 19 years ago

ENSURE-GENERIC-FUNCTION: resolve autoload first if applicable.

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