(let ((inherits (inherits-for-structure dd)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
- (%compiler-defstruct ',dd ',inherits)
- ,@(when (eq (dd-type dd) 'structure)
- `((%compiler-truly-defstruct ',dd))))
+ (%compiler-defstruct ',dd ',inherits))
(%defstruct ',dd ',inherits)
,@(unless expanding-into-code-for-xc-host-p
(append (raw-accessor-definitions dd)
;; FIXME: Someday it'd probably be good to go back to using
;; closures for the out-of-line forms of structure accessors.
- ;; See comment on corresponding code in %%COMPILER-TRULY-DEFSTRUCT.
#|
(when (dd-predicate info)
(protect-cl (dd-predicate info))
(values))
-;;; Do compile-time actions for DEFSTRUCT.
-(defun %compiler-defstruct (info inherits)
+;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD.
+(defun %compiler-defstruct (dd inherits)
+ (declare (type defstruct-description dd))
(multiple-value-bind (class layout old-layout)
(multiple-value-bind (clayout clayout-p)
- (info :type :compiler-layout (dd-name info))
- (ensure-structure-class info
+ (info :type :compiler-layout (dd-name dd))
+ (ensure-structure-class dd
inherits
(if clayout-p "previously compiled" "current")
"compiled"
(t
(unless (eq (class-layout class) layout)
(register-layout layout :invalidate nil))
- (setf (sb!xc:find-class (dd-name info)) class)))
-
- (setf (info :type :compiler-layout (dd-name info)) layout))
- (values))
-
-;;; Do (COMPILE LOAD EVAL) time actions for updating the compiler's
-;;; global meta-information to represent the definition of a structure
-;;; (truly a structure, not just DEFSTRUCT :TYPE VECTOR or DEFSTRUCT
-;;; :TYPE LIST) described by INFO.
-(defun %compiler-truly-defstruct (info)
- (declare (type defstruct-description info))
- (let* ((name (dd-name info))
- (class (sb!xc:find-class name)))
-
- (let ((copier (dd-copier info)))
- (when copier
- (proclaim `(ftype (function (,name) ,name) ,copier))))
-
- ;; FIXME: This (and corresponding code in %DEFSTRUCT) are the way
- ;; that CMU CL defined the predicate, instead of using DEFUN.
- ;; Perhaps it would be better to go back to to the CMU CL way, or
- ;; something similar. I want to reduce the amount of magic in
- ;; DEFSTRUCT functions, but making the predicate be a closure
- ;; looks like a good thing, and can even be done without magic.
- ;; (OTOH, there are some bootstrapping issues involved, since
- ;; GENESIS understands DEFUN but doesn't understand a
- ;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.)
- #|
- (let ((predicate-name (dd-predicate-name info)))
- (when predicate-name
- (proclaim-as-defstruct-function-name predicate-name)
- (setf (info :function :inlinep pred) :inline)
- (setf (info :function :inline-expansion predicate-name)
- `(lambda (x) (typep x ',name)))))
- |#
-
- (dolist (slot (dd-slots info))
- (let* ((fun (dsd-accessor-name slot))
- (setf-fun `(setf ,fun)))
- (when (and fun (eq (dsd-raw-type slot) t))
- (proclaim-as-defstruct-function-name fun)
- (setf (info :function :accessor-for fun) class)
- (unless (dsd-read-only slot)
- (proclaim-as-defstruct-function-name setf-fun)
- (setf (info :function :accessor-for setf-fun) class)))))
-
- ;; FIXME: Couldn't this logic be merged into
- ;; PROCLAIM-AS-DEFSTRUCT-FUNCTION?
- (when (boundp 'sb!c:*free-functions*) ; when compiling
- (let ((free-functions sb!c:*free-functions*))
- (dolist (slot (dd-slots info))
- (let ((accessor-name (dsd-accessor-name slot)))
- (remhash accessor-name free-functions)
- (unless (dsd-read-only slot)
- (remhash `(setf ,accessor-name) free-functions))))
- (remhash (dd-predicate-name info) free-functions)
- (remhash (dd-copier info) free-functions))))
+ (setf (sb!xc:find-class (dd-name dd)) class)))
+
+ (setf (info :type :compiler-layout (dd-name dd)) layout))
+
+ (ecase (dd-type dd)
+ ((vector list funcallable-structure)
+ ;; nothing extra to do in this case
+ )
+ ((structure)
+ (let* ((name (dd-name dd))
+ (class (sb!xc:find-class name)))
+
+ (let ((copier (dd-copier dd)))
+ (when copier
+ (proclaim `(ftype (function (,name) ,name) ,copier))))
+
+ (dolist (slot (dd-slots dd))
+ (let* ((fun (dsd-accessor-name slot))
+ (setf-fun `(setf ,fun)))
+ (when (and fun (eq (dsd-raw-type slot) t))
+ (proclaim-as-defstruct-function-name fun)
+ (setf (info :function :accessor-for fun) class)
+ (unless (dsd-read-only slot)
+ (proclaim-as-defstruct-function-name setf-fun)
+ (setf (info :function :accessor-for setf-fun) class)))))
+
+ ;; FIXME: Couldn't this logic be merged into
+ ;; PROCLAIM-AS-DEFSTRUCT-FUNCTION?
+ (when (boundp 'sb!c:*free-functions*) ; when compiling
+ (let ((free-functions sb!c:*free-functions*))
+ (dolist (slot (dd-slots dd))
+ (let ((accessor-name (dsd-accessor-name slot)))
+ (remhash accessor-name free-functions)
+ (unless (dsd-read-only slot)
+ (remhash `(setf ,accessor-name) free-functions))))
+ (remhash (dd-predicate-name dd) free-functions)
+ (remhash (dd-copier dd) free-functions))))))
(values))
\f
(in-package "SB!C")
\f
+;;; Check that NAME is a valid function name, returning the name if
+;;; OK, and signalling an error if not. In addition to checking for
+;;; basic well-formedness, we also check that symbol names are not NIL
+;;; or the name of a special form.
+(defun check-function-name (name)
+ (typecase name
+ (list
+ (unless (and (consp name) (consp (cdr name))
+ (null (cddr name)) (eq (car name) 'setf)
+ (symbolp (cadr name)))
+ (compiler-error "illegal function name: ~S" name)))
+ (symbol
+ (when (eq (info :function :kind name) :special-form)
+ (compiler-error "Special form is an illegal function name: ~S" name)))
+ (t
+ (compiler-error "illegal function name: ~S" name)))
+ name)
+
;;; Record a new function definition, and check its legality.
(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
(defun proclaim-as-function-name (name)
(check-function-name name)
- (ecase (info :function :kind name)
- (:function
- (let ((accessor-for (info :function :accessor-for name)))
- (when accessor-for
- (compiler-style-warning
- "~@<The function ~
+ (when (fboundp name)
+ (ecase (info :function :kind name)
+ (:function
+ (let ((accessor-for (info :function :accessor-for name)))
+ (when accessor-for
+ (compiler-style-warning
+ "~@<The function ~
~2I~_~S ~
~I~_was previously defined as a slot accessor for ~
~2I~_~S.~:>"
- name
- accessor-for)
- (clear-info :function :accessor-for name))))
- (:macro
- (compiler-style-warning "~S was previously defined as a macro." name)
- (setf (info :function :where-from name) :assumed)
- (clear-info :function :macro-function name))
- ((nil)))
+ name
+ accessor-for)
+ (clear-info :function :accessor-for name))))
+ (:macro
+ (compiler-style-warning "~S was previously defined as a macro." name)
+ (setf (info :function :where-from name) :assumed)
+ (clear-info :function :macro-function name))
+ ((nil))))
(setf (info :function :kind name) :function)
(note-if-setf-function-and-macro name)
name)
+;;; This is called to do something about SETF functions that overlap
+;;; with SETF macros. Perhaps we should interact with the user to see
+;;; whether the macro should be blown away, but for now just give a
+;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
+;;; can't assume that they aren't just naming a function (SETF FOO)
+;;; for the heck of it. NAME is already known to be well-formed.
+(defun note-if-setf-function-and-macro (name)
+ (when (consp name)
+ (when (or (info :setf :inverse name)
+ (info :setf :expander name))
+ (compiler-style-warning
+ "defining as a SETF function a name that already has a SETF macro:~
+ ~% ~S"
+ name)))
+ (values))
+
;;; Make NAME no longer be a function name: clear everything back to
;;; the default.
(defun undefine-function-name (name)
(defvar *undefined-warnings*)
(declaim (list *undefined-warnings*))
-;;; Check that NAME is a valid function name, returning the name if
-;;; OK, and doing an error if not. In addition to checking for basic
-;;; well-formedness, we also check that symbol names are not NIL or
-;;; the name of a special form.
-(defun check-function-name (name)
- (typecase name
- (list
- (unless (and (consp name) (consp (cdr name))
- (null (cddr name)) (eq (car name) 'setf)
- (symbolp (cadr name)))
- (compiler-error "illegal function name: ~S" name))
- name)
- (symbol
- (when (eq (info :function :kind name) :special-form)
- (compiler-error "Special form is an illegal function name: ~S" name))
- name)
- (t
- (compiler-error "illegal function name: ~S" name))))
-
-;;; This is called to do something about SETF functions that overlap
-;;; with SETF macros. Perhaps we should interact with the user to see
-;;; whether the macro should be blown away, but for now just give a
-;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
-;;; can't assume that they aren't just naming a function (SETF FOO)
-;;; for the heck of it. NAME is already known to be well-formed.
-(defun note-if-setf-function-and-macro (name)
- (when (consp name)
- (when (or (info :setf :inverse name)
- (info :setf :expander name))
- (compiler-style-warning
- "defining as a SETF function a name that already has a SETF macro:~
- ~% ~S"
- name)))
- (values))
-
;;; Look up some symbols in *FREE-VARIABLES*, returning the var
;;; structures for any which exist. If any of the names aren't
;;; symbols, we complain.
projects / sbcl.git / commitdiff