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

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

Work in progress.

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