1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 ;;;; DEFCLASS macro and close personal friends
28 ;;; state for the current DEFCLASS expansion
29 (defvar *initfunctions-for-this-defclass
*)
30 (defvar *readers-for-this-defclass
*)
31 (defvar *writers-for-this-defclass
*)
32 (defvar *slot-names-for-this-defclass
*)
34 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
35 ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
36 ;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition
37 ;;; which simply collects all class definitions up, when the metabraid
38 ;;; is initialized it is done from those class definitions.
40 ;;; After the metabraid has been setup, and the protocol for defining
41 ;;; classes has been defined, the real definition of LOAD-DEFCLASS is
42 ;;; installed by the file std-class.lisp
43 (defmacro defclass
(&environment env name direct-superclasses direct-slots
&rest options
)
44 (let (*initfunctions-for-this-defclass
*
45 *readers-for-this-defclass
* ;Truly a crock, but we got
46 *writers-for-this-defclass
* ;to have it to live nicely.
47 *slot-names-for-this-defclass
*)
48 ;; FIXME: It would be nice to collect all errors from the
49 ;; expansion of a defclass and signal them in a single go.
50 (multiple-value-bind (metaclass canonical-options
)
51 (canonize-defclass-options name options
)
52 (let ((canonical-slots (canonize-defclass-slots name direct-slots env
))
53 ;; DEFSTRUCT-P should be true if the class is defined
54 ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
55 ;; is compiled for the class.
56 (defstruct-p (and (eq **boot-state
** 'complete
)
57 (let ((mclass (find-class metaclass nil
)))
61 *the-class-structure-class
*))))))
63 `(let ,(mapcar #'cdr
*initfunctions-for-this-defclass
*)
67 (list ,@canonical-slots
)
68 (list ,@(apply #'append
70 '(:from-defclass-p t
))
72 ',*readers-for-this-defclass
*
73 ',*writers-for-this-defclass
*
74 ',*slot-names-for-this-defclass
*
75 (sb-c:source-location
)
76 ,@(and (safe-code-p env
)
80 ;; FIXME: (YUK!) Why do we do this? Because in order
81 ;; to make the defstruct form, we need to know what
82 ;; the accessors for the slots are, so we need already
83 ;; to have hooked into the CLOS machinery.
85 ;; There may be a better way to do this: it would
86 ;; involve knowing enough about PCL to ask "what will
87 ;; my slot names and accessors be"; failing this, we
88 ;; currently just evaluate the whole kaboodle, and
89 ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07
91 (let* ((include (or (and direct-superclasses
92 (find-class (car direct-superclasses
) nil
))
93 (and (not (eq name
'structure-object
))
94 *the-class-structure-object
*)))
95 (defstruct-form (make-structure-class-defstruct-form
96 name
(class-direct-slots (find-class name
))
99 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
100 ,defstruct-form
) ; really compile the defstruct-form
101 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
104 ;; By telling the type system at compile time about
105 ;; the existence of a class named NAME, we can avoid
106 ;; various bogus warnings about "type isn't defined yet"
107 ;; for code elsewhere in the same file which uses
108 ;; the name of the type.
110 ;; We only need to do this at compile time, because
111 ;; at load and execute time we write the actual
112 ;; full-blown class, so the "a class of this name is
113 ;; coming" note we write here would be irrelevant.
114 (eval-when (:compile-toplevel
)
115 (%compiler-defclass
',name
116 ',*readers-for-this-defclass
*
117 ',*writers-for-this-defclass
*
118 ',*slot-names-for-this-defclass
*))
119 ,defclass-form
)))))))
121 (defun canonize-defclass-options (class-name options
)
122 (maplist (lambda (sublist)
123 (let ((option-name (first (pop sublist
))))
124 (when (member option-name sublist
:key
#'first
:test
#'eq
)
125 (error 'simple-program-error
126 :format-control
"Multiple ~S options in DEFCLASS ~S."
127 :format-arguments
(list option-name class-name
)))))
133 (dolist (option options
)
134 (unless (listp option
)
135 (error "~S is not a legal defclass option." option
))
138 (let ((maybe-metaclass (second option
)))
139 (unless (and maybe-metaclass
(legal-class-name-p maybe-metaclass
))
140 (error 'simple-program-error
141 :format-control
"~@<The value of the :metaclass option (~S) ~
142 is not a legal class name.~:@>"
143 :format-arguments
(list maybe-metaclass
)))
144 (setf metaclass maybe-metaclass
)))
146 (let (initargs arg-names
)
147 (doplist (key val
) (cdr option
)
148 (when (member key arg-names
:test
#'eq
)
149 (error 'simple-program-error
150 :format-control
"~@<Duplicate initialization argument ~
151 name ~S in :DEFAULT-INITARGS of ~
153 :format-arguments
(list key class-name
)))
155 (push ``(,',key
,',val
,,(make-initfunction val
)) initargs
))
156 (setf default-initargs t
)
157 (push `(:direct-default-initargs
(list ,@(nreverse initargs
)))
160 (unless (stringp (second option
))
161 (error "~S is not a legal :documentation value" (second option
)))
162 (setf documentation t
)
163 (push `(:documentation
,(second option
)) canonized-options
))
165 (push `(',(car option
) ',(cdr option
)) canonized-options
))))
166 (unless default-initargs
167 (push '(:direct-default-initargs nil
) canonized-options
))
168 (values (or metaclass
'standard-class
) (nreverse canonized-options
))))
170 (defun canonize-defclass-slots (class-name slots env
)
171 (let (canonized-specs)
174 (setf spec
(list spec
)))
175 (when (and (cdr spec
) (null (cddr spec
)))
176 (error 'simple-program-error
177 :format-control
"~@<in DEFCLASS ~S, the slot specification ~S ~
178 is invalid; the probable intended meaning may ~
179 be achieved by specifiying ~S instead.~:>"
180 :format-arguments
(list class-name spec
181 `(,(car spec
) :initform
,(cadr spec
)))))
182 (let* ((name (car spec
))
188 (unsupplied (list nil
))
190 (initform unsupplied
))
191 (check-slot-name-for-defclass name class-name env
)
192 (push name
*slot-names-for-this-defclass
*)
193 (flet ((note-reader (x)
195 (error 'simple-program-error
196 :format-control
"Slot reader name ~S for slot ~S in ~
197 DEFCLASS ~S is not a symbol."
198 :format-arguments
(list x name class-name
)))
200 (push x
*readers-for-this-defclass
*))
203 (push x
*writers-for-this-defclass
*)))
204 (doplist (key val
) plist
206 (:accessor
(note-reader val
) (note-writer `(setf ,val
)))
207 (:reader
(note-reader val
))
208 (:writer
(note-writer val
))
210 (unless (symbolp val
)
211 (error 'simple-program-error
212 :format-control
"Slot initarg name ~S for slot ~S in ~
213 DEFCLASS ~S is not a symbol."
214 :format-arguments
(list val name class-name
)))
217 (when (member key
'(:initform
:allocation
:type
:documentation
))
218 (when (eq key
:initform
)
222 (when (get-properties others
(list key
))
223 (error 'simple-program-error
224 :format-control
"Duplicate slot option ~S for slot ~
226 :format-arguments
(list key name class-name
))))
227 ;; For non-standard options multiple entries go in a list
228 (push val
(getf others key
))))))
229 ;; Unwrap singleton lists (AMOP 5.4.2)
230 (do ((head others
(cddr head
)))
232 (unless (cdr (second head
))
233 (setf (second head
) (car (second head
)))))
234 (let ((canon `(:name
',name
:readers
',readers
:writers
',writers
235 :initargs
',initargs
',others
)))
236 (push (if (eq initform unsupplied
)
238 `(list* :initfunction
,(make-initfunction initform
)
241 (nreverse canonized-specs
)))
244 (defun check-slot-name-for-defclass (name class-name env
)
245 (flet ((slot-name-illegal (reason)
246 (error 'simple-program-error
248 (format nil
"~~@<In DEFCLASS ~~S, the slot name ~~S ~
250 :format-arguments
(list class-name name
))))
251 (cond ((not (symbolp name
))
252 (slot-name-illegal "not a symbol"))
254 (slot-name-illegal "a keyword"))
255 ((constantp name env
)
256 (slot-name-illegal "a constant"))
257 ((member name
*slot-names-for-this-defclass
* :test
#'eq
)
258 (error 'simple-program-error
259 :format-control
"Multiple slots named ~S in DEFCLASS ~S."
260 :format-arguments
(list name class-name
))))))
262 (defun make-initfunction (initform)
263 (cond ((or (eq initform t
)
264 (equal initform
''t
))
265 '(function constantly-t
))
266 ((or (eq initform nil
)
267 (equal initform
''nil
))
268 '(function constantly-nil
))
269 ((or (eql initform
0)
270 (equal initform
''0))
271 '(function constantly-0
))
273 (let ((entry (assoc initform
*initfunctions-for-this-defclass
*
276 (setq entry
(list initform
278 `(function (lambda ()
280 (sb-c:store-coverage-data
0)))
282 (push entry
*initfunctions-for-this-defclass
*))
285 (defun %compiler-defclass
(name readers writers slots
)
286 ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
287 ;; "appears as a top level form, the compiler must make the class
288 ;; name be recognized as a valid type name in subsequent
289 ;; declarations (as for deftype) and be recognized as a valid class
290 ;; name for defmethod parameter specializers and for use as the
291 ;; :metaclass option of a subsequent defclass."
292 (preinform-compiler-about-class-type name
)
293 (preinform-compiler-about-accessors readers writers slots
))
295 (defun preinform-compiler-about-class-type (name)
296 ;; Unless the type system already has an actual type attached to
297 ;; NAME (in which case (1) writing a placeholder value over that
298 ;; actual type as a compile-time side-effect would probably be a bad
299 ;; idea and (2) anyway we don't need to modify it in order to make
300 ;; NAME be recognized as a valid type name)
301 (with-single-package-locked-error (:symbol name
"proclaiming ~S as a class"))
302 (unless (info :type
:kind name
)
303 ;; Tell the compiler to expect a class with the given NAME, by
304 ;; writing a kind of minimal placeholder type information. This
305 ;; placeholder will be overwritten later when the class is defined.
306 (setf (info :type
:kind name
) :forthcoming-defclass-type
))
309 (defun preinform-compiler-about-accessors (readers writers slots
)
310 (flet ((inform (names type
&key key
)
312 (let ((name (if key
(funcall key name
) name
)))
313 (when (eq (info :function
:where-from name
) :assumed
)
314 (sb-c:proclaim-ftype name type
:defined
))))
316 (let ((rtype (specifier-type '(function (t) t
)))
317 (wtype (specifier-type '(function (t t
) t
))))
318 (inform readers rtype
)
319 (inform writers wtype
)
320 (inform slots rtype
:key
#'slot-reader-name
)
321 (inform slots rtype
:key
#'slot-boundp-name
)
322 (inform slots wtype
:key
#'slot-writer-name
))))
324 ;;; This is the early definition of LOAD-DEFCLASS. It just collects up
325 ;;; all the class definitions in a list. Later, in braid1.lisp, these
326 ;;; are actually defined.
328 ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
329 (defparameter *early-class-definitions
* ())
331 (defun early-class-definition (class-name)
332 (or (find class-name
*early-class-definitions
* :key
#'ecd-class-name
)
333 (error "~S is not a class in *early-class-definitions*." class-name
)))
335 (defun make-early-class-definition
336 (name source-location metaclass
337 superclass-names canonical-slots other-initargs
)
338 (list 'early-class-definition
339 name source-location metaclass
340 superclass-names canonical-slots other-initargs
))
342 (defun ecd-class-name (ecd) (nth 1 ecd
))
343 (defun ecd-source-location (ecd) (nth 2 ecd
))
344 (defun ecd-metaclass (ecd) (nth 3 ecd
))
345 (defun ecd-superclass-names (ecd) (nth 4 ecd
))
346 (defun ecd-canonical-slots (ecd) (nth 5 ecd
))
347 (defun ecd-other-initargs (ecd) (nth 6 ecd
))
349 (defvar *early-class-slots
* nil
)
351 (defun canonical-slot-name (canonical-slot)
352 (getf canonical-slot
:name
))
354 (defun early-class-slots (class-name)
355 (cdr (or (assoc class-name
*early-class-slots
*)
356 (let ((a (cons class-name
357 (mapcar #'canonical-slot-name
358 (early-collect-inheritance class-name
)))))
359 (push a
*early-class-slots
*)
362 (defun early-class-size (class-name)
363 (length (early-class-slots class-name
)))
365 (defun early-collect-inheritance (class-name)
366 ;;(declare (values slots cpl default-initargs direct-subclasses))
367 (let ((cpl (early-collect-cpl class-name
)))
368 (values (early-collect-slots cpl
)
370 (early-collect-default-initargs cpl
)
372 (dolist (definition *early-class-definitions
*)
373 (when (memq class-name
(ecd-superclass-names definition
))
374 (push (ecd-class-name definition
) collect
)))
375 (nreverse collect
)))))
377 (defun early-collect-slots (cpl)
378 (let* ((definitions (mapcar #'early-class-definition cpl
))
379 (super-slots (mapcar #'ecd-canonical-slots definitions
))
380 (slots (apply #'append
(reverse super-slots
))))
382 (let ((name1 (canonical-slot-name s1
)))
383 (dolist (s2 (cdr (memq s1 slots
)))
384 (when (eq name1
(canonical-slot-name s2
))
385 (error "More than one early class defines a slot with the~%~
386 name ~S. This can't work because the bootstrap~%~
387 object system doesn't know how to compute effective~%~
392 (defun early-collect-cpl (class-name)
394 (let* ((definition (early-class-definition c
))
395 (supers (ecd-superclass-names definition
)))
397 (apply #'append
(mapcar #'early-collect-cpl supers
))))))
398 (remove-duplicates (walk class-name
) :from-end nil
:test
#'eq
)))
400 (defun early-collect-default-initargs (cpl)
401 (let ((default-initargs ()))
402 (dolist (class-name cpl
)
403 (let* ((definition (early-class-definition class-name
))
404 (others (ecd-other-initargs definition
)))
405 (loop (when (null others
) (return nil
))
406 (let ((initarg (pop others
)))
407 (unless (eq initarg
:direct-default-initargs
)
408 (error "~@<The defclass option ~S is not supported by ~
409 the bootstrap object system.~:@>"
411 (setq default-initargs
412 (nconc default-initargs
(reverse (pop others
)))))))
413 (reverse default-initargs
)))
415 (defun !bootstrap-slot-index
(class-name slot-name
)
416 (or (position slot-name
(early-class-slots class-name
))
417 (error "~S not found" slot-name
)))
419 ;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
420 ;;; change the values of slots during bootstrapping. During
421 ;;; bootstrapping, there are only two kinds of objects whose slots we
422 ;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
423 ;;; to these functions tells whether the object is a CLASS or a
426 ;;; Note that the way this works it stores the slot in the same place
427 ;;; in memory that the full object system will expect to find it
428 ;;; later. This is critical to the bootstrapping process, the whole
429 ;;; changeover to the full object system is predicated on this.
431 ;;; One important point is that the layout of standard classes and
432 ;;; standard slots must be computed the same way in this file as it is
433 ;;; by the full object system later.
434 (defmacro !bootstrap-get-slot
(type object slot-name
)
435 `(clos-slots-ref (get-slots ,object
)
436 (!bootstrap-slot-index
,type
,slot-name
)))
437 (defun !bootstrap-set-slot
(type object slot-name new-value
)
438 (setf (!bootstrap-get-slot type object slot-name
) new-value
))
440 (defun early-class-name (class)
441 (!bootstrap-get-slot
'class class
'name
))
443 (defun early-class-precedence-list (class)
444 (!bootstrap-get-slot
'pcl-class class
'%class-precedence-list
))
446 (defun early-class-name-of (instance)
447 (early-class-name (class-of instance
)))
449 (defun early-class-slotds (class)
450 (!bootstrap-get-slot
'slot-class class
'slots
))
452 (defun early-slot-definition-name (slotd)
453 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'name
))
455 (defun early-slot-definition-location (slotd)
456 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'location
))
458 (defun early-slot-definition-info (slotd)
459 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'info
))
461 (defun early-accessor-method-slot-name (method)
462 (!bootstrap-get-slot
'standard-accessor-method method
'slot-name
))
464 (unless (fboundp 'class-name-of
)
465 (setf (symbol-function 'class-name-of
)
466 (symbol-function 'early-class-name-of
)))
467 (unintern 'early-class-name-of
)
469 (defun early-class-direct-subclasses (class)
470 (!bootstrap-get-slot
'class class
'direct-subclasses
))
472 (declaim (notinline load-defclass
))
473 (defun load-defclass (name metaclass supers canonical-slots canonical-options
474 readers writers slot-names source-location
&optional safe-p
)
475 ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since
476 ;; during the bootstrap we won't have (SAFETY 3).
477 (declare (ignore safe-p
))
478 (%compiler-defclass name readers writers slot-names
)
479 (setq supers
(copy-tree supers
)
480 canonical-slots
(copy-tree canonical-slots
)
481 canonical-options
(copy-tree canonical-options
))
483 (make-early-class-definition name
490 (find name
*early-class-definitions
* :key
#'ecd-class-name
)))
491 (setq *early-class-definitions
*
492 (cons ecd
(remove existing
*early-class-definitions
*)))