source: trunk/j/src/org/armedbear/lisp/defclass.lisp @ 4468

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

Work in progress.

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