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 (check-class-name name nil
)
45 (let (*initfunctions-for-this-defclass
*
46 *readers-for-this-defclass
* ;Truly a crock, but we got
47 *writers-for-this-defclass
* ;to have it to live nicely.
48 *slot-names-for-this-defclass
*)
49 ;; FIXME: It would be nice to collect all errors from the
50 ;; expansion of a defclass and signal them in a single go.
51 (multiple-value-bind (metaclass canonical-options
)
52 (canonize-defclass-options name options
)
53 ;; Check deprecation status of direct superclasses and
55 (mapc #'sb-int
:check-deprecated-type direct-superclasses
)
56 (sb-int:check-deprecated-type metaclass
)
57 (let ((canonical-slots (canonize-defclass-slots name direct-slots env
))
58 ;; DEFSTRUCT-P should be true if the class is defined
59 ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
60 ;; is compiled for the class.
61 (defstruct-p (and (eq **boot-state
** 'complete
)
62 (let ((mclass (find-class metaclass nil
)))
66 *the-class-structure-class
*))))))
68 `(let ,(mapcar #'cdr
*initfunctions-for-this-defclass
*)
72 (list ,@canonical-slots
)
73 (list ,@(apply #'append
75 '(:from-defclass-p t
))
77 ',*readers-for-this-defclass
*
78 ',*writers-for-this-defclass
*
79 ',*slot-names-for-this-defclass
*
80 (sb-c:source-location
)
81 ,@(and (safe-code-p env
)
85 ;; FIXME: (YUK!) Why do we do this? Because in order
86 ;; to make the defstruct form, we need to know what
87 ;; the accessors for the slots are, so we need already
88 ;; to have hooked into the CLOS machinery.
90 ;; There may be a better way to do this: it would
91 ;; involve knowing enough about PCL to ask "what will
92 ;; my slot names and accessors be"; failing this, we
93 ;; currently just evaluate the whole kaboodle, and
94 ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07
96 (let* ((include (or (and direct-superclasses
97 (find-class (car direct-superclasses
) nil
))
98 (and (not (eq name
'structure-object
))
99 *the-class-structure-object
*)))
100 (defstruct-form (make-structure-class-defstruct-form
101 name
(class-direct-slots (find-class name
))
104 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
105 ,defstruct-form
) ; really compile the defstruct-form
106 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
109 ;; By telling the type system at compile time about
110 ;; the existence of a class named NAME, we can avoid
111 ;; various bogus warnings about "type isn't defined yet"
112 ;; for code elsewhere in the same file which uses
113 ;; the name of the type.
115 ;; We only need to do this at compile time, because
116 ;; at load and execute time we write the actual
117 ;; full-blown class, so the "a class of this name is
118 ;; coming" note we write here would be irrelevant.
119 (eval-when (:compile-toplevel
)
120 (sb-kernel::%compiler-defclass
122 ',*readers-for-this-defclass
*
123 ',*writers-for-this-defclass
*
124 ',*slot-names-for-this-defclass
*))
125 ,defclass-form
)))))))
127 (defun canonize-defclass-options (class-name options
)
128 (maplist (lambda (sublist)
129 (let ((option-name (first (pop sublist
))))
130 (when (member option-name sublist
:key
#'first
:test
#'eq
)
131 (error 'simple-program-error
132 :format-control
"Multiple ~S options in DEFCLASS ~S."
133 :format-arguments
(list option-name class-name
)))))
139 (dolist (option options
)
140 (unless (listp option
)
141 (error "~S is not a legal defclass option." option
))
144 (let ((maybe-metaclass (second option
)))
145 (unless (and maybe-metaclass
(legal-class-name-p maybe-metaclass
))
146 (error 'simple-program-error
147 :format-control
"~@<The value of the :metaclass option (~S) ~
148 is not a legal class name.~:@>"
149 :format-arguments
(list maybe-metaclass
)))
150 (setf metaclass maybe-metaclass
)))
152 (let (initargs arg-names
)
153 (doplist (key val
) (cdr option
)
154 (when (member key arg-names
:test
#'eq
)
155 (error 'simple-program-error
156 :format-control
"~@<Duplicate initialization argument ~
157 name ~S in :DEFAULT-INITARGS of ~
159 :format-arguments
(list key class-name
)))
161 (push ``(,',key
,',val
,,(make-initfunction val
)) initargs
))
162 (setf default-initargs t
)
163 (push `(:direct-default-initargs
(list ,@(nreverse initargs
)))
166 (unless (stringp (second option
))
167 (error "~S is not a legal :documentation value" (second option
)))
168 (setf documentation t
)
169 (push `(:documentation
,(second option
)) canonized-options
))
171 (push `(',(car option
) ',(cdr option
)) canonized-options
))))
172 (unless default-initargs
173 (push '(:direct-default-initargs nil
) canonized-options
))
174 (values (or metaclass
'standard-class
) (nreverse canonized-options
))))
176 (defun canonize-defclass-slots (class-name slots env
)
177 (let (canonized-specs)
179 (let ((location (or (and (boundp 'sb-c
::*current-path
*)
180 (boundp 'sb-c
::*source-paths
*)
181 (let ((sb-c::*current-path
*
182 (or (sb-c::get-source-path spec
)
183 sb-c
::*current-path
*)))
184 (sb-c::make-definition-source-location
)))
185 (sb-c::make-definition-source-location
))))
187 (setf spec
(list spec
)))
188 (when (and (cdr spec
) (null (cddr spec
)))
189 (error 'simple-program-error
190 :format-control
"~@<in DEFCLASS ~S, the slot specification ~S ~
191 is invalid; the probable intended meaning may ~
192 be achieved by specifiying ~S instead.~:>"
193 :format-arguments
(list class-name spec
194 `(,(car spec
) :initform
,(cadr spec
)))))
195 (let* ((name (car spec
))
201 (unsupplied (list nil
))
203 (initform unsupplied
))
204 (check-slot-name-for-defclass name class-name env
)
205 (push name
*slot-names-for-this-defclass
*)
206 (flet ((note-reader (x)
208 (error 'simple-program-error
209 :format-control
"Slot reader name ~S for slot ~S in ~
210 DEFCLASS ~S is not a symbol."
211 :format-arguments
(list x name class-name
)))
213 (push x
*readers-for-this-defclass
*))
216 (push x
*writers-for-this-defclass
*)))
217 (doplist (key val
) plist
219 (:accessor
(note-reader val
) (note-writer `(setf ,val
)))
220 (:reader
(note-reader val
))
221 (:writer
(note-writer val
))
223 (unless (symbolp val
)
224 (error 'simple-program-error
225 :format-control
"Slot initarg name ~S for slot ~S in ~
226 DEFCLASS ~S is not a symbol."
227 :format-arguments
(list val name class-name
)))
230 (when (member key
'(:initform
:allocation
:type
:documentation
))
231 (when (eq key
:initform
)
235 (when (get-properties others
(list key
))
236 (error 'simple-program-error
237 :format-control
"Duplicate slot option ~S for slot ~
239 :format-arguments
(list key name class-name
))))
240 ;; For non-standard options multiple entries go in a list
241 (push val
(getf others key
))))))
242 ;; Unwrap singleton lists (AMOP 5.4.2)
243 (do ((head others
(cddr head
)))
245 (unless (cdr (second head
))
246 (setf (second head
) (car (second head
)))))
247 (let ((canon `(:name
',name
:readers
',readers
:writers
',writers
248 :initargs
',initargs
'source
,location
',others
)))
249 (push (if (eq initform unsupplied
)
251 `(list* :initfunction
,(make-initfunction initform
)
254 (nreverse canonized-specs
)))
257 (defun check-slot-name-for-defclass (name class-name env
)
258 (flet ((slot-name-illegal (reason)
259 (error 'simple-program-error
260 :format-control
"~@<In DEFCLASS ~S, the slot name ~S ~
262 :format-arguments
(list class-name name reason
))))
263 (cond ((not (symbolp name
))
264 (slot-name-illegal "not a symbol"))
266 (slot-name-illegal "a keyword"))
267 ((constantp name env
)
268 (slot-name-illegal "a constant"))
269 ((member name
*slot-names-for-this-defclass
* :test
#'eq
)
270 (error 'simple-program-error
271 :format-control
"Multiple slots named ~S in DEFCLASS ~S."
272 :format-arguments
(list name class-name
))))))
274 (defun make-initfunction (initform)
275 (cond ((or (eq initform t
)
276 (equal initform
''t
))
277 '(function constantly-t
))
278 ((or (eq initform nil
)
279 (equal initform
''nil
))
280 '(function constantly-nil
))
281 ((or (eql initform
0)
282 (equal initform
''0))
283 '(function constantly-0
))
285 (let ((entry (assoc initform
*initfunctions-for-this-defclass
*
288 (setq entry
(list initform
290 `(function (lambda ()
292 (sb-c:store-coverage-data
0)))
294 (push entry
*initfunctions-for-this-defclass
*))
298 ;;; This is the early definition of LOAD-DEFCLASS. It just collects up
299 ;;; all the class definitions in a list. Later, in braid1.lisp, these
300 ;;; are actually defined.
302 ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
303 (defparameter *!early-class-definitions
* ())
305 (defun !early-class-definition
(class-name)
306 (or (find class-name
*!early-class-definitions
* :key
#'ecd-class-name
)
307 (error "~S is not a class in *early-class-definitions*." class-name
)))
309 (defun !make-early-class-definition
310 (name source-location metaclass
311 superclass-names canonical-slots other-initargs
)
312 (list 'early-class-definition
313 name source-location metaclass
314 superclass-names canonical-slots other-initargs
))
316 (defun ecd-class-name (ecd) (nth 1 ecd
))
317 (defun ecd-source-location (ecd) (nth 2 ecd
))
318 (defun ecd-metaclass (ecd) (nth 3 ecd
))
319 (defun ecd-superclass-names (ecd) (nth 4 ecd
))
320 (defun ecd-canonical-slots (ecd) (nth 5 ecd
))
321 (defun ecd-other-initargs (ecd) (nth 6 ecd
))
323 (defvar *!early-class-slots
* nil
)
325 (defun canonical-slot-name (canonical-slot)
326 (getf canonical-slot
:name
))
328 (defun !early-class-slots
(class-name)
329 (cdr (or (assoc class-name
*!early-class-slots
*)
330 (let ((a (cons class-name
331 (mapcar #'canonical-slot-name
332 (!early-collect-inheritance class-name
)))))
333 (push a
*!early-class-slots
*)
336 (defun !early-class-size
(class-name)
337 (length (!early-class-slots class-name
)))
339 (defun !early-collect-inheritance
(class-name)
340 ;;(declare (values slots cpl default-initargs direct-subclasses))
341 (let ((cpl (!early-collect-cpl class-name
)))
342 (values (!early-collect-slots cpl
)
344 (!early-collect-default-initargs cpl
)
346 (dolist (definition *!early-class-definitions
*)
347 (when (memq class-name
(ecd-superclass-names definition
))
348 (push (ecd-class-name definition
) collect
)))
349 (nreverse collect
)))))
351 (defun !early-collect-slots
(cpl)
352 (let* ((definitions (mapcar #'!early-class-definition cpl
))
353 (super-slots (mapcar #'ecd-canonical-slots definitions
))
354 (slots (apply #'append
(reverse super-slots
))))
356 (let ((name1 (canonical-slot-name s1
)))
357 (dolist (s2 (cdr (memq s1 slots
)))
358 (when (eq name1
(canonical-slot-name s2
))
359 (error "More than one early class defines a slot with the~%~
360 name ~S. This can't work because the bootstrap~%~
361 object system doesn't know how to compute effective~%~
366 (defun !early-collect-cpl
(class-name)
368 (let* ((definition (!early-class-definition c
))
369 (supers (ecd-superclass-names definition
)))
371 (apply #'append
(mapcar #'!early-collect-cpl supers
))))))
372 (remove-duplicates (walk class-name
) :from-end nil
:test
#'eq
)))
374 (defun !early-collect-default-initargs
(cpl)
375 (let ((default-initargs ()))
376 (dolist (class-name cpl
)
377 (let* ((definition (!early-class-definition class-name
))
378 (others (ecd-other-initargs definition
)))
379 (loop (when (null others
) (return nil
))
380 (let ((initarg (pop others
)))
381 (unless (eq initarg
:direct-default-initargs
)
382 (error "~@<The defclass option ~S is not supported by ~
383 the bootstrap object system.~:@>"
385 (setq default-initargs
386 (nconc default-initargs
(reverse (pop others
)))))))
387 (reverse default-initargs
)))
389 (defun !bootstrap-slot-index
(class-name slot-name
)
390 (or (position slot-name
(!early-class-slots class-name
))
391 (error "~S not found" slot-name
)))
393 ;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
394 ;;; change the values of slots during bootstrapping. During
395 ;;; bootstrapping, there are only two kinds of objects whose slots we
396 ;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
397 ;;; to these functions tells whether the object is a CLASS or a
400 ;;; Note that the way this works it stores the slot in the same place
401 ;;; in memory that the full object system will expect to find it
402 ;;; later. This is critical to the bootstrapping process, the whole
403 ;;; changeover to the full object system is predicated on this.
405 ;;; One important point is that the layout of standard classes and
406 ;;; standard slots must be computed the same way in this file as it is
407 ;;; by the full object system later.
408 (defmacro !bootstrap-get-slot
(type object slot-name
)
409 `(clos-slots-ref (get-slots ,object
)
410 (!bootstrap-slot-index
,type
,slot-name
)))
411 (defun !bootstrap-set-slot
(type object slot-name new-value
)
412 (setf (!bootstrap-get-slot type object slot-name
) new-value
))
414 (defun early-class-name (class)
415 (!bootstrap-get-slot
'class class
'name
))
417 (defun early-class-precedence-list (class)
418 (!bootstrap-get-slot
'pcl-class class
'%class-precedence-list
))
420 (defun early-class-name-of (instance)
421 (early-class-name (class-of instance
)))
423 (defun early-class-slotds (class)
424 (!bootstrap-get-slot
'slot-class class
'slots
))
426 (defun early-slot-definition-name (slotd)
427 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'name
))
429 (defun early-slot-definition-location (slotd)
430 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'location
))
432 (defun early-slot-definition-info (slotd)
433 (!bootstrap-get-slot
'standard-effective-slot-definition slotd
'info
))
435 (defun early-accessor-method-slot-name (method)
436 (!bootstrap-get-slot
'standard-accessor-method method
'slot-name
))
438 (unless (fboundp 'class-name-of
)
439 (setf (symbol-function 'class-name-of
)
440 (symbol-function 'early-class-name-of
)))
441 (unintern 'early-class-name-of
)
443 (defun early-class-direct-subclasses (class)
444 (!bootstrap-get-slot
'class class
'direct-subclasses
))
446 (declaim (notinline load-defclass
))
447 (defun load-defclass (name metaclass supers canonical-slots canonical-options
448 readers writers slot-names source-location
&optional safe-p
)
449 ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since
450 ;; during the bootstrap we won't have (SAFETY 3).
451 (declare (ignore safe-p
))
452 (sb-kernel::%%compiler-defclass name readers writers slot-names
)
453 (let ((ecd (!make-early-class-definition name
457 (copy-tree canonical-slots
)
458 (copy-tree canonical-options
)))
460 (find name
*!early-class-definitions
* :key
#'ecd-class-name
)))
461 (setq *!early-class-definitions
*
462 (cons ecd
(remove existing
*!early-class-definitions
*)))