(This version issues lots of bogus redefinition warnings, and
also fails in type.impure.lisp because it builds
structure slot accessors without enough type checks
(and so doesn't catch some kinds of improper usage).
Both of these problems seem to be symptoms of doing
things out of order in the macroexpansion and
compilation of DEFSTRUCT. Hopefully I can get rid of
these problems soon in the process of getting rid of
old 'def-ir1.*defstruct' constructs in favor of new
ANSI EVAL-WHEN-based constructs.)
renamed DSD-ACCESSOR to DSD-ACCESSOR-NAME
renamed DD-PREDICATE to DD-PREDICATE-NAME
undid KLUDGE/FIXME in DEFMACRO-MUNDANELY DECLAIM: Now that
EVAL-WHEN behaves better, we don't need it.
PROCLAIM INLINE shouldn't PROCLAIM-AS-FUNCTION-NAME (both in
principle and also because right now it's causing
problems in DEFSTRUCT)
PROCLAIM-AS-FUNCTION-NAME shouldn't blow away a structure class
just because it happens to use the same name for one of
its slot accessors (just as PROCLAIM INLINE change)
made DESCRIBE smarter about SETF functions
15 files changed:
it will issue WARNINGs about the type mismatches. It's not clear
how to make the compiler smart enough to fix this in general, but
a workaround is given in the entry for 117 in the BUGS file.
it will issue WARNINGs about the type mismatches. It's not clear
how to make the compiler smart enough to fix this in general, but
a workaround is given in the entry for 117 in the BUGS file.
-* The doc/cmucl/ directory, containing old CMU CL documentation,
- is no longer part of the base system. The files which used to
- be in the doc/cmucl/ directory are now available as
- <ftp://sbcl.sourceforge.net/pub/sbcl/cmucl-docs.tar.bz2>.
-* The default value of *BYTES-CONSED-BETWEEN-GCS* has been
- doubled, to 4 million. (If your application spends a lot of time
- GCing and you have a lot of RAM, you might want to experiment with
- increasing it even more.)
* The EVAL and EVAL-WHEN code has been largely rewritten, and the
old CMU CL "IR1 interpreter" has gone away. The new interpreter
is probably slower and harder to debug than the old one, but
* The EVAL and EVAL-WHEN code has been largely rewritten, and the
old CMU CL "IR1 interpreter" has gone away. The new interpreter
is probably slower and harder to debug than the old one, but
fixes:-). But hopefully any remaining bugs will be simpler, less
fundamental, and more fixable then the bugs in the old IR1
interpreter code.
fixes:-). But hopefully any remaining bugs will be simpler, less
fundamental, and more fixable then the bugs in the old IR1
interpreter code.
+* DEFSTRUCT and DEFCLASS have been substantially updated to take
+ advantage of the new EVAL-WHEN stuff and to clean them up in
+ general, and are now more ANSI-compliant in a number of ways. Martin
+ Atzmueller is responsible for a lot of this.
* A bug in LOOP operations on hash tables has been fixed, thanks
to a bug report and patch from Alexey Dejneka.
* A bug in LOOP operations on hash tables has been fixed, thanks
to a bug report and patch from Alexey Dejneka.
+* The default value of *BYTES-CONSED-BETWEEN-GCS* has been
+ doubled, to 4 million. (If your application spends a lot of time
+ GCing and you have a lot of RAM, you might want to experiment with
+ increasing it even more.)
* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry
and uses that copy, rather than the current dynamic value, when
it's trying to decide whether to truncate output . Thus e.g.
* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry
and uses that copy, rather than the current dynamic value, when
it's trying to decide whether to truncate output . Thus e.g.
:SB-PROPAGATE-FUN-TYPE are no longer considered to be optional
features. Instead, the code that they used to control is always
built into the system.
:SB-PROPAGATE-FUN-TYPE are no longer considered to be optional
features. Instead, the code that they used to control is always
built into the system.
+* The doc/cmucl/ directory, containing old CMU CL documentation,
+ is no longer part of the base system. The files which used to
+ be in the doc/cmucl/ directory are now available as
+ <ftp://sbcl.sourceforge.net/pub/sbcl/cmucl-docs.tar.bz2>.
* lots of tidying up internally: renaming things so that names are
more systematic and consistent, converting C macros to inline
functions, systematizing indentation, making symbol packaging
* lots of tidying up internally: renaming things so that names are
more systematic and consistent, converting C macros to inline
functions, systematizing indentation, making symbol packaging
"CLASS-LAYOUT" "CLASS-%NAME"
"DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
"%CODE-CODE-SIZE" "DD-SLOTS"
"CLASS-LAYOUT" "CLASS-%NAME"
"DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
"%CODE-CODE-SIZE" "DD-SLOTS"
- "%IMAGPART" "DSD-ACCESSOR"
+ "%IMAGPART" "DSD-ACCESSOR-NAME"
"%CODE-DEBUG-INFO" "DSD-%NAME"
"LAYOUT-CLASS" "LAYOUT-INVALID"
"%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP"
"DEFSTRUCT-SLOT-DESCRIPTION" "%FUNCTION-ARGLIST"
"%CODE-DEBUG-INFO" "DSD-%NAME"
"LAYOUT-CLASS" "LAYOUT-INVALID"
"%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP"
"DEFSTRUCT-SLOT-DESCRIPTION" "%FUNCTION-ARGLIST"
- "%FUNCTION-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE"
+ "%FUNCTION-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE-NAME"
"CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
"LAYOUT-OF" "%FUNCTION-SELF" "%REALPART"
"CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
"LAYOUT-OF" "%FUNCTION-SELF" "%REALPART"
(if (typep type 'structure-class)
(let ((info (layout-info (class-layout type))))
(if (and info (eq (dd-type info) 'structure))
(if (typep type 'structure-class)
(let ((info (layout-info (class-layout type))))
(if (and info (eq (dd-type info) 'structure))
- (let ((pred (dd-predicate info)))
- (if (and pred (fboundp pred))
- (fdefinition pred)
+ (let ((predicate-name (dd-predicate-name info)))
+ (if (and predicate-name (fboundp predicate-name))
+ (fdefinition predicate-name)
layout
(let* ((dd (layout-info layout))
(dsd (elt (dd-slots dd) (1- index)))
layout
(let* ((dd (layout-info layout))
(dsd (elt (dd-slots dd) (1- index)))
- (accessor (dsd-accessor dsd)))
- (declare (type symbol accessor))
- (funcall accessor instance)))))
+ (accessor-name (dsd-accessor-name dsd)))
+ (declare (type symbol accessor-name))
+ (funcall accessor-name instance)))))
(defun %instance-set (instance index new-value)
(aver (typep instance 'structure!object))
(let* ((class (sb!xc:find-class (type-of instance)))
(defun %instance-set (instance index new-value)
(aver (typep instance 'structure!object))
(let* ((class (sb!xc:find-class (type-of instance)))
(error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
(let* ((dd (layout-info layout))
(dsd (elt (dd-slots dd) (1- index)))
(error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
(let* ((dd (layout-info layout))
(dsd (elt (dd-slots dd) (1- index)))
- (accessor (dsd-accessor dsd)))
- (declare (type symbol accessor))
- (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
+ (accessor-name (dsd-accessor-name dsd)))
+ (declare (type symbol accessor-name))
+ (funcall (fdefinition `(setf ,accessor-name))
+ new-value
+ instance))))))
;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
;;; DEFSTRUCT-style arguments with any class names in the SB!XC
;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
;;; DEFSTRUCT-style arguments with any class names in the SB!XC
;; name of copying function
(copier (symbolicate "COPY-" name) :type (or symbol null))
;; name of type predicate
;; name of copying function
(copier (symbolicate "COPY-" name) :type (or symbol null))
;; name of type predicate
- (predicate (symbolicate name "-P") :type (or symbol null))
+ (predicate-name (symbolicate name "-P") :type (or symbol null))
;; the arguments to the :INCLUDE option, or NIL if no included
;; structure
(include nil :type list)
;; the arguments to the :INCLUDE option, or NIL if no included
;; structure
(include nil :type list)
;; the same name as an inherited accessor (which we don't want to
;; shadow)") but that behavior doesn't seem to be specified by (or
;; even particularly consistent with) ANSI, so it's gone in SBCL.)
;; the same name as an inherited accessor (which we don't want to
;; shadow)") but that behavior doesn't seem to be specified by (or
;; even particularly consistent with) ANSI, so it's gone in SBCL.)
default ; default value expression
(type t) ; declared type specifier
;; If this object does not describe a raw slot, this value is T.
default ; default value expression
(type t) ; declared type specifier
;; If this object does not describe a raw slot, this value is T.
;;; string to avoid creating lots of worthless symbols at load time.
(defun dsd-name (dsd)
(intern (string (dsd-%name dsd))
;;; string to avoid creating lots of worthless symbols at load time.
(defun dsd-name (dsd)
(intern (string (dsd-%name dsd))
- (if (dsd-accessor dsd)
- (symbol-package (dsd-accessor dsd))
+ (if (dsd-accessor-name dsd)
+ (symbol-package (dsd-accessor-name dsd))
(sane-package))))
\f
;;;; typed (non-class) structures
(sane-package))))
\f
;;;; typed (non-class) structures
(collect ((res))
(dolist (slot (dd-slots dd))
(let ((stype (dsd-type slot))
(collect ((res))
(dolist (slot (dd-slots dd))
(let ((stype (dsd-type slot))
- (accname (dsd-accessor slot))
+ (accessor-name (dsd-accessor-name slot))
(argname (gensym "ARG"))
(nvname (gensym "NEW-VALUE-")))
(multiple-value-bind (accessor offset data)
(slot-accessor-form dd slot argname)
;; When accessor exists and is raw
(argname (gensym "ARG"))
(nvname (gensym "NEW-VALUE-")))
(multiple-value-bind (accessor offset data)
(slot-accessor-form dd slot argname)
;; When accessor exists and is raw
- (when (and accname (not (eq accessor '%instance-ref)))
- (res `(declaim (inline ,accname)))
- (res `(declaim (ftype (function (,name) ,stype) ,accname)))
- (res `(defun ,accname (,argname)
+ (when (and accessor-name
+ (not (eq accessor-name '%instance-ref)))
+ (res `(declaim (inline ,accessor-name)))
+ (res `(declaim (ftype (function (,name) ,stype) ,accessor-name)))
+ (res `(defun ,accessor-name (,argname)
(truly-the ,stype (,accessor ,data ,offset))))
(unless (dsd-read-only slot)
(truly-the ,stype (,accessor ,data ,offset))))
(unless (dsd-read-only slot)
- (res `(declaim (inline (setf ,accname))))
+ (res `(declaim (inline (setf ,accessor-name))))
(res `(declaim (ftype (function (,stype ,name) ,stype)
(res `(declaim (ftype (function (,stype ,name) ,stype)
+ (setf ,accessor-name))))
;; FIXME: I rewrote this somewhat from the CMU CL definition.
;; Do some basic tests to make sure that reading and writing
;; raw slots still works correctly.
;; FIXME: I rewrote this somewhat from the CMU CL definition.
;; Do some basic tests to make sure that reading and writing
;; raw slots still works correctly.
- (res `(defun (setf ,accname) (,nvname ,argname)
+ (res `(defun (setf ,accessor-name) (,nvname ,argname)
(setf (,accessor ,data ,offset) ,nvname)
,nvname)))))))
(res))))
;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
(defun predicate-definitions (dd)
(setf (,accessor ,data ,offset) ,nvname)
,nvname)))))))
(res))))
;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
(defun predicate-definitions (dd)
- (let ((pred (dd-predicate dd))
+ (let ((pred (dd-predicate-name dd))
(argname (gensym)))
(when pred
(if (eq (dd-type dd) 'funcallable-structure)
(argname (gensym)))
(when pred
(if (eq (dd-type dd) 'funcallable-structure)
;;; DEFSTRUCT.
(defun typed-predicate-definitions (defstruct)
(let ((name (dd-name defstruct))
;;; DEFSTRUCT.
(defun typed-predicate-definitions (defstruct)
(let ((name (dd-name defstruct))
- (pred (dd-predicate defstruct))
+ (predicate-name (dd-predicate-name defstruct))
- (when (and pred (dd-named defstruct))
+ (when (and predicate-name (dd-named defstruct))
(let ((ltype (dd-lisp-type defstruct)))
(let ((ltype (dd-lisp-type defstruct)))
- `((defun ,pred (,argname)
+ `((defun ,predicate-name (,argname)
(and (typep ,argname ',ltype)
(eq (elt (the ,ltype ,argname)
,(cdr (car (last (find-name-indices defstruct)))))
(and (typep ,argname ',ltype)
(eq (elt (the ,ltype ,argname)
,(cdr (car (last (find-name-indices defstruct)))))
args
(setf (dd-copier defstruct) copier)))
(:predicate
args
(setf (dd-copier defstruct) copier)))
(:predicate
- (destructuring-bind (&optional (pred (symbolicate name "-P"))) args
- (setf (dd-predicate defstruct) pred)))
+ (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
+ args
+ (setf (dd-predicate-name defstruct) predicate-name)))
(:include
(when (dd-include defstruct)
(error "more than one :INCLUDE option"))
(:include
(when (dd-include defstruct)
(error "more than one :INCLUDE option"))
name-and-options))))
(when (stringp (car slot-descriptions))
(setf (dd-doc result) (pop slot-descriptions)))
name-and-options))))
(when (stringp (car slot-descriptions))
(setf (dd-doc result) (pop slot-descriptions)))
- (dolist (slot slot-descriptions)
- (allocate-1-slot result (parse-1-dsd result slot)))
+ (dolist (slot-description slot-descriptions)
+ (allocate-1-slot result (parse-1-dsd result slot-description)))
;;;; stuff to parse slot descriptions
;;; Parse a slot description for DEFSTRUCT, add it to the description
;;;; stuff to parse slot descriptions
;;; Parse a slot description for DEFSTRUCT, add it to the description
-;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
-;;; modify to get the new slot. This is supplied when handling
+;;; and return it. If supplied, SLOT is a pre-initialized DSD
+;;; that we modify to get the new slot. This is supplied when handling
;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
- (islot (make-defstruct-slot-description :%name ""
- :index 0
- :type t)))
+ (slot (make-defstruct-slot-description :%name ""
+ :index 0
+ :type t)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
(cond
((listp spec)
(multiple-value-bind (name default default-p type type-p read-only ro-p)
(cond
((listp spec)
(error 'simple-program-error
:format-control "duplicate slot name ~S"
:format-arguments (list name)))
(error 'simple-program-error
:format-control "duplicate slot name ~S"
:format-arguments (list name)))
- (setf (dsd-%name islot) (string name))
- (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
+ (setf (dsd-%name slot) (string name))
+ (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
(let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
(let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
- (predicate-name (dd-predicate defstruct)))
- (setf (dsd-accessor islot) accessor-name)
+ (predicate-name (dd-predicate-name defstruct)))
+ (setf (dsd-accessor-name slot) accessor-name)
(when (eql accessor-name predicate-name)
;; Some adventurous soul has named a slot so that its accessor
;; collides with the structure type predicate. ANSI doesn't
(when (eql accessor-name predicate-name)
;; Some adventurous soul has named a slot so that its accessor
;; collides with the structure type predicate. ANSI doesn't
this case; this implementation chooses to overwrite the type ~
predicate with the slot accessor.~@:>"
accessor-name)
this case; this implementation chooses to overwrite the type ~
predicate with the slot accessor.~@:>"
accessor-name)
- (setf (dd-predicate defstruct) nil)))
+ (setf (dd-predicate-name defstruct) nil)))
- (setf (dsd-default islot) default))
+ (setf (dsd-default slot) default))
- (setf (dsd-type islot)
- (if (eq (dsd-type islot) t)
+ (setf (dsd-type slot)
+ (if (eq (dsd-type slot) t)
- `(and ,(dsd-type islot) ,type))))
+ `(and ,(dsd-type slot) ,type))))
- (setf (dsd-read-only islot) t)
- (when (dsd-read-only islot)
+ (setf (dsd-read-only slot) t)
+ (when (dsd-read-only slot)
(error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
name
(error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
name
- (dsd-name islot)))))
- islot))
+ (dsd-name slot)))))
+ slot))
;;; When a value of type TYPE is stored in a structure, should it be
;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
;;; When a value of type TYPE is stored in a structure, should it be
;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
(setf (dd-raw-index defstruct) (dd-raw-index included-structure))
(setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
(setf (dd-raw-index defstruct) (dd-raw-index included-structure))
(setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
- (dolist (islot (dd-slots included-structure))
- (let* ((iname (dsd-name islot))
- (modified (or (find iname modified-slots
+ (dolist (included-slot (dd-slots included-structure))
+ (let* ((included-name (dsd-name included-slot))
+ (modified (or (find included-name modified-slots
:key #'(lambda (x) (if (atom x) x (car x)))
:test #'string=)
:key #'(lambda (x) (if (atom x) x (car x)))
:test #'string=)
- `(,iname))))
- (parse-1-dsd defstruct modified (copy-structure islot)))))))
+ `(,included-name))))
+ (parse-1-dsd defstruct
+ modified
+ (copy-structure included-slot)))))))
\f
;;; This function is called at macroexpand time to compute the INHERITS
;;; vector for a structure type definition.
\f
;;; This function is called at macroexpand time to compute the INHERITS
;;; vector for a structure type definition.
(let ((old-info (layout-info old-layout)))
(when (defstruct-description-p old-info)
(dolist (slot (dd-slots old-info))
(let ((old-info (layout-info old-layout)))
(when (defstruct-description-p old-info)
(dolist (slot (dd-slots old-info))
- (fmakunbound (dsd-accessor slot))
+ (fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(unless (dsd-read-only slot)
- (fmakunbound `(setf ,(dsd-accessor slot)))))))
+ (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
(%redefine-defstruct class old-layout layout)
(setq layout (class-layout class))))
(%redefine-defstruct class old-layout layout)
(setq layout (class-layout class))))
(dolist (slot (dd-slots info))
(let ((dsd slot))
(dolist (slot (dd-slots info))
(let ((dsd slot))
- (when (and (dsd-accessor slot)
+ (when (and (dsd-accessor-name slot)
(eq (dsd-raw-type slot) t))
(eq (dsd-raw-type slot) t))
- (protect-cl (dsd-accessor slot))
- (setf (symbol-function (dsd-accessor slot))
+ (protect-cl (dsd-accessor-name slot))
+ (setf (symbol-function (dsd-accessor-name slot))
(structure-slot-getter layout dsd))
(unless (dsd-read-only slot)
(structure-slot-getter layout dsd))
(unless (dsd-read-only slot)
- (setf (fdefinition `(setf ,(dsd-accessor slot)))
+ (setf (fdefinition `(setf ,(dsd-accessor-name slot)))
(structure-slot-setter layout dsd))))))
;; FIXME: See comment on corresponding code in %%COMPILER-DEFSTRUCT.
(structure-slot-setter layout dsd))))))
;; FIXME: See comment on corresponding code in %%COMPILER-DEFSTRUCT.
;; GENESIS understands DEFUN but doesn't understand a
;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.)
#|
;; GENESIS understands DEFUN but doesn't understand a
;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.)
#|
- (let ((pred (dd-predicate info)))
- (when pred
- (proclaim-as-defstruct-function-name pred)
+ (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 :inlinep pred) :inline)
- (setf (info :function :inline-expansion pred)
+ (setf (info :function :inline-expansion predicate-name)
`(lambda (x) (typep x ',name)))))
|#
(dolist (slot (dd-slots info))
`(lambda (x) (typep x ',name)))))
|#
(dolist (slot (dd-slots info))
- (let* ((fun (dsd-accessor slot))
+ (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-fun `(setf ,fun)))
(when (and fun (eq (dsd-raw-type slot) t))
(proclaim-as-defstruct-function-name fun)
(let ((type (dd-name info)))
(setf (info :type :compiler-layout type) nil)
(undefine-function-name (dd-copier info))
(let ((type (dd-name info)))
(setf (info :type :compiler-layout type) nil)
(undefine-function-name (dd-copier info))
- (undefine-function-name (dd-predicate info))
+ (undefine-function-name (dd-predicate-name info))
(dolist (slot (dd-slots info))
(dolist (slot (dd-slots info))
- (let ((fun (dsd-accessor slot)))
+ (let ((fun (dsd-accessor-name slot)))
(undefine-function-name fun)
(unless (dsd-read-only slot)
(undefine-function-name `(setf ,fun))))))
(undefine-function-name fun)
(unless (dsd-read-only slot)
(undefine-function-name `(setf ,fun))))))
-;;; Like PROCLAIM-AS-FUNCTION-NAME, but we also set the kind to
+;;; This is like PROCLAIM-AS-FUNCTION-NAME, but we also set the kind to
;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a
;;; slot accessor currently, quietly unaccessorize it. And if there
;;; are any undefined warnings, we nuke them.
;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a
;;; slot accessor currently, quietly unaccessorize it. And if there
;;; are any undefined warnings, we nuke them.
(call-next-method)
(when (and (legal-function-name-p x)
(fboundp x))
(call-next-method)
(when (and (legal-function-name-p x)
(fboundp x))
- (format s "Its FDEFINITION is ~S.~@:_" (fdefinition x))
+ (%describe-function (fdefinition x) s :function x)
+ ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x))
;; TO DO: should check for SETF documentation.
;; TO DO: should make it clear whether the definition is a
;; DEFUN (SETF FOO) or DEFSETF FOO or what.
;; TO DO: should check for SETF documentation.
;; TO DO: should make it clear whether the definition is a
;; DEFUN (SETF FOO) or DEFSETF FOO or what.
;; INSTANCE. This has to be handled early because the design of the
;; DEFSTRUCT system, dating back to pre-1999 CMU CL, requires that
;; STRUCTURE-OBJECT be the first DEFSTRUCT executed.
;; INSTANCE. This has to be handled early because the design of the
;; DEFSTRUCT system, dating back to pre-1999 CMU CL, requires that
;; STRUCTURE-OBJECT be the first DEFSTRUCT executed.
- ((structure-object (:alternate-metaclass sb!kernel:instance)
- (:copier nil))
+ ;;
+ ;; (The #|DEF|# here is to help find this definition with lexical search.)
+ (#|def|# (structure-object (:alternate-metaclass sb!kernel:instance)
+ (:copier nil))
;; (There are no slots.)
)
;; (There are no slots.)
)
;; somewhere before this definition, to define SB!ALIEN:ALIEN-TYPE? That
;; way, any tests for SB!ALIEN:ALIEN-TYPE in the slot accessor functions
;; could be implemented more efficiently.
;; somewhere before this definition, to define SB!ALIEN:ALIEN-TYPE? That
;; way, any tests for SB!ALIEN:ALIEN-TYPE in the slot accessor functions
;; could be implemented more efficiently.
- ((sb!alien-internals:alien-value)
+ ;;
+ ;; (The #|DEF|# here is to help find this definition with lexical search.)
+ (#|def|# (sb!alien-internals:alien-value)
(sap (required-argument) :type sb!sys:system-area-pointer)
(type (required-argument) :type sb!alien::alien-type)))
(sap (required-argument) :type sb!sys:system-area-pointer)
(type (required-argument) :type sb!alien::alien-type)))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (dd-slots info) (nreverse parts-list))
(push (cons (dsd-%name dd-slot)
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (dd-slots info) (nreverse parts-list))
(push (cons (dsd-%name dd-slot)
- (funcall (dsd-accessor dd-slot) object))
+ (funcall (dsd-accessor-name dd-slot) object))
parts-list)))))
(defmethod inspected-parts ((object structure-object))
parts-list)))))
(defmethod inspected-parts ((object structure-object))
#!+sb-doc
"DECLAIM Declaration*
Do a declaration or declarations for the global environment."
#!+sb-doc
"DECLAIM Declaration*
Do a declaration or declarations for the global environment."
`(eval-when (:compile-toplevel :load-toplevel :execute)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(mapcar #'(lambda (x)
- `(sb!xc:proclaim ',x))
- specs))
- ;; KLUDGE: The definition above doesn't work in the cross-compiler,
- ;; because UNCROSS translates SB!XC:PROCLAIM into CL:PROCLAIM before
- ;; the form gets executed. Instead, we have to explicitly do the
- ;; proclamation at macroexpansion time. -- WHN ca. 19990810
- ;;
- ;; FIXME: Maybe we don't need this special treatment any more now
- ;; that we're using DEFMACRO-MUNDANELY instead of DEFMACRO?
- #+sb-xc-host (progn
- (mapcar #'sb!xc:proclaim specs)
- `(progn
- ,@(mapcar #'(lambda (x)
- `(sb!xc:proclaim ',x))
- specs))))
+ ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec))
+ specs)))
(defmacro-mundanely print-unreadable-object ((object stream &key type identity)
&body body)
(defmacro-mundanely print-unreadable-object ((object stream &key type identity)
&body body)
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
(pprint-newline :miser stream)
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
(pprint-newline :miser stream)
- (output-object (funcall (fdefinition (dsd-accessor slot))
- structure)
- stream)
+ (output-object
+ (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream)
(when (null slots)
(return))
(write-char #\space stream)
(when (null slots)
(return))
(write-char #\space stream)
(let ((slot (first slots)))
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
(let ((slot (first slots)))
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
- (output-object (funcall (fdefinition (dsd-accessor slot))
- structure)
- stream))))))))
+ (output-object
+ (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream))))))))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))
:format-control
"Structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"Structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
- (list (dsd-accessor dsd)
+ (list (dsd-accessor-name dsd)
(sb!xc:class-name (layout-class layout))
structure))))
(%instance-ref structure (dsd-index dsd)))
(sb!xc:class-name (layout-class layout))
structure))))
(%instance-ref structure (dsd-index dsd)))
:format-control
"The structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"The structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
- (list (dsd-accessor dsd) class
+ (list (dsd-accessor-name dsd) class
structure)))
(%instance-ref structure (dsd-index dsd))))))
(defun structure-slot-setter (layout dsd)
structure)))
(%instance-ref structure (dsd-index dsd))))))
(defun structure-slot-setter (layout dsd)
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(sb!xc:class-name (layout-class layout))
structure)))
(unless (typep-test new-value)
(sb!xc:class-name (layout-class layout))
structure)))
(unless (typep-test new-value)
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value))
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(sb!xc:class-name class)
structure)))
(unless (typep-test new-value)
(sb!xc:class-name class)
structure)))
(unless (typep-test new-value)
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value)))))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value)))))
-;;; Check the legality of a function name that is being introduced.
-;;; -- If it names a macro, then give a warning and blast the macro
-;;; information.
-;;; -- If it is a structure slot accessor, give a warning and blast
-;;; the structure.
-;;; -- Check for conflicting setf macros.
+;;; 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)
(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
(defun proclaim-as-function-name (name)
(check-function-name name)
(:function
(let ((accessor-for (info :function :accessor-for name)))
(when accessor-for
(:function
(let ((accessor-for (info :function :accessor-for name)))
(when accessor-for
- (compiler-warning
- "Undefining structure type:~% ~S~@
- so that this slot accessor can be redefined:~% ~S"
- (sb!xc:class-name accessor-for) name)
- ;; FIXME: This is such weird, unfriendly behavior.. (What if
- ;; the user didn't want his structure blasted?) It probably
- ;; violates ANSI, too. (Check this.) Perhaps instead of
- ;; undefining the structure, we should attach the lost
- ;; accessor function to SB-EXT:LOST-STRUCTURE-ACCESSORS on
- ;; the property list of the symbol which names the structure?
- (undefine-structure accessor-for)
- (setf (info :function :kind name) :function))))
+ (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))))
- (compiler-style-warning "~S previously defined as a macro." name)
- (setf (info :function :kind name) :function)
+ (compiler-style-warning "~S was previously defined as a macro." name)
(setf (info :function :where-from name) :assumed)
(clear-info :function :macro-function name))
(setf (info :function :where-from name) :assumed)
(clear-info :function :macro-function name))
- ((nil)
- (setf (info :function :kind name) :function)))
+ ((nil)))
+ (setf (info :function :kind name) :function)
(note-if-setf-function-and-macro name)
name)
(note-if-setf-function-and-macro name)
name)
-;;; Make NAME no longer be a function name: clear everything back to the
-;;; default.
+;;; Make NAME no longer be a function name: clear everything back to
+;;; the default.
(defun undefine-function-name (name)
(when name
(macrolet ((frob (type &optional val)
(defun undefine-function-name (name)
(when name
(macrolet ((frob (type &optional val)
(frob :assumed-type)))
(values))
(frob :assumed-type)))
(values))
-;;; part of what happens with DEFUN, also with some PCL stuff:
-;;; Make NAME known to be a function definition.
+;;; part of what happens with DEFUN, also with some PCL stuff: Make
+;;; NAME known to be a function definition.
(defun become-defined-function-name (name)
(proclaim-as-function-name name)
(when (eq (info :function :where-from name) :assumed)
(defun become-defined-function-name (name)
(proclaim-as-function-name name)
(when (eq (info :function :where-from name) :assumed)
;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
;; They eval to themselves..
;;
;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
;; They eval to themselves..
;;
- ;; KLUDGE: Someday it might be nice to make the code recognize foldable
+ ;; FIXME: Someday it would be nice to make the code recognize foldable
;; functions and call itself recursively on their arguments, so that
;; more of the examples in the ANSI CL definition are recognized.
;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
;; functions and call itself recursively on their arguments, so that
;; more of the examples in the ANSI CL definition are recognized.
;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
(let* ((info (layout-info
(or (info :type :compiler-layout (sb!xc:class-name class))
(class-layout class))))
(let* ((info (layout-info
(or (info :type :compiler-layout (sb!xc:class-name class))
(class-layout class))))
- (accessor (if (listp name) (cadr name) name))
- (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
+ (accessor-name (if (listp name) (cadr name) name))
+ (slot (find accessor-name (dd-slots info)
+ :key #'sb!kernel:dsd-accessor-name))
(type (dd-name info))
(slot-type (dsd-type slot)))
(unless slot
(type (dd-name info))
(slot-type (dsd-type slot)))
(unless slot
(let* ((info (eval info)))
(%%compiler-defstruct info)
(dolist (slot (dd-slots info))
(let* ((info (eval info)))
(%%compiler-defstruct info)
(dolist (slot (dd-slots info))
- (let ((fun (dsd-accessor slot)))
- (remhash fun *free-functions*)
+ (let ((accessor-name (dsd-accessor-name slot)))
+ (remhash accessor-name *free-functions*)
(unless (dsd-read-only slot)
(unless (dsd-read-only slot)
- (remhash `(setf ,fun) *free-functions*))))
- (remhash (dd-predicate info) *free-functions*)
+ (remhash `(setf ,accessor-name) *free-functions*))))
+ (remhash (dd-predicate-name info) *free-functions*)
(remhash (dd-copier info) *free-functions*)
(ir1-convert start cont `(%%compiler-defstruct ',info))))
(remhash (dd-copier info) *free-functions*)
(ir1-convert start cont `(%%compiler-defstruct ',info))))
(setq *policy* (process-optimize-decl form *policy*)))
((inline notinline maybe-inline)
(dolist (name args)
(setq *policy* (process-optimize-decl form *policy*)))
((inline notinline maybe-inline)
(dolist (name args)
- (proclaim-as-function-name name)
+ ;; (CMU CL did (PROCLAIM-AS-FUNCTION-NAME NAME) here, but that
+ ;; seems more likely to surprise the user than to help him, so
+ ;; we don't do it.)
(setf (info :function :inlinep name)
(setf (info :function :inlinep name)
(inline :inline)
(notinline :notinline)
(maybe-inline :maybe-inline)))))
(inline :inline)
(notinline :notinline)
(maybe-inline :maybe-inline)))))
(sb-kernel:dsd-name slotd))
(defun structure-slotd-accessor-symbol (slotd)
(sb-kernel:dsd-name slotd))
(defun structure-slotd-accessor-symbol (slotd)
- (sb-kernel:dsd-accessor slotd))
+ (sb-kernel:dsd-accessor-name slotd))
(defun structure-slotd-reader-function (slotd)
(defun structure-slotd-reader-function (slotd)
- (fdefinition (sb-kernel:dsd-accessor slotd)))
+ (fdefinition (sb-kernel:dsd-accessor-name slotd)))
(defun structure-slotd-writer-function (slotd)
(unless (sb-kernel:dsd-read-only slotd)
(defun structure-slotd-writer-function (slotd)
(unless (sb-kernel:dsd-read-only slotd)
- (fdefinition `(setf ,(sb-kernel:dsd-accessor slotd)))))
+ (fdefinition `(setf ,(sb-kernel:dsd-accessor-name slotd)))))
(defun structure-slotd-type (slotd)
(sb-kernel:dsd-type slotd))
(defun structure-slotd-type (slotd)
(sb-kernel:dsd-type slotd))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)