(dolist (dsd (dd-slots dd))
(let* ((accessor-name (dsd-accessor-name dsd)))
(when accessor-name
-
- ;; new implementation sbcl-0.pre7.64
(multiple-value-bind (reader-designator writer-designator)
(accessor-inline-expansion-designators dd dsd)
+ (proclaim-as-defstruct-fun-name accessor-name)
(setf (info :function
:inline-expansion-designator
accessor-name)
(info :function :inlinep accessor-name)
:inline)
(unless (dsd-read-only dsd)
+ (proclaim-as-defstruct-fun-name `(setf ,accessor-name))
(let ((setf-accessor-name `(setf ,accessor-name)))
(setf (info :function
:inline-expansion-designator
setf-accessor-name)
writer-designator
(info :function :inlinep setf-accessor-name)
- :inline))))
-
- ;; old code from before sbcl-0.pre7.64, will hopefully
- ;; fade away and/or merge into new code above
- (when (eq (dsd-raw-type dsd) t) ; when not raw slot
- (proclaim-as-defstruct-fun-name accessor-name)
- (setf (info :function :accessor-for accessor-name) class)
- (unless (dsd-read-only dsd)
- (proclaim-as-defstruct-fun-name `(setf ,accessor-name))
- (setf (info :function :accessor-for `(setf ,accessor-name))
- class))))))
+ :inline)))))))
;; FIXME: Couldn't this logic be merged into
;; PROCLAIM-AS-DEFSTRUCT-FUN-NAME?
;;; are any undefined warnings, we nuke them.
(defun proclaim-as-defstruct-fun-name (name)
(when name
- (when (info :function :accessor-for name)
- (setf (info :function :accessor-for name) nil))
(proclaim-as-fun-name name)
(note-name-defined name :function)
(setf (info :function :where-from name) :declared)
((not (fboundp `(setf ,name)))
;; All is well, we don't need any warnings.
(values))
- ((info :function :accessor-for name)
- (warn "defining SETF macro for DEFSTRUCT slot ~
- accessor; redefining as a normal function: ~S"
- name)
- (proclaim-as-fun-name name))
((not (eq (symbol-package name) (symbol-package 'aref)))
(style-warn "defining setf macro for ~S when ~S is fbound"
name `(setf ,name))))
(setf undefs (sort undefs #'string< :key #'fun-name-block-name))
(dolist (name undefs)
- (format t "~S" name)
- ;; FIXME: This ACCESSOR-FOR stuff should go away when the
- ;; code has stabilized. (It's only here to help me
- ;; categorize the flood of undefined functions caused by
- ;; completely rewriting the bootstrap process. Hopefully any
- ;; future maintainers will mostly have small numbers of
- ;; undefined functions..)
- (let ((accessor-for (info :function :accessor-for name)))
- (when accessor-for
- (format t " (accessor for ~S)" accessor-for)))
- (format t "~%")))
+ (format t "~S~%" name)))
(format t "~%~|~%layout names:~2%")
(collect ((stuff))
:type :ir1-transform
:type-spec (or function null))
-;;; If a function is a slot accessor or setter, then this is the class
-;;; that it accesses slots of.
-(define-info-type
- :class :function
- :type :accessor-for
- :type-spec (or sb!xc:class null)
- :default nil)
-
;;; If a function is "known" to the compiler, then this is a
;;; FUNCTION-INFO structure containing the info used to special-case
;;; compilation.
(check-fun-name name)
(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
+ (:function) ; happy case
+ ((nil)) ; another happy case
+ (:macro ; maybe-not-so-good case
(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))))
+ (clear-info :function :macro-function name))))
(setf (info :function :kind name) :function)
(note-if-setf-function-and-macro name)
name)
(frob :where-from :assumed)
(frob :inlinep)
(frob :kind)
- (frob :accessor-for)
(frob :inline-expansion-designator)
(frob :source-transform)
(frob :assumed-type)))
:inlinep inlinep
:where-from (info :function :where-from name)
:type (info :function :type name))
- (let ((info (info :function :accessor-for name)))
- (when info
- (error "no expansion for ~S even though :ACCESSOR-FOR"
- name))
- (etypecase info
- (null
- (find-free-really-function name))
- (sb!xc:structure-class
- (find-structure-slot-accessor info name))
- (sb!xc:class
- (if (typep (layout-info (info :type :compiler-layout
- (sb!xc:class-name
- info)))
- 'defstruct-description)
- (find-structure-slot-accessor info name)
- (find-free-really-function name))))))))))))
+ (find-free-really-function name))))))))
;;; Return the LEAF structure for the lexically apparent function
;;; definition of NAME.
;; definition yet, we know one is planned. (But if this
;; function name was already declared as a structure
;; accessor, then that was already been taken care of.)
- (unless (info :function :accessor-for name)
- (proclaim-as-fun-name name)
- (note-name-defined name :function))
+ (proclaim-as-fun-name name)
+ (note-name-defined name :function)
;; the actual type declaration
(setf (info :function :type name) type
;; though, and I haven't figured out what does work
;; right. For now we just punt.
(values))
- #+nil
- ((sb-int:info :function :accessor-for ext-sym)
- (values))
((typep fun 'generic-function)
(sb-pcl::generic-function-pretty-arglist fun))
(t
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.65"
+"0.pre7.66"
projects / sbcl.git / commitdiff