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

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

SLOT-EXISTS-P-USING-CLASS

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