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

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

Work in progress.

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