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

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

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

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