/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Contents of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (hide annotations)
Sun Apr 6 09:10:09 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.49: +61 -24 lines
	Fix TYPEP/SUBTYPEP problems with unfinalized and
	forward-referenced classes.

	* pcl/std-class.lisp (class-finalized-p): Method removed.
	(*allow-forward-referenced-classes-in-cpl-p*): New variable.
	(make-preliminary-layout): New function.
	(shared-initialize) <:after std-class>: Call
	make-preliminary-layout.
	(shared-initialize) <:after forward-referenced-class>: New method
	calling make-preliminary-layout.
	(shared-initialize) <:after structure-class>: Set finalized-p slot
	to true.
	(update-slots): Likewise.
	(shared-initialize) <:after condition-class>: Likewise.
	(inform-type-system-about-class): New method for
	forward-referenced classes.
	(class-has-a-forward-referenced-superclass-p): Moved to info.lisp.

	* pcl/cpl.lisp (compute-std-cpl-phase-1): Allow forward-referenced
	classes in the cpl if *allow-forward-referenced-classes-in-cpl-p*
	is true.

	* info.lisp (class-has-a-forward-referenced-superclass-p): Moved
	here from std-class.lisp.

	* pcl/cache.lisp (make-wrapper): Handle forward-referenced
	classes.

	* pcl/braid.lisp (bootstrap-initialize-class): Set the finalized-p
	slot.

	* pcl/defs.lisp (class): Add slot finalized-p.

	* pcl/rt/defclass.lisp (defclass-types.[0-5])
	(defclass-forward-referenced-class.0): New tests.

	Misc fixes.

	* pcl/defclass.lisp (expand-defclass): Remove code papering
	over a potential compiler bug.

	* pcl/macros.lisp (find-class-cell-make-instance-function-keys):
	Removed.
	(setf find-class): Add errorp and environment
	parameters, call (setf kernel::find-class) if new-value is nil.
