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
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.
+* 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.
: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
"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"
- "%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"
(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)
type))
type))
type))))
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)))
(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
;; 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 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.)
- (accessor nil)
+ (accessor-name nil)
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))
- (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
(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
- (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)
- (res `(declaim (inline (setf ,accname))))
+ (res `(declaim (inline (setf ,accessor-name))))
(res `(declaim (ftype (function (,stype ,name) ,stype)
- (setf ,accname))))
+ (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.
- (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)
- (let ((pred (dd-predicate dd))
+ (let ((pred (dd-predicate-name dd))
(argname (gensym)))
(when pred
(if (eq (dd-type dd) 'funcallable-structure)
;;; DEFSTRUCT.
(defun typed-predicate-definitions (defstruct)
(let ((name (dd-name defstruct))
- (pred (dd-predicate defstruct))
+ (predicate-name (dd-predicate-name defstruct))
(argname (gensym)))
- (when (and pred (dd-named defstruct))
+ (when (and predicate-name (dd-named 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)))))
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"))
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)))
result))
) ; EVAL-WHEN
;;;; 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
- (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)
(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))
- (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
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)))
(when default-p
- (setf (dsd-default islot) default))
+ (setf (dsd-default slot) default))
(when type-p
- (setf (dsd-type islot)
- (if (eq (dsd-type islot) t)
+ (setf (dsd-type slot)
+ (if (eq (dsd-type slot) t)
type
- `(and ,(dsd-type islot) ,type))))
+ `(and ,(dsd-type slot) ,type))))
(when ro-p
(if read-only
- (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
- (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
(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=)
- `(,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.
(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)
- (fmakunbound `(setf ,(dsd-accessor slot)))))))
+ (fmakunbound `(setf ,(dsd-accessor-name slot)))))))
(%redefine-defstruct class old-layout layout)
(setq layout (class-layout class))))
(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))
- (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)
- (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.
;; 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 :inline-expansion pred)
+ (setf (info :function :inline-expansion predicate-name)
`(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)
(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))
- (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))))))
\f
;;;; compiler stuff
-;;; 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.
(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.
;; 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.)
)
;; 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)))
(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))
#!+sb-doc
"DECLAIM Declaration*
Do a declaration or declarations for the global environment."
- #-sb-xc-host
`(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)
(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)
(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*))
: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)))
: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)
: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)
: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))
: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)
: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)))))
(in-package "SB!C")
\f
-;;; 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)
(: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))))
(:macro
- (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))
- ((nil)
- (setf (info :function :kind name) :function)))
+ ((nil)))
+ (setf (info :function :kind name) :function)
(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)
(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)
;; 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)))
(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
(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)
- (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))))
(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)
- (case kind
+ (ecase kind
(inline :inline)
(notinline :notinline)
(maybe-inline :maybe-inline)))))
(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)
- (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)
- (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))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.34"
+"0.pre7.35"
projects / sbcl.git / commitdiff