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

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

CANONICALIZE-DIRECT-SLOT: signal error for invalid initialization argument.

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