1 wlott 1.1 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27 pw 1.25
28 dtc 1.18 (ext:file-comment
29 gerd 1.50 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.50 2003/04/06 09:10:09 gerd Exp $")
30 wlott 1.1
31 phg 1.7 (in-package :pcl)
32 wlott 1.1
33 ram 1.4 (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
34     (ecase type
35     (reader (slot-definition-reader-function slotd))
36     (writer (slot-definition-writer-function slotd))
37     (boundp (slot-definition-boundp-function slotd))))
38 wlott 1.1
39 ram 1.6 (defmethod (setf slot-accessor-function) (function
40     (slotd effective-slot-definition) type)
41 ram 1.4 (ecase type
42 ram 1.6 (reader (setf (slot-definition-reader-function slotd) function))
43     (writer (setf (slot-definition-writer-function slotd) function))
44 ram 1.4 (boundp (setf (slot-definition-boundp-function slotd) function))))
45    
46     (defconstant *slotd-reader-function-std-p* 1)
47     (defconstant *slotd-writer-function-std-p* 2)
48     (defconstant *slotd-boundp-function-std-p* 4)
49 ram 1.6 (defconstant *slotd-all-function-std-p* 7)
50 ram 1.4
51     (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
52     (let ((flags (slot-value slotd 'accessor-flags)))
53 ram 1.6 (declare (type fixnum flags))
54 ram 1.4 (if (eq type 'all)
55 ram 1.6 (eql *slotd-all-function-std-p* flags)
56 ram 1.4 (let ((mask (ecase type
57     (reader *slotd-reader-function-std-p*)
58     (writer *slotd-writer-function-std-p*)
59     (boundp *slotd-boundp-function-std-p*))))
60 ram 1.6 (declare (type fixnum mask))
61     (not (zerop (the fixnum (logand mask flags))))))))
62 ram 1.4
63     (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
64     (let ((mask (ecase type
65     (reader *slotd-reader-function-std-p*)
66     (writer *slotd-writer-function-std-p*)
67     (boundp *slotd-boundp-function-std-p*)))
68     (flags (slot-value slotd 'accessor-flags)))
69 ram 1.6 (declare (type fixnum mask flags))
70 ram 1.4 (setf (slot-value slotd 'accessor-flags)
71     (if value
72 ram 1.6 (the fixnum (logior mask flags))
73     (the fixnum (logand (the fixnum (lognot mask)) flags)))))
74 ram 1.4 value)
75    
76     (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
77     (let* ((name (slot-value slotd 'name))
78 ram 1.6 (class (slot-value slotd 'class)))
79 ram 1.4 (let ((table (or (gethash name *name->class->slotd-table*)
80     (setf (gethash name *name->class->slotd-table*)
81     (make-hash-table :test 'eq :size 5)))))
82     (setf (gethash class table) slotd))
83     (dolist (type '(reader writer boundp))
84 ram 1.6 (let* ((gf-name (ecase type
85     (reader 'slot-value-using-class)
86     (writer '(setf slot-value-using-class))
87     (boundp 'slot-boundp-using-class)))
88     (gf (gdefinition gf-name)))
89     (compute-slot-accessor-info slotd type gf)))
90     (initialize-internal-slot-gfs name)))
91 ram 1.4
92 gerd 1.44 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
93     type gf)
94 ram 1.6 (let* ((name (slot-value slotd 'name))
95     (class (slot-value slotd 'class))
96     (old-slotd (find-slot-definition class name))
97     (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
98     (multiple-value-bind (function std-p)
99     (if (eq *boot-state* 'complete)
100     (get-accessor-method-function gf type class slotd)
101     (get-optimized-std-accessor-method-function class slotd type))
102     (setf (slot-accessor-std-p slotd type) std-p)
103     (setf (slot-accessor-function slotd type) function))
104 gerd 1.44 ;;
105     ;; Optimized accessor functions use pv tables.
106     (when (and old-slotd
107     (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
108     (record-pv-update-info slotd))))
109 ram 1.5
110 ram 1.6 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
111     :instance)
112 ram 1.5
113 ram 1.6
114 ram 1.5
115 ram 1.6 (defmethod shared-initialize :after ((object documentation-mixin)
116     slot-names
117     &key (documentation nil documentation-p))
118     (declare (ignore slot-names))
119     (when documentation-p
120 gerd 1.43 (setf (documentation object nil) documentation)))
121 ram 1.5
122 dtc 1.11 (defmethod documentation (object doc-type)
123 dtc 1.10 (declare (ignore object doc-type))
124     nil)
125 wlott 1.1
126 dtc 1.11 (defmethod (setf documentation) (new-value object doc-type)
127 wlott 1.1 (declare (ignore new-value doc-type))
128 gerd 1.44 (error "~@<Can't change the documentation of ~S.~@:>" object))
129 wlott 1.1
130 dtc 1.11 (defmethod documentation ((object documentation-mixin) doc-type)
131 ram 1.6 (declare (ignore doc-type))
132     (plist-value object 'documentation))
133 wlott 1.1
134 dtc 1.11 (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type)
135 ram 1.6 (declare (ignore doc-type))
136     (setf (plist-value object 'documentation) new-value))
137 wlott 1.1
138 dtc 1.11 (defmethod documentation ((slotd standard-slot-definition) doc-type)
139 ram 1.6 (declare (ignore doc-type))
140     (slot-value slotd 'documentation))
141 wlott 1.1
142 dtc 1.11 (defmethod (setf documentation) (new-value (slotd standard-slot-definition) doc-type)
143 ram 1.6 (declare (ignore doc-type))
144     (setf (slot-value slotd 'documentation) new-value))
145 gerd 1.43
146     (defmethod (setf documentation) (doc (gf generic-function) type)
147     (declare (ignore type))
148     (setf (ext:info function documentation (generic-function-name gf))
149     doc))
150 wlott 1.1
151    
152     ;;;
153     ;;; Various class accessors that are a little more complicated than can be
154     ;;; done with automatically generated reader methods.
155     ;;;
156     (defmethod class-prototype ((class std-class))
157     (with-slots (prototype) class
158 ram 1.6 (or prototype (setq prototype (allocate-instance class)))))
159 wlott 1.1
160 ram 1.6 (defmethod class-prototype ((class structure-class))
161     (with-slots (prototype wrapper defstruct-constructor) class
162     (or prototype
163     (setq prototype
164 pw 1.23 (if defstruct-constructor
165 ram 1.6 (allocate-instance class)
166     (allocate-standard-instance wrapper))))))
167 ram 1.4
168 ram 1.6 (defmethod class-direct-default-initargs ((class slot-class))
169     (plist-value class 'direct-default-initargs))
170    
171     (defmethod class-default-initargs ((class slot-class))
172     (plist-value class 'default-initargs))
173    
174 ram 1.4 (defmethod class-constructors ((class slot-class))
175 wlott 1.1 (plist-value class 'constructors))
176    
177     (defmethod class-slot-cells ((class std-class))
178     (plist-value class 'class-slot-cells))
179    
180    
181     ;;;
182     ;;; Class accessors that are even a little bit more complicated than those
183     ;;; above. These have a protocol for updating them, we must implement that
184     ;;; protocol.
185     ;;;
186    
187     ;;;
188     ;;; Maintaining the direct subclasses backpointers. The update methods are
189     ;;; here, the values are read by an automatically generated reader method.
190     ;;;
191     (defmethod add-direct-subclass ((class class) (subclass class))
192 gerd 1.44 (check-seals class 'add-direct-subclass)
193 wlott 1.1 (with-slots (direct-subclasses) class
194     (pushnew subclass direct-subclasses)
195     subclass))
196    
197     (defmethod remove-direct-subclass ((class class) (subclass class))
198 gerd 1.44 (check-seals class 'remove-direct-subclass)
199 wlott 1.1 (with-slots (direct-subclasses) class
200     (setq direct-subclasses (remove subclass direct-subclasses))
201     subclass))
202    
203     ;;;
204     ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
205     ;;;
206     ;;; There are four generic functions involved, each has one method for the
207     ;;; class case and another method for the damned EQL specializers. All of
208     ;;; these are specified methods and appear in their specified place in the
209     ;;; class graph.
210     ;;;
211 ram 1.4 ;;; ADD-DIRECT-METHOD
212     ;;; REMOVE-DIRECT-METHOD
213     ;;; SPECIALIZER-DIRECT-METHODS
214     ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
215 wlott 1.1 ;;;
216     ;;; In each case, we maintain one value which is a cons. The car is the list
217     ;;; methods. The cdr is a list of the generic functions. The cdr is always
218     ;;; computed lazily.
219     ;;;
220    
221 ram 1.4 (defmethod add-direct-method ((specializer class) (method method))
222 wlott 1.1 (with-slots (direct-methods) specializer
223     (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
224     (cdr direct-methods) ()))
225     method)
226    
227 ram 1.4 (defmethod remove-direct-method ((specializer class) (method method))
228 wlott 1.1 (with-slots (direct-methods) specializer
229     (setf (car direct-methods) (remove method (car direct-methods))
230     (cdr direct-methods) ()))
231 gerd 1.44 (remove-inline-access-method specializer method)
232 wlott 1.1 method)
233    
234 ram 1.4 (defmethod specializer-direct-methods ((specializer class))
235 wlott 1.1 (with-slots (direct-methods) specializer
236     (car direct-methods)))
237    
238 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer class))
239 wlott 1.1 (with-slots (direct-methods) specializer
240     (or (cdr direct-methods)
241     (setf (cdr direct-methods)
242 pmai 1.32 (loop for method in (car direct-methods)
243     for generic-function = (method-generic-function method)
244     unless (member generic-function collected :test #'eq)
245     collect generic-function into collected
246     finally (return collected))))))
247 wlott 1.1
248    
249     ;;;
250     ;;; This hash table is used to store the direct methods and direct generic
251     ;;; functions of EQL specializers. Each value in the table is the cons.
252     ;;;
253 gerd 1.44 (defvar *eql-specializer-methods* (make-hash-table :test 'eql))
254     (defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
255 wlott 1.1
256 ram 1.4 (defmethod specializer-method-table ((specializer eql-specializer))
257     *eql-specializer-methods*)
258    
259     (defmethod specializer-method-table ((specializer class-eq-specializer))
260     *class-eq-specializer-methods*)
261    
262     (defmethod add-direct-method ((specializer specializer-with-object) (method method))
263 ram 1.2 (let* ((object (specializer-object specializer))
264 ram 1.4 (table (specializer-method-table specializer))
265     (entry (gethash object table)))
266 wlott 1.1 (unless entry
267     (setq entry
268 ram 1.4 (setf (gethash object table)
269 wlott 1.1 (cons nil nil))))
270     (setf (car entry) (adjoin method (car entry))
271     (cdr entry) ())
272     method))
273    
274 ram 1.4 (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
275 ram 1.2 (let* ((object (specializer-object specializer))
276 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
277 wlott 1.1 (when entry
278     (setf (car entry) (remove method (car entry))
279     (cdr entry) ()))
280     method))
281    
282 ram 1.4 (defmethod specializer-direct-methods ((specializer specializer-with-object))
283     (car (gethash (specializer-object specializer)
284     (specializer-method-table specializer))))
285 wlott 1.1
286 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
287 ram 1.2 (let* ((object (specializer-object specializer))
288 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
289 wlott 1.1 (when entry
290     (or (cdr entry)
291     (setf (cdr entry)
292 pmai 1.32 (loop for method in (car entry)
293     for generic-function = (method-generic-function method)
294     unless (member generic-function collected :test #'eq)
295     collect generic-function into collected
296     finally (return collected)))))))
297 wlott 1.1
298 ram 1.4 (defun map-specializers (function)
299 pmai 1.32 (map-all-classes (lambda (class)
300     (funcall function (class-eq-specializer class))
301     (funcall function class)))
302     (maphash (lambda (object methods)
303     (declare (ignore methods))
304     (intern-eql-specializer object))
305 ram 1.4 *eql-specializer-methods*)
306 pmai 1.32 (maphash (lambda (object specl)
307     (declare (ignore object))
308     (funcall function specl))
309 ram 1.4 *eql-specializer-table*)
310     nil)
311    
312 gerd 1.44 (defun map-all-classes (function &optional (root t))
313     (let ((braid-p (memq *boot-state* '(braid complete)))
314     (root (if (symbolp root) (find-class root) root)))
315     (labels ((map-class (class)
316     (mapc #'map-class
317     (if braid-p
318     (class-direct-subclasses class)
319     (early-class-direct-subclasses class)))
320     (funcall function class)))
321     (map-class root))))
322    
323 ram 1.4 (defun map-all-generic-functions (function)
324     (let ((all-generic-functions (make-hash-table :test 'eq)))
325 pmai 1.32 (map-specializers (lambda (specl)
326     (dolist (gf (specializer-direct-generic-functions specl))
327     (unless (gethash gf all-generic-functions)
328     (setf (gethash gf all-generic-functions) t)
329     (funcall function gf))))))
330 ram 1.4 nil)
331    
332     (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
333     (declare (ignore slot-names))
334     (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
335    
336     (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
337     (declare (ignore slot-names))
338     (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
339    
340 wlott 1.1
341    
342 dtc 1.24 (defun real-load-defclass (name metaclass-name supers slots other)
343 gerd 1.44 (apply #'ensure-class name :metaclass metaclass-name
344     :direct-superclasses supers
345     :direct-slots slots
346     :definition-source `((defclass ,name) ,*load-pathname*)
347     other))
348 wlott 1.1
349 phg 1.7 (setf (gdefinition 'load-defclass) #'real-load-defclass)
350 ram 1.6
351     (defun ensure-class (name &rest all)
352 gerd 1.47 (apply #'ensure-class-using-class (find-class name nil) name all))
353 ram 1.6
354 gerd 1.47 (defmethod ensure-class-using-class ((class null) name &rest args &key)
355 ram 1.6 (multiple-value-bind (meta initargs)
356     (ensure-class-values class args)
357 gerd 1.44 (inform-type-system-about-class (class-prototype meta) name)
358 ram 1.6 (setf class (apply #'make-instance meta :name name initargs)
359 phg 1.7 (find-class name) class)
360 gerd 1.44 (inform-type-system-about-class class name)
361 ram 1.6 class))
362    
363 gerd 1.47 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
364 ram 1.6 (multiple-value-bind (meta initargs)
365     (ensure-class-values class args)
366 gerd 1.44 (unless (eq (class-of class) meta)
367 gerd 1.49 (apply #'change-class class meta initargs))
368 ram 1.6 (apply #'reinitialize-instance class initargs)
369 phg 1.7 (setf (find-class name) class)
370 gerd 1.44 (inform-type-system-about-class class name)
371 ram 1.6 class))
372    
373 phg 1.7 (defmethod class-predicate-name ((class t))
374     'function-returning-nil)
375    
376 wlott 1.1 (defun ensure-class-values (class args)
377     (let* ((initargs (copy-list args))
378     (unsupplied (list 1))
379     (supplied-meta (getf initargs :metaclass unsupplied))
380     (supplied-supers (getf initargs :direct-superclasses unsupplied))
381 gerd 1.44 (meta (cond ((neq supplied-meta unsupplied)
382     (find-class supplied-meta))
383     ((or (null class)
384     (forward-referenced-class-p class))
385     *the-class-standard-class*)
386     (t
387     (class-of class)))))
388 gerd 1.50 (flet ((fix-super (super)
389     (cond ((classp super)
390     super)
391     ((legal-class-name-p super)
392     (or (find-class super nil)
393     (make-instance 'forward-referenced-class
394     :name super)))
395     (t
396 pmai 1.33 (simple-program-error
397 gerd 1.50 "~@<~S is not a class or a legal class name.~@:>"
398     super)))))
399 pmai 1.31 ;;
400     ;; CLHS: signal PROGRAM-ERROR, if
401     ;; (a) there are any duplicate slot names
402     ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
403     ;; :DOCUMENTATION appears more than one in a single slot description.
404     (loop for (slot . more) on (getf initargs :direct-slots)
405     for slot-name = (getf slot :name)
406     if (some (lambda (s) (eq slot-name (getf s :name))) more) do
407 pmai 1.33 (simple-program-error
408 gerd 1.44 "~@<More than one direct slot with name ~S.~@:>"
409 pmai 1.33 slot-name)
410 pmai 1.31 else do
411     (loop for (option value . more) on slot by #'cddr
412 gerd 1.44 if (and (member option '(:allocation :type :initform
413     :documentation))
414     (not (eq unsupplied
415     (getf more option unsupplied)))) do
416     (simple-program-error
417     "~@<Duplicate slot option ~S for slot ~S.~@:>"
418     option slot-name)
419     else if (and (eq option :readers)
420     (notevery #'symbolp value)) do
421     (simple-program-error
422     "~@<Slot ~S: slot reader names must be symbols.~@:>"
423     slot-name)
424     else if (and (eq option :initargs)
425     (notevery #'symbolp value)) do
426 pmai 1.33 (simple-program-error
427 gerd 1.44 "~@<Slot ~S: initarg names must be symbols.~@:>"
428     slot-name)))
429 pmai 1.31 ;;
430     ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
431     ;; appears more than once in :DEFAULT-INITARGS class option.
432     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
433     for name = (car initarg)
434     when (some (lambda (a) (eq (car a) name)) more) do
435 pmai 1.33 (simple-program-error
436 gerd 1.44 "~@<Duplicate initialization argument ~
437     name ~S in ~s of class ~A.~@:>"
438     name :default-initargs class))
439     ;;
440     (loop for (arg value) on initargs by #'cddr
441     count (eq arg :metaclass) into metaclass
442     count (eq arg :direct-default-initargs) into default-initargs
443     when (or (> metaclass 1) (> default-initargs 1)) do
444     (simple-program-error
445     "~@<Class ~S: More than one ~S specified~@:>"
446     class (if (eq arg :direct-default-initargs)
447     :default-initargs arg)))
448     (remf initargs :metaclass)
449     (remf initargs :direct-superclasses)
450 pmai 1.31 ;;
451 wlott 1.1 (values meta
452 gerd 1.44 (nconc (when (neq supplied-supers unsupplied)
453     (list :direct-superclasses
454     (mapcar #'fix-super supplied-supers)))
455     initargs)))))
456 wlott 1.1
457    
458     ;;;
459     ;;;
460     ;;;
461     (defmethod shared-initialize :after
462     ((class std-class)
463     slot-names
464 ram 1.2 &key (direct-superclasses nil direct-superclasses-p)
465     (direct-slots nil direct-slots-p)
466 ram 1.4 (direct-default-initargs nil direct-default-initargs-p)
467     (predicate-name nil predicate-name-p))
468 wlott 1.1 (declare (ignore slot-names))
469 pmai 1.28 (cond ((or direct-superclasses-p
470     (null (slot-value class 'direct-superclasses)))
471 dtc 1.17 (setq direct-superclasses
472     (or direct-superclasses
473     (list (if (funcallable-standard-class-p class)
474     *the-class-funcallable-standard-object*
475     *the-class-standard-object*))))
476     (dolist (superclass direct-superclasses)
477     (unless (validate-superclass class superclass)
478 gerd 1.44 (error "~@<The class ~S was specified as a ~
479     super-class of the class ~S, ~
480     but the meta-classes ~S and ~S are incompatible. ~
481     Define a method for ~S to avoid this error.~@:>"
482 dtc 1.17 superclass class (class-of superclass) (class-of class)
483     'validate-superclass)))
484     (setf (slot-value class 'direct-superclasses) direct-superclasses))
485     (t
486     (setq direct-superclasses (slot-value class 'direct-superclasses))))
487 ram 1.2 (setq direct-slots
488     (if direct-slots-p
489     (setf (slot-value class 'direct-slots)
490 gerd 1.50 (mapcar (lambda (pl) (make-direct-slotd class pl))
491     direct-slots))
492 ram 1.2 (slot-value class 'direct-slots)))
493     (if direct-default-initargs-p
494 gerd 1.50 (setf (plist-value class 'direct-default-initargs)
495     direct-default-initargs)
496     (setq direct-default-initargs
497     (plist-value class 'direct-default-initargs)))
498 wlott 1.1 (setf (plist-value class 'class-slot-cells)
499 pmai 1.32 (let ((collected ()))
500     (dolist (dslotd direct-slots (nreverse collected))
501 pmai 1.38 (when (eq (slot-definition-allocation dslotd) :class)
502 ram 1.4 (let ((initfunction (slot-definition-initfunction dslotd)))
503 pmai 1.32 (push (cons (slot-definition-name dslotd)
504     (if initfunction
505     (funcall initfunction)
506 pmai 1.35 +slot-unbound+))
507 pmai 1.32 collected))))))
508 ram 1.6 (setq predicate-name (if predicate-name-p
509     (setf (slot-value class 'predicate-name)
510     (car predicate-name))
511     (or (slot-value class 'predicate-name)
512     (setf (slot-value class 'predicate-name)
513     (make-class-predicate-name (class-name class))))))
514 wlott 1.1 (add-direct-subclasses class direct-superclasses)
515 gerd 1.47 (make-class-predicate class predicate-name)
516 ram 1.6 (update-class class nil)
517 gerd 1.50 (add-slot-accessors class direct-slots)
518     (make-preliminary-layout class))
519    
520     (defmethod shared-initialize :after ((class forward-referenced-class)
521     slot-names &key &allow-other-keys)
522     (declare (ignore slot-names))
523     (make-preliminary-layout class))
524    
525     ;;;
526     ;;; Give CLASS a preliminary layout, if it doesn't have a layout
527     ;;; already. This is done to make CLASS known to the type system
528     ;;; before the class is finalized, and is a consequence of the class
529     ;;; schizophrenia we are suffering from.
530     ;;;
531     (defvar *allow-forward-referenced-classes-in-cpl-p* nil)
532    
533     (defun make-preliminary-layout (class)
534     (flet ((compute-preliminary-cpl (root)
535     (let ((*allow-forward-referenced-classes-in-cpl-p* t))
536     (compute-class-precedence-list root))))
537     (unless (class-finalized-p class)
538     (let ((name (class-name class)))
539     (setf (find-class name) class)
540     (inform-type-system-about-class class name)
541     (let ((layout (make-wrapper 0 class))
542     (kernel-class (kernel::find-class name)))
543     (setf (kernel:layout-class layout) kernel-class)
544     (setf (kernel:%class-pcl-class kernel-class) class)
545     (setf (slot-value class 'wrapper) layout)
546     (let ((cpl (compute-preliminary-cpl class)))
547     (setf (kernel:layout-inherits layout)
548     (kernel:order-layout-inherits
549     (map 'simple-vector #'class-wrapper
550     (reverse (rest cpl))))))
551     (kernel:register-layout layout :invalidate t)
552     (setf (kernel:%class-layout kernel-class) layout))))))
553 wlott 1.1
554 ram 1.6 (defmethod shared-initialize :before ((class class) slot-names &key name)
555     (declare (ignore slot-names name))
556 ram 1.4 (setf (slot-value class 'type) `(class ,class))
557     (setf (slot-value class 'class-eq-specializer)
558     (make-instance 'class-eq-specializer :class class)))
559    
560 pw 1.22 (defmethod reinitialize-instance :before ((class slot-class)
561     &key direct-superclasses)
562     (remove-direct-subclasses class direct-superclasses)
563 wlott 1.1 (remove-slot-accessors class (class-direct-slots class)))
564    
565 ram 1.6 (defmethod reinitialize-instance :after ((class slot-class)
566 wlott 1.1 &rest initargs
567     &key)
568     (map-dependents class
569 pmai 1.32 (lambda (dependent)
570     (apply #'update-dependent class dependent initargs))))
571 ram 1.4
572 ram 1.6 (defmethod shared-initialize :after
573     ((class structure-class)
574     slot-names
575     &key (direct-superclasses nil direct-superclasses-p)
576     (direct-slots nil direct-slots-p)
577     direct-default-initargs
578     (predicate-name nil predicate-name-p))
579     (declare (ignore slot-names direct-default-initargs))
580     (if direct-superclasses-p
581     (setf (slot-value class 'direct-superclasses)
582     (or direct-superclasses
583     (setq direct-superclasses
584     (and (not (eq (class-name class) 'structure-object))
585     (list *the-class-structure-object*)))))
586     (setq direct-superclasses (slot-value class 'direct-superclasses)))
587     (let* ((name (class-name class))
588     (from-defclass-p (slot-value class 'from-defclass-p))
589     (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
590     (if direct-slots-p
591     (setf (slot-value class 'direct-slots)
592     (setq direct-slots
593 pmai 1.32 (mapcar (lambda (pl)
594     (when defstruct-p
595     (let* ((slot-name (getf pl :name))
596 gerd 1.44 (accessor
597     (symbolicate
598     *package*
599     (if (symbol-package name)
600     (package-name (symbol-package name))
601     "")
602     "::" name " structure class " slot-name)))
603 pmai 1.32 (setq pl (list* :defstruct-accessor-symbol accessor
604     pl))))
605     (make-direct-slotd class pl))
606 ram 1.6 direct-slots)))
607     (setq direct-slots (slot-value class 'direct-slots)))
608     (when defstruct-p
609     (let* ((include (car (slot-value class 'direct-superclasses)))
610 gerd 1.44 (conc-name (symbolicate *package*
611     (if (symbol-package name)
612     (package-name (symbol-package name))
613     "")
614     "::" name " structure class "))
615     ;;
616     ;; It's not possible to use a generalized name for the
617     ;; constructor function. It shouldn't matter though, I think,
618     ;; like for the slot names above, because this stuff is not
619     ;; supposed to be used by users directly.
620     (constructor
621     (symbolicate *package* conc-name " constructor"))
622 ram 1.6 (defstruct `(defstruct (,name
623     ,@(when include
624     `((:include ,(class-name include))))
625     (:predicate nil)
626     (:conc-name ,conc-name)
627     (:constructor ,constructor ()))
628 gerd 1.44 ;;
629     ;; Use a temporary unbound marker that lets
630     ;; SHARED-INITIALIZE recognize if a before-method
631     ;; has written to a slot.
632 pmai 1.32 ,@(mapcar (lambda (slot)
633     `(,(slot-definition-name slot)
634 gerd 1.44 '.unbound.))
635 ram 1.6 direct-slots)))
636 pmai 1.32 (reader-names (mapcar (lambda (slotd)
637 gerd 1.44 (list 'slot-accessor name
638     (slot-definition-name slotd)
639     'reader))
640 ram 1.6 direct-slots))
641 pmai 1.32 (writer-names (mapcar (lambda (slotd)
642 gerd 1.44 (list 'slot-accessor name
643     (slot-definition-name slotd)
644     'writer))
645 ram 1.6 direct-slots))
646     (readers-init
647 pmai 1.32 (mapcar (lambda (slotd reader-name)
648     (let ((accessor
649     (slot-definition-defstruct-accessor-symbol slotd)))
650     `(defun ,reader-name (obj)
651     (declare (type ,name obj))
652     (,accessor obj))))
653 ram 1.6 direct-slots reader-names))
654     (writers-init
655 pmai 1.32 (mapcar (lambda (slotd writer-name)
656     (let ((accessor
657     (slot-definition-defstruct-accessor-symbol slotd)))
658     `(defun ,writer-name (nv obj)
659     (declare (type ,name obj))
660     (setf (,accessor obj) nv))))
661 ram 1.6 direct-slots writer-names))
662     (defstruct-form
663     `(progn
664     ,defstruct
665 pw 1.27 ,@readers-init ,@writers-init)))
666 ram 1.6 (unless (structure-type-p name) (eval defstruct-form))
667 pmai 1.32 (mapc (lambda (dslotd reader-name writer-name)
668 gerd 1.48 (let* ((reader (when (fboundp reader-name)
669     (gdefinition reader-name)))
670 pmai 1.32 (writer (when (fboundp writer-name)
671     (gdefinition writer-name))))
672     (setf (slot-value dslotd 'internal-reader-function) reader)
673     (setf (slot-value dslotd 'internal-writer-function) writer)))
674 ram 1.6 direct-slots reader-names writer-names)
675     (setf (slot-value class 'defstruct-form) defstruct-form)
676     (setf (slot-value class 'defstruct-constructor) constructor))))
677     (add-direct-subclasses class direct-superclasses)
678     (setf (slot-value class 'class-precedence-list)
679     (compute-class-precedence-list class))
680     (setf (slot-value class 'slots) (compute-slots class))
681 gerd 1.44 (let ((lclass (kernel::find-class (class-name class))))
682     (setf (kernel:%class-pcl-class lclass) class)
683     (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
684 gerd 1.50 (setf (slot-value class 'finalized-p) t)
685 ram 1.6 (update-pv-table-cache-info class)
686     (setq predicate-name (if predicate-name-p
687     (setf (slot-value class 'predicate-name)
688     (car predicate-name))
689     (or (slot-value class 'predicate-name)
690     (setf (slot-value class 'predicate-name)
691     (make-class-predicate-name (class-name class))))))
692     (make-class-predicate class predicate-name)
693     (add-slot-accessors class direct-slots))
694 ram 1.4
695 ram 1.6 (defmethod direct-slot-definition-class ((class structure-class) initargs)
696     (declare (ignore initargs))
697     (find-class 'structure-direct-slot-definition))
698    
699     (defmethod finalize-inheritance ((class structure-class))
700     nil) ; always finalized
701 wlott 1.1
702     (defun add-slot-accessors (class dslotds)
703     (fix-slot-accessors class dslotds 'add))
704    
705     (defun remove-slot-accessors (class dslotds)
706     (fix-slot-accessors class dslotds 'remove))
707    
708 gerd 1.44 (defun fix-slot-accessors (class dslotds add/remove)
709 ram 1.6 (flet ((fix (gfspec name r/w)
710 wlott 1.1 (let ((gf (ensure-generic-function gfspec)))
711     (case r/w
712     (r (if (eq add/remove 'add)
713 ram 1.6 (add-reader-method class gf name)
714 wlott 1.1 (remove-reader-method class gf)))
715     (w (if (eq add/remove 'add)
716 ram 1.6 (add-writer-method class gf name)
717 wlott 1.1 (remove-writer-method class gf)))))))
718     (dolist (dslotd dslotds)
719 ram 1.6 (let ((slot-name (slot-definition-name dslotd)))
720 gerd 1.44 (dolist (r (slot-definition-readers dslotd))
721     (fix r slot-name 'r))
722     (dolist (w (slot-definition-writers dslotd))
723     (fix w slot-name 'w))))))
724 wlott 1.1
725    
726     (defun add-direct-subclasses (class new)
727     (dolist (n new)
728     (unless (memq class (class-direct-subclasses class))
729     (add-direct-subclass n class))))
730    
731     (defun remove-direct-subclasses (class new)
732     (let ((old (class-direct-superclasses class)))
733     (dolist (o (set-difference old new))
734     (remove-direct-subclass o class))))
735    
736    
737     ;;;
738     ;;;
739     ;;;
740     (defmethod finalize-inheritance ((class std-class))
741     (update-class class t))
742 pmai 1.41
743     (defmethod finalize-inheritance ((class forward-referenced-class))
744     (simple-program-error
745 gerd 1.44 "~@<Forward-referenced classes cannot be finalized: ~A.~@:>"
746 pmai 1.41 class))
747 wlott 1.1
748    
749     ;;;
750 ram 1.4 ;;; Called by :after shared-initialize whenever a class is initialized or
751     ;;; reinitialized. The class may or may not be finalized.
752 wlott 1.1 ;;;
753 gerd 1.44 (defun update-class (class finalizep)
754 pmai 1.40 ;;
755 gerd 1.44 ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
756     ;; makes the class finalized. When UPDATE-CLASS isn't called from
757     ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
758     ;; FINALIZE-INHERITANCE as per AMOP. Note that we can't simply
759     ;; delay the finalization when CLASS has no forward referenced
760     ;; superclasses because that causes bootstrap problems.
761     (when (and (not (or finalizep (class-finalized-p class)))
762 pmai 1.40 (not (class-has-a-forward-referenced-superclass-p class)))
763     (finalize-inheritance class)
764     (return-from update-class))
765 gerd 1.44 ;;
766     (when (or finalizep
767     (class-finalized-p class)
768 ram 1.6 (not (class-has-a-forward-referenced-superclass-p class)))
769 gerd 1.47 (setf (find-class (class-name class)) class)
770 ram 1.4 (update-cpl class (compute-class-precedence-list class))
771 ram 1.6 (update-slots class (compute-slots class))
772 ram 1.4 (update-gfs-of-class class)
773     (update-inits class (compute-default-initargs class))
774 gerd 1.44 (update-ctors 'finalize-inheritance :class class))
775     ;;
776 wlott 1.1 (unless finalizep
777 gerd 1.44 (dolist (sub (class-direct-subclasses class))
778     (update-class sub nil))))
779 wlott 1.1
780     (defun update-cpl (class cpl)
781 dtc 1.13 (if (class-finalized-p class)
782     (unless (equal (class-precedence-list class) cpl)
783     ;; Need to have the cpl setup before update-lisp-class-layout
784     ;; is called on CMUCL.
785     (setf (slot-value class 'class-precedence-list) cpl)
786     (force-cache-flushes class))
787     (setf (slot-value class 'class-precedence-list) cpl))
788 ram 1.4 (update-class-can-precede-p cpl))
789 wlott 1.1
790 ram 1.4 (defun update-class-can-precede-p (cpl)
791     (when cpl
792 ram 1.6 (let ((first (car cpl)))
793 ram 1.4 (dolist (c (cdr cpl))
794 ram 1.6 (pushnew c (slot-value first 'can-precede-list))))
795 ram 1.4 (update-class-can-precede-p (cdr cpl))))
796    
797     (defun class-can-precede-p (class1 class2)
798 ram 1.6 (member class2 (class-can-precede-list class1)))
799 ram 1.4
800 ram 1.6 (defun update-slots (class eslotds)
801 ram 1.4 (let ((instance-slots ())
802     (class-slots ()))
803     (dolist (eslotd eslotds)
804 pmai 1.38 (ecase (slot-definition-allocation eslotd)
805     (:instance (push eslotd instance-slots))
806     (:class (push eslotd class-slots))))
807 ram 1.6 ;;
808     ;; If there is a change in the shape of the instances then the
809     ;; old class is now obsolete.
810     ;;
811     (let* ((nlayout (mapcar #'slot-definition-name
812 pmai 1.42 (sort instance-slots #'<
813     :key #'slot-definition-location)))
814 ram 1.6 (nslots (length nlayout))
815     (nwrapper-class-slots (compute-class-slots class-slots))
816     (owrapper (class-wrapper class))
817     (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
818     (nwrapper
819     (cond ((null owrapper)
820     (make-wrapper nslots class))
821 pmai 1.42 ;;
822     ;; We cannot reuse the old wrapper easily when it
823     ;; has class slot cells, even if these cells are
824 gerd 1.44 ;; EQUAL to the ones used in the new wrapper. The
825 pmai 1.42 ;; class slot cells of OWRAPPER may be referenced
826     ;; from caches, and if we don't change the wrapper,
827     ;; the caches won't notice that something has
828     ;; changed. We could do something here manually,
829     ;; but I don't think it's worth it.
830 ram 1.6 ((and (equal nlayout olayout)
831 pmai 1.42 (null (wrapper-class-slots owrapper)))
832 ram 1.6 owrapper)
833     (t
834     ;;
835     ;; This will initialize the new wrapper to have the same
836     ;; state as the old wrapper. We will then have to change
837     ;; that. This may seem like wasted work (it is), but the
838     ;; spec requires that we call make-instances-obsolete.
839     ;;
840     (make-instances-obsolete class)
841     (class-wrapper class)))))
842 pw 1.9
843 ram 1.6 (with-slots (wrapper slots) class
844 pw 1.9 (update-lisp-class-layout class nwrapper)
845 ram 1.6 (setf slots eslotds
846     (wrapper-instance-slots-layout nwrapper) nlayout
847     (wrapper-class-slots nwrapper) nwrapper-class-slots
848     (wrapper-no-of-instance-slots nwrapper) nslots
849     wrapper nwrapper))
850 gerd 1.50 (setf (slot-value class 'finalized-p) t)
851 pw 1.9
852 ram 1.6 (unless (eq owrapper nwrapper)
853 gerd 1.44 (update-inline-access class)
854 gerd 1.46 (update-pv-table-cache-info class)
855     (maybe-update-standard-class-locations class)))))
856 wlott 1.1
857 ram 1.6 (defun compute-class-slots (eslotds)
858 pmai 1.32 (loop for eslotd in eslotds
859     for name = (slot-definition-name eslotd)
860 pmai 1.38 and class = (slot-definition-class eslotd)
861     collect (assoc name (class-slot-cells class))))
862 wlott 1.1
863 ram 1.4 (defun update-gfs-of-class (class)
864 ram 1.6 (when (and (class-finalized-p class)
865     (let ((cpl (class-precedence-list class)))
866     (or (member *the-class-slot-class* cpl)
867     (member *the-class-standard-effective-slot-definition* cpl))))
868 ram 1.4 (let ((gf-table (make-hash-table :test 'eq)))
869     (labels ((collect-gfs (class)
870     (dolist (gf (specializer-direct-generic-functions class))
871     (setf (gethash gf gf-table) t))
872     (mapc #'collect-gfs (class-direct-superclasses class))))
873     (collect-gfs class)
874 pmai 1.32 (maphash (lambda (gf ignore)
875     (declare (ignore ignore))
876     (update-gf-dfun class gf))
877 ram 1.4 gf-table)))))
878 wlott 1.1
879     (defun update-inits (class inits)
880 ram 1.6 (setf (plist-value class 'default-initargs) inits))
881 wlott 1.1
882    
883     ;;;
884     ;;;
885     ;;;
886 ram 1.4 (defmethod compute-default-initargs ((class slot-class))
887     (let ((cpl (class-precedence-list class))
888     (direct (class-direct-default-initargs class)))
889     (labels ((walk (tail)
890     (if (null tail)
891     nil
892     (let ((c (pop tail)))
893     (append (if (eq c class)
894     direct
895     (class-direct-default-initargs c))
896     (walk tail))))))
897     (let ((initargs (walk cpl)))
898     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
899 wlott 1.1
900    
901     ;;;
902     ;;; Protocols for constructing direct and effective slot definitions.
903     ;;;
904     ;;;
905     ;;;
906     ;;;
907     (defmethod direct-slot-definition-class ((class std-class) initargs)
908     (declare (ignore initargs))
909     (find-class 'standard-direct-slot-definition))
910    
911 ram 1.6 (defun make-direct-slotd (class initargs)
912     (let ((initargs (list* :class class initargs)))
913 gerd 1.44 (apply #'make-instance (direct-slot-definition-class class initargs)
914     initargs)))
915 ram 1.6
916 wlott 1.1 ;;;
917 gerd 1.44 ;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
918     ;;; for each different slot name we find in our superclasses. Each
919     ;;; call receives the class and a list of the dslotds with that name.
920     ;;; The list is in most-specific-first order.
921     ;;;
922     (defmethod compute-slots ((class std-class))
923     (loop with names/slots = ()
924     for c in (class-precedence-list class) do
925     (loop for slot in (class-direct-slots c)
926     as name = (slot-definition-name slot)
927     as entry = (assq name names/slots) do
928     (if entry
929     (push slot (cdr entry))
930     (push (list name slot) names/slots)))
931     finally
932     (return
933     (loop for (name . slots) in names/slots collect
934     (compute-effective-slot-definition
935     class (nreverse slots))))))
936    
937 wlott 1.1 ;;;
938 gerd 1.44 ;;; These are the specified AMOP methods.
939 wlott 1.1 ;;;
940    
941 pmai 1.39 (defmethod compute-slots ((class standard-class))
942     (call-next-method))
943 gerd 1.44
944 pmai 1.39 (defmethod compute-slots :around ((class standard-class))
945 gerd 1.44 (loop with slotds = (call-next-method) and location = -1
946     for slot in slotds do
947     (setf (slot-definition-location slot)
948     (ecase (slot-definition-allocation slot)
949     (:instance
950     (incf location))
951     (:class
952     (let* ((name (slot-definition-name slot))
953     (from-class (slot-definition-allocation-class slot))
954     (cell (assq name (class-slot-cells from-class))))
955     (assert (consp cell))
956     cell))))
957     (initialize-internal-slot-functions slot)
958     finally
959     (return slotds)))
960 pmai 1.39
961     (defmethod compute-slots ((class funcallable-standard-class))
962     (call-next-method))
963    
964     (defmethod compute-slots :around ((class funcallable-standard-class))
965 gerd 1.44 (labels (;;
966     ;; Return a list of the names of instance slots in SLOTDS.
967     (instance-slot-names (slotds)
968     (loop for e in slotds
969     when (eq (slot-definition-allocation e) :instance)
970     collect (slot-definition-name e)))
971     ;;
972 pmai 1.39 ;; This sorts slots so that slots of classes later in the CPL
973 gerd 1.44 ;; come before slots of other classes. This is crucial for
974     ;; funcallable instances because it ensures that the slots of
975     ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
976     ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
977     ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
978     ;; a funcallable instance.
979 pmai 1.39 (compute-layout (eslotds)
980 gerd 1.44 (loop with first = ()
981     with names = (instance-slot-names eslotds)
982     for class in (reverse (class-precedence-list class)) do
983     (loop for ss in (class-slots class)
984     as name = (slot-definition-name ss)
985     when (member name names) do
986     (push name first)
987     (setq names (delete name names)))
988     finally (return (nreverse (nconc names first))))))
989     ;;
990 pmai 1.39 (let ((all-slotds (call-next-method))
991     (instance-slots ())
992     (class-slots ()))
993 gerd 1.44 (loop for slotd in all-slotds do
994     (ecase (slot-definition-allocation slotd)
995     (:instance (push slotd instance-slots))
996     (:class (push slotd class-slots))))
997     (loop with layout = (compute-layout instance-slots)
998     for slotd in instance-slots do
999     (setf (slot-definition-location slotd)
1000     (position (slot-definition-name slotd) layout))
1001     (initialize-internal-slot-functions slotd))
1002     (loop for slotd in class-slots
1003     as name = (slot-definition-name slotd)
1004     as from-class = (slot-definition-allocation-class slotd) do
1005     (setf (slot-definition-location slotd)
1006     (assoc name (class-slot-cells from-class)))
1007     (assert (consp (slot-definition-location slotd)))
1008     (initialize-internal-slot-functions slotd))
1009 pmai 1.39 all-slotds)))
1010 ram 1.4
1011 ram 1.6 (defmethod compute-slots ((class structure-class))
1012 pmai 1.32 (mapcan (lambda (superclass)
1013     (mapcar (lambda (dslotd)
1014     (compute-effective-slot-definition class (list dslotd)))
1015     (class-direct-slots superclass)))
1016 ram 1.6 (reverse (slot-value class 'class-precedence-list))))
1017 ram 1.4
1018 ram 1.6 (defmethod compute-slots :around ((class structure-class))
1019     (let ((eslotds (call-next-method)))
1020     (mapc #'initialize-internal-slot-functions eslotds)
1021     eslotds))
1022    
1023     (defmethod compute-effective-slot-definition ((class slot-class) dslotds)
1024 wlott 1.1 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
1025 ram 1.6 (class (effective-slot-definition-class class initargs)))
1026     (apply #'make-instance class initargs)))
1027 wlott 1.1
1028     (defmethod effective-slot-definition-class ((class std-class) initargs)
1029     (declare (ignore initargs))
1030 ram 1.6 (find-class 'standard-effective-slot-definition))
1031 wlott 1.1
1032 ram 1.6 (defmethod effective-slot-definition-class ((class structure-class) initargs)
1033     (declare (ignore initargs))
1034     (find-class 'structure-effective-slot-definition))
1035    
1036 ram 1.4 (defmethod compute-effective-slot-definition-initargs
1037     ((class slot-class) direct-slotds)
1038 wlott 1.1 (let* ((name nil)
1039     (initfunction nil)
1040     (initform nil)
1041     (initargs nil)
1042     (allocation nil)
1043 pmai 1.39 (allocation-class nil)
1044 wlott 1.1 (type t)
1045     (namep nil)
1046     (initp nil)
1047 ram 1.6 (allocp nil))
1048 wlott 1.1
1049     (dolist (slotd direct-slotds)
1050     (when slotd
1051     (unless namep
1052 ram 1.4 (setq name (slot-definition-name slotd)
1053 wlott 1.1 namep t))
1054     (unless initp
1055 ram 1.4 (when (slot-definition-initfunction slotd)
1056 ram 1.6 (setq initform (slot-definition-initform slotd)
1057     initfunction (slot-definition-initfunction slotd)
1058 wlott 1.1 initp t)))
1059     (unless allocp
1060 ram 1.4 (setq allocation (slot-definition-allocation slotd)
1061 pmai 1.39 allocation-class (slot-definition-class slotd)
1062 wlott 1.1 allocp t))
1063 ram 1.4 (setq initargs (append (slot-definition-initargs slotd) initargs))
1064     (let ((slotd-type (slot-definition-type slotd)))
1065 pmai 1.32 (setq type (cond ((eq type t) slotd-type)
1066 ram 1.4 ((*subtypep type slotd-type) type)
1067 ram 1.6 (t `(and ,type ,slotd-type)))))))
1068 wlott 1.1 (list :name name
1069     :initform initform
1070     :initfunction initfunction
1071     :initargs initargs
1072     :allocation allocation
1073 pmai 1.39 :allocation-class allocation-class
1074 ram 1.4 :type type
1075 ram 1.6 :class class)))
1076 wlott 1.1
1077 ram 1.6 (defmethod compute-effective-slot-definition-initargs :around
1078     ((class structure-class) direct-slotds)
1079     (let ((slotd (car direct-slotds)))
1080     (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
1081     :internal-reader-function (slot-definition-internal-reader-function slotd)
1082     :internal-writer-function (slot-definition-internal-writer-function slotd)
1083     (call-next-method))))
1084 wlott 1.1
1085     ;;;
1086     ;;; NOTE: For bootstrapping considerations, these can't use make-instance
1087     ;;; to make the method object. They have to use make-a-method which
1088     ;;; is a specially bootstrapped mechanism for making standard methods.
1089     ;;;
1090 ram 1.6 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
1091     (declare (ignore direct-slot initargs))
1092     (find-class 'standard-reader-method))
1093 wlott 1.1
1094 ram 1.6 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
1095     (add-method generic-function
1096     (make-a-method 'standard-reader-method
1097     ()
1098     (list (or (class-name class) 'object))
1099     (list class)
1100     (make-reader-method-function class slot-name)
1101     "automatically generated reader method"
1102     slot-name)))
1103 wlott 1.1
1104 ram 1.6 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
1105 ram 1.5 (declare (ignore direct-slot initargs))
1106 ram 1.6 (find-class 'standard-writer-method))
1107 ram 1.5
1108 ram 1.6 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
1109     (add-method generic-function
1110     (make-a-method 'standard-writer-method
1111     ()
1112     (list 'new-value (or (class-name class) 'object))
1113     (list *the-class-t* class)
1114     (make-writer-method-function class slot-name)
1115     "automatically generated writer method"
1116     slot-name)))
1117 ram 1.5
1118 ram 1.6 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
1119     (add-method generic-function
1120     (make-a-method 'standard-boundp-method
1121     ()
1122     (list (or (class-name class) 'object))
1123     (list class)
1124     (make-boundp-method-function class slot-name)
1125     "automatically generated boundp method"
1126     slot-name)))
1127 ram 1.5
1128 ram 1.4 (defmethod remove-reader-method ((class slot-class) generic-function)
1129 wlott 1.1 (let ((method (get-method generic-function () (list class) nil)))
1130 gerd 1.44 (when method
1131     (remove-method generic-function method))))
1132 wlott 1.1
1133 ram 1.4 (defmethod remove-writer-method ((class slot-class) generic-function)
1134 gerd 1.44 (let ((method (get-method generic-function ()
1135     (list *the-class-t* class) nil)))
1136     (when method
1137     (remove-method generic-function method))))
1138 wlott 1.1
1139 ram 1.4 (defmethod remove-boundp-method ((class slot-class) generic-function)
1140     (let ((method (get-method generic-function () (list class) nil)))
1141 gerd 1.44 (when method
1142     (remove-method generic-function method))))
1143 ram 1.4
1144 wlott 1.1
1145     ;;;
1146     ;;; make-reader-method-function and make-write-method function are NOT part of
1147     ;;; the standard protocol. They are however useful, PCL makes uses makes use
1148     ;;; of them internally and documents them for PCL users.
1149     ;;;
1150     ;;; *** This needs work to make type testing by the writer functions which
1151     ;;; *** do type testing faster. The idea would be to have one constructor
1152     ;;; *** for each possible type test. In order to do this it would be nice
1153     ;;; *** to have help from inform-type-system-about-class and friends.
1154     ;;;
1155     ;;; *** There is a subtle bug here which is going to have to be fixed.
1156     ;;; *** Namely, the simplistic use of the template has to be fixed. We
1157     ;;; *** have to give the optimize-slot-value method the user might have
1158     ;;; *** defined for this metclass a chance to run.
1159     ;;;
1160 ram 1.6 (defmethod make-reader-method-function ((class slot-class) slot-name)
1161     (make-std-reader-method-function (class-name class) slot-name))
1162 wlott 1.1
1163 ram 1.6 (defmethod make-writer-method-function ((class slot-class) slot-name)
1164     (make-std-writer-method-function (class-name class) slot-name))
1165 ram 1.5
1166 ram 1.6 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1167     (make-std-boundp-method-function (class-name class) slot-name))
1168 ram 1.5
1169 wlott 1.1
1170     ;;;; inform-type-system-about-class
1171     ;;;
1172 pw 1.26 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1173 wlott 1.1 ;;; which PCL uses to *try* and tell the type system about class definitions.
1174     ;;; In a more fully integrated implementation of CLOS, the type system would
1175     ;;; know about class objects and class names in a more fundamental way and
1176     ;;; the mechanism used to inform the type system about new classes would be
1177     ;;; different.
1178     ;;;
1179     (defmethod inform-type-system-about-class ((class std-class) name)
1180 pw 1.26 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1181     ;; compiler warnings. Not otherwise needed in this implementation.
1182 gerd 1.44 (inform-type-system-about-std-class name)
1183     (set-class-translation class name))
1184    
1185     (defmethod inform-type-system-about-class ((class funcallable-standard-class)
1186     name)
1187     (set-class-translation class name))
1188 pw 1.26
1189 gerd 1.44 (defmethod inform-type-system-about-class ((class structure-class) name)
1190     (set-class-translation class name))
1191    
1192     (defmethod inform-type-system-about-class ((class condition-class) name)
1193     (set-class-translation class name))
1194 pw 1.26
1195 gerd 1.50 (defmethod inform-type-system-about-class ((class forward-referenced-class)
1196     name)
1197     (inform-type-system-about-std-class name)
1198     (set-class-translation class name))
1199    
1200 wlott 1.1
1201     (defmethod compatible-meta-class-change-p (class proto-new-class)
1202     (eq (class-of class) (class-of proto-new-class)))
1203    
1204 ram 1.4 (defmethod validate-superclass ((class class) (new-super class))
1205     (or (eq new-super *the-class-t*)
1206     (eq (class-of class) (class-of new-super))))
1207 wlott 1.1
1208 dtc 1.16 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1209     (let ((new-super-meta-class (class-of new-super)))
1210     (or (eq new-super-meta-class *the-class-std-class*)
1211     (eq (class-of class) new-super-meta-class))))
1212 ram 1.4
1213 wlott 1.1
1214     ;;;
1215 pmai 1.37 ;;; Force the flushing of caches by creating a new wrapper for CLASS,
1216     ;;; if necessary.
1217 wlott 1.1 ;;;
1218 pmai 1.37 ;;; If the LAYOUT-INVALID slot of CLASS's wrapper is
1219     ;;;
1220     ;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's
1221     ;;; nothing to do. The new wrapper has already been created.
1222     ;;;
1223     ;;; -- :INVALID, then it has been set to that value by a previous
1224     ;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's
1225     ;;; wrapper has been invalidated together with its subclasses. In
1226     ;;; this case, CLASS's caches must obviously be flushed, too, like
1227     ;;; S's. So, make a new wrapper for CLASS, and translate kernel's
1228     ;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later
1229     ;;; decide if it wants to make this (:OBSOLETE ...).
1230     ;;;
1231     ;;; -- NIL, then the wrapper is still valid, in which case we do
1232     ;;; the same as for :INVALID, but for the obviously slightly
1233     ;;; different reason.
1234 wlott 1.1 ;;;
1235     (defun force-cache-flushes (class)
1236 pmai 1.37 (let* ((owrapper (class-wrapper class)))
1237     (when (or (not (invalid-wrapper-p owrapper))
1238     (eq :invalid (kernel:layout-invalid owrapper)))
1239 ram 1.6 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1240     class)))
1241 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1242     (wrapper-instance-slots-layout owrapper))
1243     (setf (wrapper-class-slots nwrapper)
1244     (wrapper-class-slots owrapper))
1245 pmai 1.34 (with-pcl-lock
1246 pw 1.9 (update-lisp-class-layout class nwrapper)
1247 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1248 pmai 1.32 (invalidate-wrapper owrapper :flush nwrapper))))))
1249 wlott 1.1
1250     (defun flush-cache-trap (owrapper nwrapper instance)
1251     (declare (ignore owrapper))
1252 gerd 1.44 (cond ((std-instance-p instance)
1253     (setf (std-instance-wrapper instance) nwrapper))
1254     ((fsc-instance-p instance)
1255     (setf (fsc-instance-wrapper instance) nwrapper))
1256     (t
1257     (internal-error "Internal error."))))
1258 wlott 1.1
1259    
1260     ;;;
1261     ;;; make-instances-obsolete can be called by user code. It will cause the
1262     ;;; next access to the instance (as defined in 88-002R) to trap through the
1263     ;;; update-instance-for-redefined-class mechanism.
1264     ;;;
1265     (defmethod make-instances-obsolete ((class std-class))
1266 ram 1.6 (let* ((owrapper (class-wrapper class))
1267     (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1268     class)))
1269 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1270     (wrapper-instance-slots-layout owrapper))
1271     (setf (wrapper-class-slots nwrapper)
1272     (wrapper-class-slots owrapper))
1273 pmai 1.34 (with-pcl-lock
1274 pw 1.9 (update-lisp-class-layout class nwrapper)
1275 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1276 pmai 1.32 (invalidate-wrapper owrapper :obsolete nwrapper)
1277 ram 1.6 class)))
1278 wlott 1.1
1279     (defmethod make-instances-obsolete ((class symbol))
1280     (make-instances-obsolete (find-class class)))
1281    
1282    
1283     ;;;
1284     ;;; obsolete-instance-trap is the internal trap that is called when we see
1285     ;;; an obsolete instance. The times when it is called are:
1286     ;;; - when the instance is involved in method lookup
1287     ;;; - when attempting to access a slot of an instance
1288     ;;;
1289     ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1290     ;;; access macros.
1291     ;;;
1292     ;;; Of course these times when it is called are an internal implementation
1293     ;;; detail of PCL and are not part of the documented description of when the
1294     ;;; obsolete instance update happens. The documented description is as it
1295     ;;; appears in 88-002R.
1296     ;;;
1297     ;;; This has to return the new wrapper, so it counts on all the methods on
1298     ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1299     ;;; a little internal error checking to make sure that the traps are only
1300     ;;; happening when they should, and that the trap methods are computing
1301     ;;; apropriate new wrappers.
1302     ;;;
1303 pw 1.9
1304     ;;; obsolete-instance-trap might be called on structure instances
1305     ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1306     ;;; will not be able to fix the old instance, so it must signal an
1307     ;;; error. The hard part of this is that the error system and debugger
1308     ;;; might cause obsolete-instance-trap to be called again, so in that
1309     ;;; case, we have to return some reasonable wrapper, instead.
1310    
1311     (defvar *in-obsolete-instance-trap* nil)
1312 gerd 1.44
1313 pw 1.9 (defvar *the-wrapper-of-structure-object*
1314     (class-wrapper (find-class 'structure-object)))
1315    
1316     (define-condition obsolete-structure (error)
1317     ((datum :reader obsolete-structure-datum :initarg :datum))
1318     (:report
1319     (lambda (condition stream)
1320     ;; Don't try to print the structure, since it probably
1321     ;; won't work.
1322 gerd 1.44 (format stream "~@<Obsolete structure error in ~S ~
1323     for a structure of type ~S.~@:>"
1324 pw 1.9 (conditions::condition-function-name condition)
1325     (type-of (obsolete-structure-datum condition))))))
1326    
1327     (defun obsolete-instance-trap (owrapper nwrapper instance)
1328 pw 1.25 (if (not (pcl-instance-p instance))
1329 pw 1.9 (if *in-obsolete-instance-trap*
1330     *the-wrapper-of-structure-object*
1331     (let ((*in-obsolete-instance-trap* t))
1332     (error 'obsolete-structure :datum instance)))
1333     (let* ((class (wrapper-class* nwrapper))
1334     (copy (allocate-instance class)) ;??? allocate-instance ???
1335     (olayout (wrapper-instance-slots-layout owrapper))
1336     (nlayout (wrapper-instance-slots-layout nwrapper))
1337     (oslots (get-slots instance))
1338     (nslots (get-slots copy))
1339     (oclass-slots (wrapper-class-slots owrapper))
1340     (added ())
1341     (discarded ())
1342     (plist ()))
1343     ;; local --> local transfer
1344     ;; local --> shared discard
1345     ;; local --> -- discard
1346     ;; shared --> local transfer
1347     ;; shared --> shared discard
1348     ;; shared --> -- discard
1349     ;; -- --> local add
1350     ;; -- --> shared --
1351     ;;
1352     ;; Go through all the old local slots.
1353 pmai 1.32 ;;
1354     (loop for name in olayout and opos from 0
1355     as npos = (posq name nlayout)
1356     if npos do
1357 gerd 1.44 (setf (slot-ref nslots npos)
1358     (slot-ref oslots opos))
1359 pmai 1.32 else do
1360     (push name discarded)
1361 gerd 1.44 (unless (eq (slot-ref oslots opos) +slot-unbound+)
1362 pmai 1.32 (setf (getf plist name)
1363 gerd 1.44 (slot-ref oslots opos))))
1364 pw 1.9 ;;
1365     ;; Go through all the old shared slots.
1366     ;;
1367 pmai 1.32 (loop for (name . val) in oclass-slots
1368     for npos = (posq name nlayout)
1369     if npos do
1370 gerd 1.44 (setf (slot-ref nslots npos) val)
1371 pmai 1.32 else do
1372     (push name discarded)
1373 pmai 1.35 (unless (eq val +slot-unbound+)
1374 pmai 1.32 (setf (getf plist name) val)))
1375 pw 1.9 ;;
1376     ;; Go through all the new local slots to compute the added slots.
1377     ;;
1378     (dolist (nlocal nlayout)
1379     (unless (or (memq nlocal olayout)
1380     (assq nlocal oclass-slots))
1381     (push nlocal added)))
1382 wlott 1.1
1383 pw 1.9 (swap-wrappers-and-slots instance copy)
1384 wlott 1.1
1385 pw 1.9 (update-instance-for-redefined-class instance
1386     added
1387     discarded
1388     plist)
1389     nwrapper)))
1390 wlott 1.1
1391    
1392     ;;;
1393     ;;;
1394     ;;;
1395 pmai 1.29 (defun change-class-internal (instance new-class initargs)
1396 ram 1.6 (let* ((old-class (class-of instance))
1397 pw 1.9 (copy (allocate-instance new-class))
1398     (new-wrapper (get-wrapper copy))
1399 ram 1.6 (old-wrapper (class-wrapper old-class))
1400     (old-layout (wrapper-instance-slots-layout old-wrapper))
1401     (new-layout (wrapper-instance-slots-layout new-wrapper))
1402     (old-slots (get-slots instance))
1403 pw 1.9 (new-slots (get-slots copy))
1404 ram 1.6 (old-class-slots (wrapper-class-slots old-wrapper)))
1405    
1406 wlott 1.1 ;;
1407     ;; "The values of local slots specified by both the class Cto and
1408     ;; Cfrom are retained. If such a local slot was unbound, it remains
1409     ;; unbound."
1410 pmai 1.32 ;;
1411     (loop for new-slot in new-layout and new-position from 0
1412     for old-position = (posq new-slot old-layout)
1413     when old-position do
1414 gerd 1.44 (setf (slot-ref new-slots new-position)
1415     (slot-ref old-slots old-position)))
1416 wlott 1.1 ;;
1417     ;; "The values of slots specified as shared in the class Cfrom and
1418     ;; as local in the class Cto are retained."
1419     ;;
1420 pmai 1.32 (loop for (name . val) in old-class-slots
1421     for new-position = (posq name new-layout)
1422     when new-position do
1423 gerd 1.44 (setf (slot-ref new-slots new-position) val))
1424 wlott 1.1
1425     ;; Make the copy point to the old instance's storage, and make the
1426     ;; old instance point to the new storage.
1427 pw 1.9 (swap-wrappers-and-slots instance copy)
1428 wlott 1.1
1429 pmai 1.29 (apply #'update-instance-for-different-class copy instance initargs)
1430 wlott 1.1 instance))
1431    
1432     (defmethod change-class ((instance standard-object)
1433 pmai 1.29 (new-class standard-class)
1434     &rest initargs)
1435     (change-class-internal instance new-class initargs))
1436 wlott 1.1
1437 dtc 1.15 (defmethod change-class ((instance funcallable-standard-object)
1438 pmai 1.29 (new-class funcallable-standard-class)
1439     &rest initargs)
1440     (change-class-internal instance new-class initargs))
1441 dtc 1.17
1442     (defmethod change-class ((instance standard-object)
1443 pmai 1.29 (new-class funcallable-standard-class)
1444     &rest initargs)
1445     (declare (ignore initargs))
1446 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1447     because it isn't already an instance with metaclass ~S.~@:>"
1448 dtc 1.17 instance new-class 'standard-class))
1449    
1450     (defmethod change-class ((instance funcallable-standard-object)
1451 pmai 1.29 (new-class standard-class)
1452     &rest initargs)
1453     (declare (ignore initargs))
1454 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1455     because it isn't already an instance with metaclass ~S.~@:>"
1456 dtc 1.17 instance new-class 'funcallable-standard-class))
1457 wlott 1.1
1458 pmai 1.29 (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1459     (apply #'change-class instance (find-class new-class-name) initargs))
1460 wlott 1.1
1461    
1462    
1463     ;;;
1464     ;;; The metaclass BUILT-IN-CLASS
1465     ;;;
1466     ;;; This metaclass is something of a weird creature. By this point, all
1467     ;;; instances of it which will exist have been created, and no instance
1468     ;;; is ever created by calling MAKE-INSTANCE.
1469     ;;;
1470     ;;; But, there are other parts of the protcol we must follow and those
1471     ;;; definitions appear here.
1472     ;;;
1473     (defmethod shared-initialize :before
1474     ((class built-in-class) slot-names &rest initargs)
1475 ram 1.5 (declare (ignore slot-names initargs))
1476 gerd 1.44 (error "Attempt to initialize or reinitialize a built-in class."))
1477 wlott 1.1
1478 ram 1.6 (defmethod class-direct-slots ((class built-in-class)) ())
1479     (defmethod class-slots ((class built-in-class)) ())
1480     (defmethod class-direct-default-initargs ((class built-in-class)) ())
1481     (defmethod class-default-initargs ((class built-in-class)) ())
1482    
1483 ram 1.4 (defmethod validate-superclass ((c class) (s built-in-class))
1484 gerd 1.44 (or (eq s *the-class-t*)
1485     (eq s *the-class-stream*)))
1486 wlott 1.1
1487 ram 1.4
1488 wlott 1.1
1489     ;;;
1490     ;;;
1491     ;;;
1492    
1493 gerd 1.44 (macrolet ((frob (method)
1494     `(defmethod ,method ((class forward-referenced-class))
1495     (declare (ignore class))
1496     ())))
1497     (frob class-direct-slots)
1498     (frob class-direct-default-initargs))
1499    
1500     (macrolet ((frob (method)
1501     `(defmethod ,method ((class forward-referenced-class))
1502     (error "~@<~S called for forward referenced class ~S.~@:>"
1503     ',method class))))
1504     (frob class-default-initargs)
1505     (frob class-precedence-list)
1506     (frob class-slots))
1507    
1508 ram 1.4 (defmethod validate-superclass ((c slot-class)
1509 dtc 1.16 (f forward-referenced-class))
1510 pmai 1.32 t)
1511 wlott 1.1
1512    
1513     ;;;
1514     ;;;
1515     ;;;
1516    
1517     (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1518     (pushnew dependent (plist-value metaobject 'dependents)))
1519    
1520     (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1521     (setf (plist-value metaobject 'dependents)
1522     (delete dependent (plist-value metaobject 'dependents))))
1523    
1524     (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1525     (dolist (dependent (plist-value metaobject 'dependents))
1526 ram 1.2 (funcall function dependent)))
1527 ram 1.4
1528 gerd 1.44
1529     ;;;
1530     ;;; Conditions
1531     ;;;
1532 gerd 1.45 (defmethod class-direct-slots ((class condition-class)) ())
1533     (defmethod class-slots ((class condition-class)) ())
1534     (defmethod class-default-initargs ((class condition-class)) ())
1535     (defmethod class-direct-default-initargs ((class condition-class)) ())
1536    
1537 gerd 1.44 (defmethod shared-initialize :after ((class condition-class) slot-names
1538     &key direct-superclasses)
1539     (declare (ignore slot-names))
1540     (let ((kernel-class (kernel::find-class (class-name class))))
1541     (with-slots (wrapper class-precedence-list prototype predicate-name
1542     (direct-supers direct-superclasses))
1543     class
1544 gerd 1.50 (setf (slot-value class 'finalized-p) t)
1545 gerd 1.44 (setf (kernel:%class-pcl-class kernel-class) class)
1546     (setq direct-supers direct-superclasses)
1547     (setq wrapper (kernel:%class-layout kernel-class))
1548     (setq class-precedence-list (compute-class-precedence-list class))
1549     (setq prototype (make-condition (class-name class)))
1550     (add-direct-subclasses class direct-superclasses)
1551     (setq predicate-name (make-class-predicate-name (class-name class)))
1552     (make-class-predicate class predicate-name))))
1553    

  ViewVC Help
Powered by ViewVC 1.1.5