0.pre7.67:

	cleaned up miscellaneous FTYPE proclamation stuff..
	..I changed my mind: PROCLAIM-AS-FUN-NAME is appropriate
		in PROCLAIM INLINE and PROCLAIM NOTINLINE after all.
	..got rid of separate PROCLAIM-AS-DEFSTRUCT-FUN-NAME in
		favor of ordinary PROCLAIM FTYPE
	..moved remove-from-*FREE-FUNCTIONS* logic from
		%COMPILER-DEFSTRUCT to PROCLAIM-AS-FUN-NAME
	..PROCLAIM-AS-FUN-NAME doesn't need to return NAME. Nor
		CHECK-FUN-NAME neither.
	..When %COMPILER-DEFSTRUCT sets the inline expansions of
		slot functions, it should proclaim their ftype too.
	Now that %COMPILER-DEFSTRUCT wants SB!XC:PROCLAIM, I
		rearranged things to make SB!XC:PROCLAIM available
		sooner, moving src/compiler/proclaim, and the
		src/compiler/knownfun that it depends on, earlier
		in stems-and-flags

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 2404a83..00dd740 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -60,7 +60,7 @@
   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
   (constructors () :type list)
   ;; name of copying function
-  (copier (symbolicate "COPY-" name) :type (or symbol null))
+  (copier-name (symbolicate "COPY-" name) :type (or symbol null))
   ;; name of type predicate
   (predicate-name (symbolicate name "-P") :type (or symbol null))
   ;; the arguments to the :INCLUDE option, or NIL if no included
@@ -404,9 +404,9 @@
 
 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
 (defun typed-copier-definitions (defstruct)
-  (when (dd-copier defstruct)
-    `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
-      (declaim (ftype function ,(dd-copier defstruct))))))
+  (when (dd-copier-name defstruct)
+    `((setf (fdefinition ',(dd-copier-name defstruct)) #'copy-seq)
+      (declaim (ftype function ,(dd-copier-name defstruct))))))
 
 ;;; Return a list of function definitions for accessing and setting the
 ;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline,
@@ -461,7 +461,7 @@
       (:copier
        (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
           args
-        (setf (dd-copier dd) copier)))
+        (setf (dd-copier-name dd) copier)))
       (:predicate
        (destructuring-bind (&optional (predicate-name (symbolicate name "-P")))
           args
@@ -807,9 +807,9 @@
                  (typep-to-layout object layout))))
       |#
 
-      (when (dd-copier info)
-       (protect-cl (dd-copier info))
-       (setf (symbol-function (dd-copier info))
+      (when (dd-copier-name info)
+       (protect-cl (dd-copier-name info))
+       (setf (symbol-function (dd-copier-name info))
              #'(lambda (structure)
                  (declare (optimize (speed 3) (safety 0)))
                  (flet ((layout-test (structure)
@@ -911,51 +911,42 @@
 
     (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 (dsd (dd-slots dd))
-        (let* ((accessor-name (dsd-accessor-name dsd)))
-          (when accessor-name
-            (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)
-                    reader-designator
-                    (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)))))))
-
-       ;; FIXME: Couldn't this logic be merged into
-       ;; PROCLAIM-AS-DEFSTRUCT-FUN-NAME?
-       (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))))))
+  (let* ((dd-name (dd-name dd))
+        (class (sb!xc:find-class dd-name)))
+
+    (let ((copier-name (dd-copier-name dd)))
+      (when copier-name
+       (sb!xc:proclaim `(ftype (function (,dd-name) ,dd-name) ,copier-name))))
+
+    (let ((predicate-name (dd-predicate-name dd)))
+      (when predicate-name
+       (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))))
+
+    (dolist (dsd (dd-slots dd))
+      (let* ((accessor-name (dsd-accessor-name dsd))
+            (dsd-type (dsd-type dsd)))
+       (when accessor-name
+         (multiple-value-bind (reader-designator writer-designator)
+             (accessor-inline-expansion-designators dd dsd)
+           (sb!xc:proclaim `(ftype (function (,dd-name) ,dsd-type)
+                                   ,accessor-name))
+           (setf (info :function
+                       :inline-expansion-designator
+                       accessor-name)
+                 reader-designator
+                 (info :function :inlinep accessor-name)
+                 :inline)
+           (unless (dsd-read-only dsd)
+             (let ((setf-accessor-name `(setf ,accessor-name)))
+               (sb!xc:proclaim
+                `(ftype (function (,dsd-type ,dd-name) ,dsd-type)
+                        ,setf-accessor-name))
+               (setf (info :function
+                           :inline-expansion-designator
+                           setf-accessor-name)
+                     writer-designator
+                     (info :function :inlinep setf-accessor-name)
+                     :inline))))))))
 
   (values))
 \f
@@ -1104,7 +1095,7 @@
     (when (defstruct-description-p info)
       (let ((type (dd-name info)))
        (setf (info :type :compiler-layout type) nil)
-       (undefine-fun-name (dd-copier info))
+       (undefine-fun-name (dd-copier-name info))
        (undefine-fun-name (dd-predicate-name info))
        (dolist (slot (dd-slots info))
          (let ((fun (dsd-accessor-name slot)))
@@ -1407,21 +1398,6 @@
 
       (res))))
 \f
-;;;; compiler stuff
-
-;;; This is like PROCLAIM-AS-FUN-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.
-(defun proclaim-as-defstruct-fun-name (name)
-  (when name
-    (proclaim-as-fun-name name)
-    (note-name-defined name :function)
-    (setf (info :function :where-from name) :declared)
-    (when (info :function :assumed-type name)
-      (setf (info :function :assumed-type name) nil)))
-  (values))
-\f
 ;;;; finalizing bootstrapping
 
 ;;; early structure placeholder definitions: Set up layout and class

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index 64bba8d..b74f637 100644 (file)
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -33,12 +33,15 @@
        (compiler-error "Special form is an illegal function name: ~S" name)))
     (t
      (compiler-error "illegal function name: ~S" name)))
