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

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

Support :allocation :class slots.

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