;;;
;;; After the metabraid has been setup, and the protocol for defining
;;; classes has been defined, the real definition of LOAD-DEFCLASS is
-;;; installed by the file defclass.lisp
+;;; installed by the file std-class.lisp
(defmacro defclass (name direct-superclasses direct-slots &rest options)
(expand-defclass name direct-superclasses direct-slots options))
(defun expand-defclass (name supers slots options)
- ;; FIXME: We should probably just ensure that the relevant
- ;; DEFVAR/DEFPARAMETERs occur before this definition, rather
- ;; than locally declaring them SPECIAL.
- (declare (special *boot-state* *the-class-structure-class*))
(setq supers (copy-tree supers)
slots (copy-tree slots)
options (copy-tree options))
(defstruct-p (and (eq *boot-state* 'complete)
(let ((mclass (find-class metaclass nil)))
(and mclass
- (*subtypep mclass
- *the-class-structure-class*))))))
+ (*subtypep
+ mclass
+ *the-class-structure-class*))))))
(let ((defclass-form
- (eval-when (:load-toplevel :execute)
- `(progn
- ,@(mapcar #'(lambda (x)
- `(declaim (ftype (function (t) t) ,x)))
- *readers*)
- ,@(mapcar #'(lambda (x)
- `(declaim (ftype (function (t t) t) ,x)))
- *writers*)
- (let ,(mapcar #'cdr *initfunctions*)
- (load-defclass ',name
- ',metaclass
- ',supers
- (list ,@canonical-slots)
- (list ,@(apply #'append
- (when defstruct-p
- '(:from-defclass-p t))
- other-initargs))))))))
+ `(progn
+ ,@(mapcar (lambda (x)
+ `(declaim (ftype (function (t) t) ,x)))
+ *readers*)
+ ,@(mapcar (lambda (x)
+ `(declaim (ftype (function (t t) t) ,x)))
+ *writers*)
+ (let ,(mapcar #'cdr *initfunctions*)
+ (load-defclass ',name
+ ',metaclass
+ ',supers
+ (list ,@canonical-slots)
+ (list ,@(apply #'append
+ (when defstruct-p
+ '(:from-defclass-p t))
+ other-initargs)))))))
+ ;; FIXME: The way that we do things like (EVAL DEFCLASS-FORM)
+ ;; here is un-ANSI-Common-Lisp-y and leads to problems
+ ;; (like DEFUN for the type predicate being called more than
+ ;; once when we do DEFCLASS at the interpreter prompt),
+ ;; causing bogus style warnings. It would be better to
+ ;; rewrite this so that the macroexpansion looks like e.g.
+ ;; (PROGN
+ ;; (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+ ;; (FROB1 ..))
+ ;; (EVAL-WHEN (:LOAD-TOPLEVEL :EXECUTE)
+ ;; (FROB2 ..)))
(if defstruct-p
(progn
(eval defclass-form) ; Define the class now, so that..
,defclass-form))
(progn
(when (eq *boot-state* 'complete)
+ ;; FIXME: MNA (on sbcl-devel 2001-05-30) reported
+ ;; (if I understand correctly -- WHN) that this call
+ ;; is directly responsible for defining
+ ;; class-predicates which always return
+ ;; CONSTANTLY-NIL in the compile-time environment,
+ ;; and is indirectly responsible for bogus warnings
+ ;; about redefinitions when making definitions in
+ ;; the interpreter. I didn't like his fix (deleting
+ ;; the call) since I think the type system *should*
+ ;; be informed about class definitions here. And I'm
+ ;; not eager to look too deeply into this sort of
+ ;; done-too-many-times-in-the-interpreter problem
+ ;; right now, since it should be easier to make a
+ ;; clean fix when EVAL-WHEN is made more ANSI (as
+ ;; per the IR1 section in the BUGS file). But
+ ;; at some point this should be cleaned up.
(inform-type-system-about-std-class name))
defclass-form)))))))
(defun make-initfunction (initform)
(declare (special *initfunctions*))
- (cond ((or (eq initform 't)
+ (cond ((or (eq initform t)
(equal initform ''t))
'(function constantly-t))
- ((or (eq initform 'nil)
+ ((or (eq initform nil)
(equal initform ''nil))
'(function constantly-nil))
- ((or (eql initform '0)
+ ((or (eql initform 0)
(equal initform ''0))
'(function constantly-0))
(t
(loop (when (null others) (return nil))
(let ((initarg (pop others)))
(unless (eq initarg :direct-default-initargs)
- (error "The defclass option ~S is not supported by the bootstrap~%~
- object system."
+ (error "~@<The defclass option ~S is not supported by ~
+ the bootstrap object system.~:@>"
initarg)))
(setq default-initargs
(nconc default-initargs (reverse (pop others)))))))
;;; standard slots must be computed the same way in this file as it is
;;; by the full object system later.
(defmacro !bootstrap-get-slot (type object slot-name)
- `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name)))
+ `(clos-slots-ref (get-slots ,object)
+ (!bootstrap-slot-index ,type ,slot-name)))
(defun !bootstrap-set-slot (type object slot-name new-value)
(setf (!bootstrap-get-slot type object slot-name) new-value))
projects / sbcl.git / blobdiff