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

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

ENSURE-CLASS: check for duplicate argument names in :DEFAULT-INITARGS.

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