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

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

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

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