source: trunk/j/src/org/armedbear/lisp/defclass.lisp @ 4319

Last change on this file since 4319 was 4319, checked in by piso, 19 years ago

Work in progress.

File size: 47.3 KB
Line 
1;;; defclass.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defclass.lisp,v 1.13 2003-10-11 20:41:28 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(in-package "SYSTEM")
21
22(defmacro push-on-end (value location)
23  `(setf ,location (nconc ,location (list ,value))))
24
25;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
26;;; which must be non-nil.
27
28(defun (setf getf*) (new-value plist key)
29  (block body
30    (do ((x plist (cddr x)))
31        ((null x))
32      (when (eq (car x) key)
33        (setf (car (cdr x)) new-value)
34        (return-from body new-value)))
35    (push-on-end key plist)
36    (push-on-end new-value plist)
37    new-value))
38
39(defun mapappend (fun &rest args)
40  (if (some #'null args)
41      ()
42      (append (apply fun (mapcar #'car args))
43              (apply #'mapappend fun (mapcar #'cdr args)))))
44
45(defun mapplist (fun x)
46  (if (null x)
47      ()
48      (cons (funcall fun (car x) (cadr x))
49            (mapplist fun (cddr x)))))
50
51(defsetf class-name %set-class-name)
52(defsetf class-direct-superclasses %set-class-direct-superclasses)
53(defsetf class-direct-subclasses %set-class-direct-subclasses)
54(defsetf class-direct-methods %set-class-direct-methods)
55(defsetf class-direct-slots %set-class-direct-slots)
56(defsetf class-precedence-list %set-class-precedence-list)
57(defsetf class-slots %set-class-slots)
58
59(defun canonicalize-direct-slots (direct-slots)
60  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
61
62(defun canonicalize-direct-slot (spec)
63  (if (symbolp spec)
64      `(list :name ',spec)
65      (let ((name (car spec))
66            (initfunction nil)
67            (initform nil)
68            (initargs ())
69            (readers ())
70            (writers ())
71            (other-options ()))
72        (do ((olist (cdr spec) (cddr olist)))
73            ((null olist))
74          (case (car olist)
75            (:initform
76             (setq initfunction
77                   `(function (lambda () ,(cadr olist))))
78             (setq initform `',(cadr olist)))
79            (:initarg
80             (push-on-end (cadr olist) initargs))
81            (:reader
82             (push-on-end (cadr olist) readers))
83            (:writer
84             (push-on-end (cadr olist) writers))
85            (:accessor
86             (push-on-end (cadr olist) readers)
87             (push-on-end `(setf ,(cadr olist)) writers))
88            (otherwise
89             (push-on-end `',(car olist) other-options)
90             (push-on-end `',(cadr olist) other-options))))
91        `(list
92          :name ',name
93          ,@(when initfunction
94              `(:initform ,initform
95                          :initfunction ,initfunction))
96          ,@(when initargs `(:initargs ',initargs))
97          ,@(when readers `(:readers ',readers))
98          ,@(when writers `(:writers ',writers))
99          ,@other-options))))
100
101(defun canonicalize-direct-superclasses (direct-superclasses)
102  `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses)))
103
104(defun canonicalize-direct-superclass (class-name)
105  `(find-class ',class-name))
106
107(defun canonicalize-defclass-options (options)
108  (mapappend #'canonicalize-defclass-option options))
109
110(defun canonicalize-defclass-option (option)
111  (case (car option)
112    (:metaclass
113     (list ':metaclass
114           `(find-class ',(cadr option))))
115    (:default-initargs
116     (list
117      ':direct-default-initargs
118      `(list ,@(mapappend
119                #'(lambda (x) x)
120                (mapplist
121                 #'(lambda (key value)
122                    `(',key ,value))
123                 (cdr option))))))
124    (t (list `',(car option) `',(cadr option)))))
125
126;;; Slot definition metaobjects
127
128;;; N.B. Quietly retain all unknown slot options (rather than signaling an
129;;; error), so that it's easy to add new ones.
130
131(defun make-direct-slot-definition
132  (&rest properties
133         &key name (initargs ()) (initform nil) (initfunction nil)
134         (readers ()) (writers ()) (allocation :instance)
135         &allow-other-keys)
136  (let ((slot (copy-list properties))) ; Don't want to side effect &rest list
137    (setf (getf* slot ':name) name)
138    (setf (getf* slot ':initargs) initargs)
139    (setf (getf* slot ':initform) initform)
140    (setf (getf* slot ':initfunction) initfunction)
141    (setf (getf* slot ':readers) readers)
142    (setf (getf* slot ':writers) writers)
143    (setf (getf* slot ':allocation) allocation)
144    slot))
145
146(defun make-effective-slot-definition
147  (&rest properties
148         &key name (initargs ()) (initform nil) (initfunction nil)
149         (allocation :instance)
150         &allow-other-keys)
151  (let ((slot (copy-list properties)))  ; Don't want to side effect &rest list
152    (setf (getf* slot ':name) name)
153    (setf (getf* slot ':initargs) initargs)
154    (setf (getf* slot ':initform) initform)
155    (setf (getf* slot ':initfunction) initfunction)
156    (setf (getf* slot ':allocation) allocation)
157    slot))
158
159(defun slot-definition-name (slot)
160  (getf slot ':name))
161(defun (setf slot-definition-name) (new-value slot)
162  (setf (getf* slot ':name) new-value))
163
164(defun slot-definition-initfunction (slot)
165  (getf slot ':initfunction))
166(defun (setf slot-definition-initfunction) (new-value slot)
167  (setf (getf* slot ':initfunction) new-value))
168
169(defun slot-definition-initform (slot)
170  (getf slot ':initform))
171(defun (setf slot-definition-initform) (new-value slot)
172  (setf (getf* slot ':initform) new-value))
173
174(defun slot-definition-initargs (slot)
175  (getf slot ':initargs))
176(defun (setf slot-definition-initargs) (new-value slot)
177  (setf (getf* slot ':initargs) new-value))
178
179(defun slot-definition-readers (slot)
180  (getf slot ':readers))
181(defun (setf slot-definition-readers) (new-value slot)
182  (setf (getf* slot ':readers) new-value))
183
184(defun slot-definition-writers (slot)
185  (getf slot ':writers))
186(defun (setf slot-definition-writers) (new-value slot)
187  (setf (getf* slot ':writers) new-value))
188
189(defun slot-definition-allocation (slot)
190  (getf slot ':allocation))
191(defun (setf slot-definition-allocation) (new-value slot)
192  (setf (getf* slot ':allocation) new-value))
193
194;;; finalize-inheritance
195
196(defun std-finalize-inheritance (class)
197  (setf (class-precedence-list class)
198        (funcall (if (eq (class-of class) the-class-standard-class)
199                     #'std-compute-class-precedence-list
200                     #'compute-class-precedence-list)
201                 class))
202  (setf (class-slots class)
203        (funcall (if (eq (class-of class) the-class-standard-class)
204                     #'std-compute-slots
205                     #'compute-slots)
206                 class))
207  (values))
208
209;;; Class precedence lists
210
211(defun std-compute-class-precedence-list (class)
212  (let ((classes-to-order (collect-superclasses* class)))
213    (topological-sort classes-to-order
214                      (remove-duplicates
215                       (mapappend #'local-precedence-ordering
216                                  classes-to-order))
217                      #'std-tie-breaker-rule)))
218
219;;; topological-sort implements the standard algorithm for topologically
220;;; sorting an arbitrary set of elements while honoring the precedence
221;;; constraints given by a set of (X,Y) pairs that indicate that element
222;;; X must precede element Y.  The tie-breaker procedure is called when it
223;;; is necessary to choose from multiple minimal elements; both a list of
224;;; candidates and the ordering so far are provided as arguments.
225
226(defun topological-sort (elements constraints tie-breaker)
227  (let ((remaining-constraints constraints)
228        (remaining-elements elements)
229        (result ()))
230    (loop
231      (let ((minimal-elements
232             (remove-if
233              #'(lambda (class)
234                 (member class remaining-constraints
235                         :key #'cadr))
236              remaining-elements)))
237        (when (null minimal-elements)
238          (if (null remaining-elements)
239              (return-from topological-sort result)
240              (error "Inconsistent precedence graph.")))
241        (let ((choice (if (null (cdr minimal-elements))
242                          (car minimal-elements)
243                          (funcall tie-breaker
244                                   minimal-elements
245                                   result))))
246          (setq result (append result (list choice)))
247          (setq remaining-elements
248                (remove choice remaining-elements))
249          (setq remaining-constraints
250                (remove choice
251                        remaining-constraints
252                        :test #'member)))))))
253
254;;; In the event of a tie while topologically sorting class precedence lists,
255;;; the CLOS Specification says to "select the one that has a direct subclass
256;;; rightmost in the class precedence list computed so far."  The same result
257;;; is obtained by inspecting the partially constructed class precedence list
258;;; from right to left, looking for the first minimal element to show up among
259;;; the direct superclasses of the class precedence list constituent.
260;;; (There's a lemma that shows that this rule yields a unique result.)
261
262(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
263  (dolist (cpl-constituent (reverse cpl-so-far))
264    (let* ((supers (class-direct-superclasses cpl-constituent))
265           (common (intersection minimal-elements supers)))
266      (when (not (null common))
267        (return-from std-tie-breaker-rule (car common))))))
268
269;;; This version of collect-superclasses* isn't bothered by cycles in the class
270;;; hierarchy, which sometimes happen by accident.
271
272(defun collect-superclasses* (class)
273  (labels ((all-superclasses-loop (seen superclasses)
274                                  (let ((to-be-processed
275                                         (set-difference superclasses seen)))
276                                    (if (null to-be-processed)
277                                        superclasses
278                                        (let ((class-to-process
279                                               (car to-be-processed)))
280                                          (all-superclasses-loop
281                                           (cons class-to-process seen)
282                                           (union (class-direct-superclasses
283                                                   class-to-process)
284                                                  superclasses)))))))
285          (all-superclasses-loop () (list class))))
286
287;;; The local precedence ordering of a class C with direct superclasses C_1,
288;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
289
290(defun local-precedence-ordering (class)
291  (mapcar #'list
292          (cons class
293                (butlast (class-direct-superclasses class)))
294          (class-direct-superclasses class)))
295
296;;; Slot inheritance
297
298(defun std-compute-slots (class)
299  (let* ((all-slots (mapappend #'class-direct-slots
300                               (class-precedence-list class)))
301         (all-names (remove-duplicates
302                     (mapcar #'slot-definition-name all-slots))))
303    (mapcar #'(lambda (name)
304               (funcall
305                (if (eq (class-of class) the-class-standard-class)
306                    #'std-compute-effective-slot-definition
307                    #'compute-effective-slot-definition)
308                class
309                (remove name all-slots
310                        :key #'slot-definition-name
311                        :test-not #'eq)))
312            all-names)))
313
314(defun std-compute-effective-slot-definition (class direct-slots)
315  (declare (ignore class))
316  (let ((initer (find-if-not #'null direct-slots
317                             :key #'slot-definition-initfunction)))
318    (make-effective-slot-definition
319     :name (slot-definition-name (car direct-slots))
320     :initform (if initer
321                   (slot-definition-initform initer)
322                   nil)
323     :initfunction (if initer
324                       (slot-definition-initfunction initer)
325                       nil)
326     :initargs (remove-duplicates
327                (mapappend #'slot-definition-initargs
328                           direct-slots))
329     :allocation (slot-definition-allocation (car direct-slots)))))
330
331;;; Simple vectors are used for slot storage.
332
333(defun allocate-slot-storage (size initial-value)
334  (make-array size :initial-element initial-value))
335
336;;; Standard instance slot access
337
338;;; N.B. The location of the effective-slots slots in the class metaobject for
339;;; standard-class must be determined without making any further slot
340;;; references.
341
342(defvar the-slots-of-standard-class) ;standard-class's class-slots
343(defvar the-class-standard-class (find-class 'standard-class))
344
345(defun slot-location (class slot-name)
346  (if (and (eq slot-name 'effective-slots)
347           (eq class the-class-standard-class))
348      (position 'effective-slots the-slots-of-standard-class
349                :key #'slot-definition-name)
350      (let ((slot (find slot-name
351                        (class-slots class)
352                        :key #'slot-definition-name)))
353        (if (null slot)
354            (error "the slot ~S is missing from the class ~S"
355                   slot-name class)
356            (let ((pos (position slot
357                                 (remove-if-not #'instance-slot-p
358                                                (class-slots class)))))
359              (if (null pos)
360                  (error "the slot ~S is not an instance slot in the class ~S"
361                         slot-name class)
362                  pos))))))
363
364(defun slot-contents (slots location)
365  (svref slots location))
366
367(defun (setf slot-contents) (new-value slots location)
368  (setf (svref slots location) new-value))
369
370(defun std-slot-value (instance slot-name)
371  (let* ((location (slot-location (class-of instance) slot-name))
372         (slots (std-instance-slots instance))
373         (val (slot-contents slots location)))
374    (if (eq secret-unbound-value val)
375        (error "The slot ~S is unbound in the object ~S."
376               slot-name instance)
377        val)))
378(defun slot-value (object slot-name)
379  (if (eq (class-of (class-of object)) the-class-standard-class)
380      (std-slot-value object slot-name)
381      (slot-value-using-class (class-of object) object slot-name)))
382
383(defun (setf std-slot-value) (new-value instance slot-name)
384  (let ((location (slot-location (class-of instance) slot-name))
385        (slots (std-instance-slots instance)))
386    (setf (slot-contents slots location) new-value)))
387(defun (setf slot-value) (new-value object slot-name)
388  (if (eq (class-of (class-of object)) the-class-standard-class)
389      (setf (std-slot-value object slot-name) new-value)
390      (setf-slot-value-using-class
391       new-value (class-of object) object slot-name)))
392
393(defun std-slot-boundp (instance slot-name)
394  (let ((location (slot-location (class-of instance) slot-name))
395        (slots (std-instance-slots instance)))
396    (not (eq secret-unbound-value (slot-contents slots location)))))
397(defun slot-boundp (object slot-name)
398  (if (eq (class-of (class-of object)) the-class-standard-class)
399      (std-slot-boundp object slot-name)
400      (slot-boundp-using-class (class-of object) object slot-name)))
401
402(defun std-slot-makunbound (instance slot-name)
403  (let ((location (slot-location (class-of instance) slot-name))
404        (slots (std-instance-slots instance)))
405    (setf (slot-contents slots location) secret-unbound-value))
406  instance)
407(defun slot-makunbound (object slot-name)
408  (if (eq (class-of (class-of object)) the-class-standard-class)
409      (std-slot-makunbound object slot-name)
410      (slot-makunbound-using-class (class-of object) object slot-name)))
411
412(defun std-slot-exists-p (instance slot-name)
413  (not (null (find slot-name (class-slots (class-of instance))
414                   :key #'slot-definition-name))))
415(defun slot-exists-p (object slot-name)
416  (if (eq (class-of (class-of object)) the-class-standard-class)
417      (std-slot-exists-p object slot-name)
418      (slot-exists-p-using-class (class-of object) object slot-name)))
419
420;;; Standard instance allocation
421
422(defparameter secret-unbound-value (list "slot unbound"))
423
424(defun instance-slot-p (slot)
425  (eq (slot-definition-allocation slot) ':instance))
426
427(defun std-allocate-instance (class)
428;;   (format t "std-allocate-instance class = ~S~%" class)
429;;   (format t "class-slots = ~S~%" (class-slots class))
430  (allocate-std-instance
431   class
432   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
433                          secret-unbound-value)))
434
435(defun allocate-instance (class)
436  (std-allocate-instance class))
437
438(defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots
439                                               &allow-other-keys)
440  (declare (ignore metaclass))
441;;   (format t "name = ~S~%" name)
442;;   (format t "direct-superclasses = ~S~%" direct-superclasses)
443;;   (format t "direct-slots = ~S~%" direct-slots)
444  (let ((class (std-allocate-instance (find-class 'standard-class))))
445    (setf (class-name class) name)
446    (setf (class-direct-subclasses class) ())
447    (setf (class-direct-methods class) ())
448    (std-after-initialization-for-classes class
449                                          :direct-slots direct-slots
450                                          :direct-superclasses direct-superclasses)
451    class))
452
453;; FIXME
454(defun std-after-initialization-for-classes (class
455                                             &key direct-superclasses direct-slots
456                                             &allow-other-keys)
457  (let ((supers
458         (or direct-superclasses
459             (list (find-class 'standard-object)))))
460    (setf (class-direct-superclasses class) supers)
461    (dolist (superclass supers)
462      (push class (class-direct-subclasses superclass))))
463  (let ((slots
464         (mapcar #'(lambda (slot-properties)
465                    (apply #'make-direct-slot-definition
466                           slot-properties))
467                 direct-slots)))
468;;     (format t "slots = ~S~%" slots)
469    (setf (class-direct-slots class) slots)
470    (dolist (direct-slot slots)
471      (dolist (reader (slot-definition-readers direct-slot))
472        (add-reader-method
473         class reader (slot-definition-name direct-slot)))
474      (dolist (writer (slot-definition-writers direct-slot))
475        (add-writer-method
476         class writer (slot-definition-name direct-slot))))
477    )
478  (funcall (if (eq (class-of class) (find-class 'standard-class))
479               #'std-finalize-inheritance
480               #'finalize-inheritance)
481           class)
482  (values))
483
484(defun ensure-class (name &rest all-keys &allow-other-keys)
485  (let ((class (find-class name nil)))
486    (unless class
487      (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
488      (add-class class))
489    class))
490
491(defmacro defclass (name direct-superclasses direct-slots
492                         &rest options)
493  `(ensure-class ',name
494                 :direct-superclasses
495                 ,(canonicalize-direct-superclasses direct-superclasses)
496                 :direct-slots
497                 ,(canonicalize-direct-slots direct-slots)
498                 ,@(canonicalize-defclass-options options)))
499
500;;;
501;;; Generic function metaobjects and standard-generic-function
502;;;
503
504(defclass standard-generic-function (generic-function)
505  ((name :initarg :name)      ; :accessor generic-function-name
506   (lambda-list               ; :accessor generic-function-lambda-list
507    :initarg :lambda-list)
508   (methods :initform ())     ; :accessor generic-function-methods
509   (method-class              ; :accessor generic-function-method-class
510    :initarg :method-class)
511   (discriminating-function)  ; :accessor generic-function-
512   ;    -discriminating-function
513   (classes-to-emf-table      ; :accessor classes-to-emf-table
514    :initform (make-hash-table :test #'equal))))
515
516(defvar the-class-standard-gf (find-class 'standard-generic-function))
517
518(defun generic-function-name (gf)
519  (slot-value gf 'name))
520(defun (setf generic-function-name) (new-value gf)
521  (setf (slot-value gf 'name) new-value))
522
523(defun generic-function-lambda-list (gf)
524  (slot-value gf 'lambda-list))
525(defun (setf generic-function-lambda-list) (new-value gf)
526  (setf (slot-value gf 'lambda-list) new-value))
527
528(defun generic-function-methods (gf)
529  (slot-value gf 'methods))
530(defun (setf generic-function-methods) (new-value gf)
531  (setf (slot-value gf 'methods) new-value))
532
533(defun generic-function-discriminating-function (gf)
534  (slot-value gf 'discriminating-function))
535(defun (setf generic-function-discriminating-function) (new-value gf)
536  (setf (slot-value gf 'discriminating-function) new-value))
537
538(defun generic-function-method-class (gf)
539  (slot-value gf 'method-class))
540(defun (setf generic-function-method-class) (new-value gf)
541  (setf (slot-value gf 'method-class) new-value))
542
543;;; Internal accessor for effective method function table
544
545(defun classes-to-emf-table (gf)
546  (slot-value gf 'classes-to-emf-table))
547(defun (setf classes-to-emf-table) (new-value gf)
548  (setf (slot-value gf 'classes-to-emf-table) new-value))
549
550;;;
551;;; Method metaobjects and standard-method
552;;;
553
554(defclass standard-method ()
555  ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
556   (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
557   (specializers :initarg :specializers)   ; :accessor method-specializers
558   (body :initarg :body)                   ; :accessor method-body
559   (environment :initarg :environment)     ; :accessor method-environment
560   (generic-function :initform nil)        ; :accessor method-generic-function
561   (function)))                            ; :accessor method-function
562
563(defvar the-class-standard-method (find-class 'standard-method))
564
565(defun method-lambda-list (method) (slot-value method 'lambda-list))
566(defun (setf method-lambda-list) (new-value method)
567  (setf (slot-value method 'lambda-list) new-value))
568
569(defun method-qualifiers (method) (slot-value method 'qualifiers))
570(defun (setf method-qualifiers) (new-value method)
571  (setf (slot-value method 'qualifiers) new-value))
572
573(defun method-specializers (method) (slot-value method 'specializers))
574(defun (setf method-specializers) (new-value method)
575  (setf (slot-value method 'specializers) new-value))
576
577(defun method-body (method) (slot-value method 'body))
578(defun (setf method-body) (new-value method)
579  (setf (slot-value method 'body) new-value))
580
581(defun method-environment (method) (slot-value method 'environment))
582(defun (setf method-environment) (new-value method)
583  (setf (slot-value method 'environment) new-value))
584
585(defun method-generic-function (method)
586  (slot-value method 'generic-function))
587(defun (setf method-generic-function) (new-value method)
588  (setf (slot-value method 'generic-function) new-value))
589
590(defun method-function (method) (slot-value method 'function))
591(defun (setf method-function) (new-value method)
592  (setf (slot-value method 'function) new-value))
593
594;;; defgeneric
595
596(defmacro defgeneric (function-name lambda-list
597                                    &rest options-and-method-descriptions)
598  (let ((options ())
599        (methods ()))
600    (dolist (item options-and-method-descriptions)
601      (case (car item)
602        (declare) ; FIXME
603        (:method
604         (push `(defmethod ,function-name ,@(cdr item)) methods))
605        (t
606         (push item options))))
607    (setf options (nreverse options)
608          methods (nreverse methods))
609    `(prog1
610       (ensure-generic-function
611        ',function-name
612        :lambda-list ',lambda-list
613        ,@(canonicalize-defgeneric-options options))
614       ,@methods)))
615
616(defun canonicalize-defgeneric-options (options)
617  (mapappend #'canonicalize-defgeneric-option options))
618
619(defun canonicalize-defgeneric-option (option)
620  (case (car option)
621    (:generic-function-class
622     (list ':generic-function-class
623           `(find-class ',(cadr option))))
624    (:method-class
625     (list ':method-class
626           `(find-class ',(cadr option))))
627    (t (list `',(car option) `',(cadr option)))))
628
629;;; find-generic-function looks up a generic function by name.  It's an
630;;; artifact of the fact that our generic function metaobjects can't legally
631;;; be stored a symbol's function value.
632
633(defparameter generic-function-table (make-hash-table :test #'equal))
634
635(defun find-generic-function (symbol &optional (errorp t))
636  (let ((gf (gethash symbol generic-function-table nil)))
637    (if (and (null gf) errorp)
638        (error "no generic function named ~S" symbol)
639        gf)))
640
641(defun (setf find-generic-function) (new-value symbol)
642  (setf (gethash symbol generic-function-table) new-value))
643
644;;; ensure-generic-function
645
646(defun ensure-generic-function
647  (function-name
648   &rest all-keys
649   &key (generic-function-class the-class-standard-gf)
650   (method-class the-class-standard-method)
651   &allow-other-keys)
652;;   (format t "ensure-generic-function function-name = ~S~%" function-name)
653;;   (when (fboundp function-name)
654;;     (error "~A already names an ordinary function, macro, or special operator"
655;;            function-name))
656  (if (find-generic-function function-name nil)
657      (find-generic-function function-name)
658      (progn
659        (when (fboundp function-name)
660          (error "~A already names an ordinary function, macro, or special operator"
661                 function-name))
662        (let ((gf (apply (if (eq generic-function-class the-class-standard-gf)
663                             #'make-instance-standard-generic-function
664                             #'make-instance)
665                         generic-function-class
666                         :name function-name
667                         :method-class method-class
668                         all-keys)))
669          (setf (find-generic-function function-name) gf)
670          gf))))
671
672;;; finalize-generic-function
673
674;;; N.B. Same basic idea as finalize-inheritance.  Takes care of recomputing
675;;; and storing the discriminating function, and clearing the effective method
676;;; function table.
677
678(defun finalize-generic-function (gf)
679  (setf (generic-function-discriminating-function gf)
680        (funcall (if (eq (class-of gf) the-class-standard-gf)
681                     #'std-compute-discriminating-function
682                     #'compute-discriminating-function)
683                 gf))
684  (setf (fdefinition (generic-function-name gf))
685        (generic-function-discriminating-function gf))
686  (clrhash (classes-to-emf-table gf))
687  (values))
688
689;;; make-instance-standard-generic-function creates and initializes an
690;;; instance of standard-generic-function without falling into method lookup.
691;;; However, it cannot be called until standard-generic-function exists.
692
693(defun make-instance-standard-generic-function (generic-function-class
694                                                &key name lambda-list method-class)
695  (declare (ignore generic-function-class))
696  (let ((gf (std-allocate-instance the-class-standard-gf)))
697;;     (format t "gf = ~S~%" gf)
698    (setf (generic-function-name gf) name)
699    (setf (generic-function-lambda-list gf) lambda-list)
700    (setf (generic-function-methods gf) ())
701    (setf (generic-function-method-class gf) method-class)
702    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
703    (finalize-generic-function gf)
704    gf))
705
706;;; Run-time environment hacking (Common Lisp ain't got 'em).
707
708(defun top-level-environment ()
709  nil) ; Bogus top level lexical environment
710
711(defvar compile-methods nil)      ; by default, run everything interpreted
712
713(defun compile-in-lexical-environment (env lambda-expr)
714  (declare (ignore env))
715  (if compile-methods
716      (compile nil lambda-expr)
717      (eval `(function ,lambda-expr))))
718
719;;; defmethod
720
721(defmacro defmethod (&rest args)
722  (multiple-value-bind (function-name qualifiers lambda-list specializers
723                                      body)
724    (parse-defmethod args)
725    `(progn
726      (ensure-generic-function
727       ',function-name
728       :lambda-list ',lambda-list)
729      (ensure-method (find-generic-function ',function-name)
730                     :lambda-list ',lambda-list
731                     :qualifiers ',qualifiers
732                     :specializers ,(canonicalize-specializers specializers)
733                     :body ',body
734                     :environment (top-level-environment)))))
735
736(defun canonicalize-specializers (specializers)
737  `(list ,@(mapcar #'canonicalize-specializer specializers)))
738
739(defun canonicalize-specializer (specializer)
740  ;; FIXME (EQL specializers)
741  `(if (atom ',specializer) (find-class ',specializer) (find-class 't)))
742
743(defun parse-defmethod (args)
744  (let ((fn-spec (car args))
745        (qualifiers ())
746        (specialized-lambda-list nil)
747        (body ())
748        (parse-state :qualifiers))
749    (dolist (arg (cdr args))
750      (ecase parse-state
751        (:qualifiers
752         (if (and (atom arg) (not (null arg)))
753             (push-on-end arg qualifiers)
754             (progn (setq specialized-lambda-list arg)
755               (setq parse-state :body))))
756        (:body (push-on-end arg body))))
757    (values fn-spec
758            qualifiers
759            (extract-lambda-list specialized-lambda-list)
760            (extract-specializers specialized-lambda-list)
761            (list* 'block
762                   (if (consp fn-spec)
763                       (cadr fn-spec)
764                       fn-spec)
765                   body))))
766
767;;; Several tedious functions for analyzing lambda lists
768
769(defun required-portion (gf args)
770  (let ((number-required (length (gf-required-arglist gf))))
771    (when (< (length args) number-required)
772      (error "Too few arguments to generic function ~S." gf))
773    (subseq args 0 number-required)))
774
775(defun gf-required-arglist (gf)
776  (let ((plist
777         (analyze-lambda-list
778          (generic-function-lambda-list gf))))
779    (getf plist ':required-args)))
780
781(defun extract-lambda-list (specialized-lambda-list)
782  (let* ((plist (analyze-lambda-list specialized-lambda-list))
783         (requireds (getf plist ':required-names))
784         (rv (getf plist ':rest-var))
785         (ks (getf plist ':key-args))
786         (aok (getf plist ':allow-other-keys))
787         (opts (getf plist ':optional-args))
788         (auxs (getf plist ':auxiliary-args)))
789    `(,@requireds
790      ,@(if rv `(&rest ,rv) ())
791      ,@(if (or ks aok) `(&key ,@ks) ())
792      ,@(if aok '(&allow-other-keys) ())
793      ,@(if opts `(&optional ,@opts) ())
794      ,@(if auxs `(&aux ,@auxs) ()))))
795
796(defun extract-specializers (specialized-lambda-list)
797  (let ((plist (analyze-lambda-list specialized-lambda-list)))
798    (getf plist ':specializers)))
799
800(defun analyze-lambda-list (lambda-list)
801  (labels ((make-keyword (symbol)
802                         (intern (symbol-name symbol)
803                                 (find-package 'keyword)))
804           (get-keyword-from-arg (arg)
805                                 (if (listp arg)
806                                     (if (listp (car arg))
807                                         (caar arg)
808                                         (make-keyword (car arg)))
809                                     (make-keyword arg))))
810          (let ((keys ())           ; Just the keywords
811                (key-args ())       ; Keywords argument specs
812                (required-names ()) ; Just the variable names
813                (required-args ())  ; Variable names & specializers
814                (specializers ())   ; Just the specializers
815                (rest-var nil)
816                (optionals ())
817                (auxs ())
818                (allow-other-keys nil)
819                (state :parsing-required))
820            (dolist (arg lambda-list)
821              (if (member arg lambda-list-keywords)
822                  (ecase arg
823                    (&optional
824                     (setq state :parsing-optional))
825                    (&rest
826                     (setq state :parsing-rest))
827                    (&key
828                     (setq state :parsing-key))
829                    (&allow-other-keys
830                     (setq allow-other-keys 't))
831                    (&aux
832                     (setq state :parsing-aux)))
833                  (case state
834                    (:parsing-required
835                     (push-on-end arg required-args)
836                     (if (listp arg)
837                         (progn (push-on-end (car arg) required-names)
838                           (push-on-end (cadr arg) specializers))
839                         (progn (push-on-end arg required-names)
840                           (push-on-end 't specializers))))
841                    (:parsing-optional (push-on-end arg optionals))
842                    (:parsing-rest (setq rest-var arg))
843                    (:parsing-key
844                     (push-on-end (get-keyword-from-arg arg) keys)
845                     (push-on-end arg key-args))
846                    (:parsing-aux (push-on-end arg auxs)))))
847            (list  :required-names required-names
848                   :required-args required-args
849                   :specializers specializers
850                   :rest-var rest-var
851                   :keywords keys
852                   :key-args key-args
853                   :auxiliary-args auxs
854                   :optional-args optionals
855                   :allow-other-keys allow-other-keys))))
856
857;;; ensure method
858
859(defun ensure-method (gf &rest all-keys)
860  (let ((new-method
861         (apply
862          (if (eq (generic-function-method-class gf)
863                  the-class-standard-method)
864              #'make-instance-standard-method
865              #'make-instance)
866          (generic-function-method-class gf)
867          all-keys)))
868    (add-method gf new-method)
869    new-method))
870
871;;; make-instance-standard-method creates and initializes an instance of
872;;; standard-method without falling into method lookup.  However, it cannot
873;;; be called until standard-method exists.
874
875(defun make-instance-standard-method (method-class
876                                      &key lambda-list qualifiers
877                                      specializers body environment)
878  (declare (ignore method-class))
879  (let ((method (std-allocate-instance the-class-standard-method)))
880    (setf (method-lambda-list method) lambda-list)
881    (setf (method-qualifiers method) qualifiers)
882    (setf (method-specializers method) specializers)
883    (setf (method-body method) body)
884    (setf (method-environment method) environment)
885    (setf (method-generic-function method) nil)
886    (setf (method-function method)
887          (std-compute-method-function method))
888    method))
889
890;;; add-method
891
892;;; N.B. This version first removes any existing method on the generic function
893;;; with the same qualifiers and specializers.  It's a pain to develop
894;;; programs without this feature of full CLOS.
895
896(defun add-method (gf method)
897  (let ((old-method
898         (find-method gf (method-qualifiers method)
899                      (method-specializers method) nil)))
900    (when old-method (remove-method gf old-method)))
901  (setf (method-generic-function method) gf)
902  (push method (generic-function-methods gf))
903  (dolist (specializer (method-specializers method))
904    (pushnew method (class-direct-methods specializer)))
905  (finalize-generic-function gf)
906  method)
907
908(defun remove-method (gf method)
909  (setf (generic-function-methods gf)
910        (remove method (generic-function-methods gf)))
911  (setf (method-generic-function method) nil)
912;;   (format t "remove-method method-specializers = ~S~%" (method-specializers method))
913  (dolist (class (method-specializers method))
914    (setf (class-direct-methods class)
915          (remove method (class-direct-methods class))))
916  (finalize-generic-function gf)
917  method)
918
919(defun find-method (gf qualifiers specializers
920                       &optional (errorp t))
921  (let ((method
922         (find-if #'(lambda (method)
923                     (and (equal qualifiers
924                                 (method-qualifiers method))
925                          (equal specializers
926                                 (method-specializers method))))
927                  (generic-function-methods gf))))
928    (if (and (null method) errorp)
929        (error "No such method for ~S." (generic-function-name gf))
930        method)))
931
932;;; Reader and write methods
933
934(defun add-reader-method (class fn-name slot-name)
935;;   (format t "add-reader-method ~S~%" fn-name)
936  (ensure-method
937   (ensure-generic-function fn-name :lambda-list '(object))
938   :lambda-list '(object)
939   :qualifiers ()
940   :specializers (list class)
941   :body `(slot-value object ',slot-name)
942   :environment (top-level-environment))
943  (values))
944
945(defun add-writer-method (class fn-name slot-name)
946  (ensure-method
947   (ensure-generic-function
948    fn-name :lambda-list '(new-value object))
949   :lambda-list '(new-value object)
950   :qualifiers ()
951   :specializers (list (find-class 't) class)
952   :body `(setf (slot-value object ',slot-name)
953                new-value)
954   :environment (top-level-environment))
955  (values))
956
957;;; subclassp and sub-specializer-p
958
959(defun subclassp (c1 c2)
960  (not (null (find c2 (class-precedence-list c1)))))
961
962(defun sub-specializer-p (c1 c2 c-arg)
963  (let ((cpl (class-precedence-list c-arg)))
964    (not (null (find c2 (cdr (member c1 cpl)))))))
965
966;;;
967;;; Generic function invocation
968;;;
969
970;;; apply-generic-function
971
972(defun apply-generic-function (gf args)
973  (apply (generic-function-discriminating-function gf) args))
974
975;;; compute-discriminating-function
976
977(defun std-compute-discriminating-function (gf)
978  #'(lambda (&rest args)
979     (let* ((classes (mapcar #'class-of
980                             (required-portion gf args)))
981            (emfun (gethash classes (classes-to-emf-table gf) nil)))
982       (if emfun
983           (funcall emfun args)
984           (slow-method-lookup gf args classes)))))
985
986(defun slow-method-lookup (gf args classes)
987  (let* ((applicable-methods
988          (compute-applicable-methods-using-classes gf classes))
989         (emfun
990          (funcall
991           (if (eq (class-of gf) the-class-standard-gf)
992               #'std-compute-effective-method-function
993               #'compute-effective-method-function)
994           gf applicable-methods)))
995    (setf (gethash classes (classes-to-emf-table gf)) emfun)
996    (funcall emfun args)))
997
998;;; compute-applicable-methods-using-classes
999
1000(defun compute-applicable-methods-using-classes
1001  (gf required-classes)
1002  (sort
1003   (copy-list
1004    (remove-if-not #'(lambda (method)
1005                      (every #'subclassp
1006                             required-classes
1007                             (method-specializers method)))
1008                   (generic-function-methods gf)))
1009   #'(lambda (m1 m2)
1010      (funcall
1011       (if (eq (class-of gf) the-class-standard-gf)
1012           #'std-method-more-specific-p
1013           #'method-more-specific-p)
1014       gf m1 m2 required-classes))))
1015
1016;;; method-more-specific-p
1017
1018(defun std-method-more-specific-p (gf method1 method2 required-classes)
1019  (declare (ignore gf))
1020  (mapc #'(lambda (spec1 spec2 arg-class)
1021           (unless (eq spec1 spec2)
1022             (return-from std-method-more-specific-p
1023                          (sub-specializer-p spec1 spec2 arg-class))))
1024        (method-specializers method1)
1025        (method-specializers method2)
1026        required-classes)
1027  nil)
1028
1029;;; apply-methods and compute-effective-method-function
1030
1031(defun apply-methods (gf args methods)
1032  (funcall (compute-effective-method-function gf methods)
1033           args))
1034
1035(defun primary-method-p (method)
1036  (null (method-qualifiers method)))
1037(defun before-method-p (method)
1038  (equal '(:before) (method-qualifiers method)))
1039(defun after-method-p (method)
1040  (equal '(:after) (method-qualifiers method)))
1041(defun around-method-p (method)
1042  (equal '(:around) (method-qualifiers method)))
1043
1044(defun std-compute-effective-method-function (gf methods)
1045  (let ((primaries (remove-if-not #'primary-method-p methods))
1046        (around (find-if #'around-method-p methods)))
1047    (when (null primaries)
1048      (error "No primary methods for the~@
1049      generic function ~S." gf))
1050    (if around
1051        (let ((next-emfun
1052               (funcall
1053                (if (eq (class-of gf) the-class-standard-gf)
1054                    #'std-compute-effective-method-function
1055                    #'compute-effective-method-function)
1056                gf (remove around methods))))
1057          #'(lambda (args)
1058             (funcall (method-function around) args next-emfun)))
1059        (let ((next-emfun (compute-primary-emfun (cdr primaries)))
1060              (befores (remove-if-not #'before-method-p methods))
1061              (reverse-afters
1062               (reverse (remove-if-not #'after-method-p methods))))
1063          #'(lambda (args)
1064             (dolist (before befores)
1065               (funcall (method-function before) args nil))
1066             (multiple-value-prog1
1067              (funcall (method-function (car primaries)) args next-emfun)
1068              (dolist (after reverse-afters)
1069                (funcall (method-function after) args nil))))))))
1070
1071;;; compute an effective method function from a list of primary methods:
1072
1073(defun compute-primary-emfun (methods)
1074  (if (null methods)
1075      nil
1076      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1077        #'(lambda (args)
1078           (funcall (method-function (car methods)) args next-emfun)))))
1079
1080;;; apply-method and compute-method-function
1081
1082(defun apply-method (method args next-methods)
1083  (funcall (method-function method)
1084           args
1085           (if (null next-methods)
1086               nil
1087               (compute-effective-method-function
1088                (method-generic-function method) next-methods))))
1089
1090(defun std-compute-method-function (method)
1091  (let ((form (method-body method))
1092        (lambda-list (method-lambda-list method)))
1093    (compile-in-lexical-environment (method-environment method)
1094                                    `(lambda (args next-emfun)
1095                                       (flet ((call-next-method (&rest cnm-args)
1096                                                                (if (null next-emfun)
1097                                                                    (error "No next method for the~@
1098                                                                    generic function ~S."
1099                                                                           (method-generic-function ',method))
1100                                                                    (funcall next-emfun (or cnm-args args))))
1101                                              (next-method-p ()
1102                                                             (not (null next-emfun))))
1103                                         (apply #'(lambda ,(kludge-arglist lambda-list)
1104                                                   ,form)
1105                                                args))))))
1106
1107;;; N.B. The function kludge-arglist is used to pave over the differences
1108;;; between argument keyword compatibility for regular functions versus
1109;;; generic functions.
1110
1111(defun kludge-arglist (lambda-list)
1112  (if (and (member '&key lambda-list)
1113           (not (member '&allow-other-keys lambda-list)))
1114      (append lambda-list '(&allow-other-keys))
1115      (if (and (not (member '&rest lambda-list))
1116               (not (member '&key lambda-list)))
1117          (append lambda-list '(&key &allow-other-keys))
1118          lambda-list)))
1119
1120;;; Slot access
1121
1122(defun setf-slot-value-using-class (new-value class instance slot-name)
1123  (setf (std-slot-value instance slot-name) new-value))
1124
1125(defgeneric slot-value-using-class (class instance slot-name))
1126(defmethod slot-value-using-class ((class standard-class) instance slot-name)
1127  (std-slot-value instance slot-name))
1128
1129(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
1130(defmethod (setf slot-value-using-class)
1131  (new-value (class standard-class) instance slot-name)
1132  (setf (std-slot-value instance slot-name) new-value))
1133;;; N.B. To avoid making a forward reference to a (setf xxx) generic function:
1134;; (defun setf-slot-value-using-class (new-value class object slot-name)
1135;;   (setf (slot-value-using-class class object slot-name) new-value))
1136
1137(defgeneric slot-exists-p-using-class (class instance slot-name))
1138(defmethod slot-exists-p-using-class
1139  ((class standard-class) instance slot-name)
1140  (std-slot-exists-p instance slot-name))
1141
1142(defgeneric slot-boundp-using-class (class instance slot-name))
1143(defmethod slot-boundp-using-class
1144  ((class standard-class) instance slot-name)
1145  (std-slot-boundp instance slot-name))
1146
1147(defgeneric slot-makunbound-using-class (class instance slot-name))
1148(defmethod slot-makunbound-using-class
1149  ((class standard-class) instance slot-name)
1150  (std-slot-makunbound instance slot-name))
1151
1152;;; Instance creation and initialization
1153
1154;; (defgeneric allocate-instance (class))
1155;; (defmethod allocate-instance ((class standard-class))
1156;;   (std-allocate-instance class))
1157
1158(defgeneric make-instance (class &key))
1159(defmethod make-instance ((class standard-class) &rest initargs)
1160  (let ((instance (allocate-instance class)))
1161    (apply #'initialize-instance instance initargs)
1162    instance))
1163(defmethod make-instance ((class symbol) &rest initargs)
1164  (apply #'make-instance (find-class class) initargs))
1165
1166(defgeneric initialize-instance (instance &key))
1167(defmethod initialize-instance ((instance standard-object) &rest initargs)
1168  (apply #'shared-initialize instance t initargs))
1169
1170(defgeneric reinitialize-instance (instance &key))
1171(defmethod reinitialize-instance
1172  ((instance standard-object) &rest initargs)
1173  (apply #'shared-initialize instance () initargs))
1174
1175(defgeneric shared-initialize (instance slot-names &key))
1176(defmethod shared-initialize ((instance standard-object)
1177                              slot-names &rest all-keys)
1178  (dolist (slot (class-slots (class-of instance)))
1179    (let ((slot-name (slot-definition-name slot)))
1180      (multiple-value-bind (init-key init-value foundp)
1181        (get-properties
1182         all-keys (slot-definition-initargs slot))
1183        (declare (ignore init-key))
1184        (if foundp
1185            (setf (slot-value instance slot-name) init-value)
1186            (when (and (not (slot-boundp instance slot-name))
1187                       (not (null (slot-definition-initfunction slot)))
1188                       (or (eq slot-names t)
1189                           (member slot-name slot-names)))
1190              (setf (slot-value instance slot-name)
1191                    (funcall (slot-definition-initfunction slot))))))))
1192  instance)
1193
1194;;; change-class
1195
1196(defgeneric change-class (instance new-class &key))
1197(defmethod change-class
1198  ((old-instance standard-object)
1199   (new-class standard-class)
1200   &rest initargs)
1201  (let ((new-instance (allocate-instance new-class)))
1202    (dolist (slot-name (mapcar #'slot-definition-name
1203                               (class-slots new-class)))
1204      (when (and (slot-exists-p old-instance slot-name)
1205                 (slot-boundp old-instance slot-name))
1206        (setf (slot-value new-instance slot-name)
1207              (slot-value old-instance slot-name))))
1208    (rotatef (std-instance-slots new-instance)
1209             (std-instance-slots old-instance))
1210    (rotatef (std-instance-class new-instance)
1211             (std-instance-class old-instance))
1212    (apply #'update-instance-for-different-class
1213           new-instance old-instance initargs)
1214    old-instance))
1215
1216(defmethod change-class
1217  ((instance standard-object) (new-class symbol) &rest initargs)
1218  (apply #'change-class instance (find-class new-class) initargs))
1219
1220(defgeneric update-instance-for-different-class (old new &key))
1221(defmethod update-instance-for-different-class
1222  ((old standard-object) (new standard-object) &rest initargs)
1223  (let ((added-slots
1224         (remove-if #'(lambda (slot-name)
1225                       (slot-exists-p old slot-name))
1226                    (mapcar #'slot-definition-name
1227                            (class-slots (class-of new))))))
1228    (apply #'shared-initialize new added-slots initargs)))
Note: See TracBrowser for help on using the repository browser.