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

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

COMPUTE-APPLICABLE-METHODS

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