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

Last change on this file since 5193 was 5193, checked in by piso, 17 years ago

Work in progress.

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