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

Last change on this file since 5212 was 5212, checked in by piso, 17 years ago

Work in progress.

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