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

Last change on this file since 4894 was 4894, checked in by asimon, 18 years ago

SLOW-METHOD-LOOKUP: signal error if there are no applicable methods.

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