(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..
(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))