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

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

(defstruct slot-definition ...)

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