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

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

Work in progress.

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