-  name)
+  (values))
 
 ;;; Record a new function definition, and check its legality.
-(declaim (ftype (function ((or symbol cons)) t) proclaim-as-fun-name))
 (defun proclaim-as-fun-name (name)
+
+  ;; legal name?
   (check-fun-name name)
+
+  ;; scrubbing old data I: possible collision with old definition
   (when (fboundp name)
     (ecase (info :function :kind name)
       (:function) ; happy case
@@ -47,9 +50,21 @@
        (compiler-style-warning "~S was previously defined as a macro." name)
        (setf (info :function :where-from name) :assumed)
        (clear-info :function :macro-function name))))
+
+  ;; scrubbing old data II: dangling forward references
+  ;;
+  ;; (This could happen if someone does PROCLAIM FTYPE in macroexpansion,
+  ;; which is bad style, or at compile time, e.g. in EVAL-WHEN (:COMPILE)
+  ;; inside something like DEFSTRUCT, in which case it's reasonable style.
+  ;; Either way, it's no longer a free function.)
+  (when (boundp '*free-functions*) ; when compiling
+    (remhash name *free-functions*))
+
+  ;; recording the ordinary case
   (setf (info :function :kind name) :function)
   (note-if-setf-function-and-macro name)
-  name)
+
+  (values))
 
 ;;; This is called to do something about SETF functions that overlap
 ;;; with SETF macros. Perhaps we should interact with the user to see

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 8cecb52..ae2acab 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -554,7 +554,8 @@
       (when (or (atom def) (< (length def) 2))
        (compiler-error "The ~S definition spec ~S is malformed." context def))
 
-      (let ((name (check-fun-name (first def))))
+      (let ((name (first def)))
+       (check-fun-name name)
        (names name)
        (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
          (defs `(lambda ,(second def)

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index c36d9e1..690fc9e 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -1828,8 +1828,8 @@
 ;;; define. If the function has been forward referenced, then
 ;;; substitute for the previous references.
 (defun get-defined-fun (name)
-  (let* ((name (proclaim-as-fun-name name))
-        (found (find-free-function name "shouldn't happen! (defined-fun)")))
+  (proclaim-as-fun-name name)
+  (let ((found (find-free-function name "shouldn't happen! (defined-fun)")))
     (note-name-defined name :function)
     (cond ((not (defined-fun-p found))
           (aver (not (info :function :inlinep name)))

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index faef555..f25b899 100644 (file)
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -151,9 +151,10 @@
 
             ;; Now references to this function shouldn't be warned
             ;; about as undefined, since even if we haven't seen a
-            ;; 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.)
+            ;; definition yet, we know one is planned. 
+            ;;
+            ;; Other consequences of we-know-you're-a-function-now
+            ;; are appropriate too, e.g. any MACRO-FUNCTION goes away.
             (proclaim-as-fun-name name)
             (note-name-defined name :function)
 
@@ -174,9 +175,7 @@
        (setq *policy* (process-optimize-decl form *policy*)))
       ((inline notinline maybe-inline)
        (dolist (name args)
-        ;; (CMU CL did (PROCLAIM-AS-FUN-NAME NAME) here, but that
-        ;; seems more likely to surprise the user than to help him, so
-        ;; we don't do it.)
+        (proclaim-as-fun-name name) ; since implicitly it is a function
         (setf (info :function :inlinep name)
               (ecase kind
                 (inline :inline)

diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr
index 20cd9ee..6abbd77 100644 (file)
--- a/stems-and-flags.lisp-expr
+++ b/stems-and-flags.lisp-expr
@@ -345,23 +345,26 @@
  ;; the target version of "code/defstruct".
  ("src/code/target-defstruct" :not-host)
 
+ ;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp
+ ("src/compiler/knownfun")
+
  ;; stuff needed by "code/defstruct"
  ("src/code/cross-type" :not-target)
  ("src/compiler/generic/vm-type")
+ ("src/compiler/proclaim")
 
  ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in 
  ;; "code/late-type", and SB!XC:TYPEP, defined in "code/cross-type",
- ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type".
+ ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type",
+ ;; and SB!XC:PROCLAIM, defined in "src/compiler/proclaim"
  ("src/code/defstruct")
 
  ;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT
  ;; machinery) before we can set its superclasses here.
  ("src/code/alien-type")
 
- ("src/compiler/knownfun")
-
- ;; needs IR1-ATTRIBUTES macro, defined in knownfun.lisp
- ("src/compiler/proclaim")
+ ;; was here until sbcl-0.pre7.67
+ #+nil ("src/compiler/knownfun")
 
  ;; This needs not just the SB!XC:DEFSTRUCT machinery, but also
  ;; the TYPE= stuff defined in late-type.lisp, and the

diff --git a/version.lisp-expr b/version.lisp-expr
index 534e6c6..217fa19 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre7.66"
+"0.pre7.67"