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

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

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

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