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

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

DEFCLASS: support :DEFAULT-INITARGS option.

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