0.6.10.15:
authorWilliam Harold Newman <william.newman@airmail.net>
Sun, 11 Feb 2001 23:11:36 +0000 (23:11 +0000)
committerWilliam Harold Newman <william.newman@airmail.net>
Sun, 11 Feb 2001 23:11:36 +0000 (23:11 +0000)
MNA patches from sbcl-devel e-mail 2001-02-10: Make %DEFUN
update INFO better, and (originally due to Paolo
Amoroso on cmucl-imp) clean up debugger restarts.
also degraded FTYPE mismatch to a STYLE-WARNING instead of
a full WARNING

src/code/debug.lisp
src/code/defboot.lisp
src/compiler/ctype.lisp
src/compiler/ir1final.lisp
src/compiler/ir1opt.lisp
src/compiler/ir1tran.lisp
src/compiler/locall.lisp
tests/info.impure.lisp [new file with mode: 0644]
version.lisp-expr

index 26caa7b..5005b32 100644 (file)
@@ -1078,20 +1078,20 @@ argument")
 ;;;
 ;;; Two commands are made for each restart: one for the number, and
 ;;; one for the restart name (unless it's been shadowed by an earlier
-;;; restart of the same name).
+;;; restart of the same name, or it is NIL).
 (defun make-restart-commands (&optional (restarts *debug-restarts*))
   (let ((commands)
        (num 0))                        ; better be the same as show-restarts!
     (dolist (restart restarts)
       (let ((name (string (restart-name restart))))
-       (unless (find name commands :key #'car :test #'string=)
-         (let ((restart-fun
-                #'(lambda ()
-                    (invoke-restart-interactively restart))))
-           (push (cons name restart-fun) commands)
-           (push (cons (format nil "~D" num) restart-fun) commands))))
-      (incf num))
-    commands))
+        (let ((restart-fun
+                #'(lambda () (invoke-restart-interactively restart))))
+          (push (cons (format nil "~d" num) restart-fun) commands)
+          (unless (or (null (restart-name restart)) 
+                      (find name commands :key #'car :test #'string=))
+            (push (cons name restart-fun) commands))))
+    (incf num))
+  commands))
 \f
 ;;;; frame-changing commands
 
@@ -1592,7 +1592,7 @@ argument")
     (if function
        (describe function)
        (format t "can't figure out the function for this frame"))))
-\f
+\f<
 ;;;; debug loop command utilities
 
 (defun read-prompting-maybe (prompt &optional (in *standard-input*)
index 00ca92d..69c3e9a 100644 (file)
 (defun sb!c::%defun (name def doc source)
   (declare (ignore source))
   (setf (sb!eval:interpreted-function-name def) name)
+  (ecase (info :function :where-from name)
+    (:assumed
+      (setf (info :function :where-from name) :defined)
+      (setf (info :function :type name)
+              (extract-function-type def))
+      (when (info :function :assumed-type name)
+        (setf (info :function :assumed-type name) nil)))
+    (:declared)
+    (:defined
+        (setf (info :function :type name) (extract-function-type def))))
   (sb!c::%%defun name def doc))
 \f
 ;;;; DEFVAR and DEFPARAMETER
index b9bd2c4..f094849 100644 (file)
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
+;;;; FIXME: This is a poor name for this file, since CTYPE is the name
+;;;; of the type used internally to represent Lisp types. It'd
+;;;; probably be good to rename this file to "call-type.lisp" or
+;;;; "ir1-type.lisp" or something.
+
 (in-package "SB!C")
 
 ;;; These are the functions that are to be called when a problem is
 ;;; anything. The error function is called when something is
 ;;; definitely incorrect. The warning function is called when it is
 ;;; somehow impossible to tell whether the call is correct.
+;;;
+;;; FIXME: *ERROR-FUNCTION* and *WARNING-FUNCTION* are now misnomers.
+;;; As per the KLUDGE note below, what the Python compiler
+;;; considered a "definite incompatibility" could easily be conforming
+;;; ANSI Common Lisp (if the incompatibility is across a compilation
+;;; unit boundary, and we don't keep track of whether it is..), so we
+;;; have to just report STYLE-WARNINGs instead of ERRORs or full
+;;; WARNINGs; and unlike CMU CL, we don't use the condition system
+;;; at all when we're reporting notes.
 (defvar *error-function*)
 (defvar *warning-function*)
 
 (declaim (type (or function null) *error-function* *warning-function
               *test-function*))
 
-;;; *LOSSAGE-DETECTED* is set when a definite incompatibility is
+;;; *LOSSAGE-DETECTED* is set when a "definite incompatibility" is
 ;;; detected. *SLIME-DETECTED* is set when we can't tell whether the
 ;;; call is compatible or not.
+;;;
+;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not.
+;;; As far as I can see, none of the "definite incompatibilities"
+;;; detected in this file are actually definite under the ANSI spec.
+;;; They would be incompatibilites if the use were within the same
+;;; compilation unit as the contradictory definition (as per the spec
+;;; section "3.2.2.3 Semantic Constraints") but the old Python code
+;;; doesn't keep track of whether that's the case. So until/unless we
+;;; upgrade the code to keep track of that, we have to handle all
+;;; these as STYLE-WARNINGs. -- WHN 2001-02-10
 (defvar *lossage-detected*)
 (defvar *slime-detected*)
-;;; FIXME: SLIME is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
+;;; FIXME: "SLIME" is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
 ;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic.
 
 ;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*.
@@ -59,7 +83,7 @@
 ;;;; function type inference and declarations.
 
 ;;; A dummy version of SUBTYPEP useful when we want a functional like
-;;; subtypep that always returns true.
+;;; SUBTYPEP that always returns true.
 (defun always-subtypep (type1 type2)
   (declare (ignore type1 type2))
   (values t t))
 ;;;    NIL, T: the call is definitely invalid.
 ;;;    NIL, NIL: unable to determine whether the call is valid.
 ;;;
-;;; The Argument-Test function is used to determine whether an
+;;; The ARGUMENT-TEST function is used to determine whether an
 ;;; argument type matches the type we are checking against. Similarly,
-;;; the Result-Test is used to determine whether the result type
+;;; the RESULT-TEST is used to determine whether the result type
 ;;; matches the specified result.
 ;;;
 ;;; Unlike the argument test, the result test may be called on values
-;;; or function types. If Strict-Result is true and safety is
-;;; non-zero, then the Node-Derived-Type is always used. Otherwise, if
-;;; Cont's Type-Check is true, then the Node-Derived-Type is
-;;; intersected with the Cont's Asserted-Type.
+;;; or function types. If STRICT-RESULT is true and SAFETY is
+;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
+;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
+;;; intersected with the CONT's ASSERTED-TYPE.
 ;;;
 ;;; The error and warning functions are functions that are called to
-;;; explain the result. We bind *compiler-error-context* to the
-;;; combination node so that Compiler-Warning and related functions
+;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
+;;; combination node so that COMPILER-WARNING and related functions
 ;;; will do the right thing if they are supplied.
 (defun valid-function-use (call type &key
                                ((:argument-test *test-function*) #'csubtypep)
          (*slime-detected* (values nil nil))
          (t (values t t)))))
 
-;;; Check that the derived type of the continuation Cont is compatible
-;;; with Type. N is the arg number, for error message purposes. We
+;;; Check that the derived type of the continuation CONT is compatible
+;;; with TYPE. N is the arg number, for error message purposes. We
 ;;; return true if arg is definitely o.k. If the type is a magic
 ;;; CONSTANT-TYPE, then we check for the argument being a constant
 ;;; value of the specified type. If there is a manifest type error
   ;; :allow-other-keys.
   (allowp nil :type (member t nil)))
 
-;;; Return an Approximate-Function-Type representing the context of
-;;; Call. If Type is supplied and not null, then we merge the
-;;; information into the information already accumulated in Type.
+;;; Return an APPROXIMATE-FUNCTION-TYPE representing the context of
+;;; CALL. If TYPE is supplied and not null, then we merge the
+;;; information into the information already accumulated in TYPE.
 (declaim (ftype (function (combination
                           &optional (or approximate-function-type null))
                          approximate-function-type)
                                :types (list val-type))))))))))))
     type))
 
-;;; Similar to Valid-Function-Use, but checks an
-;;; Approximate-Function-Type against a real function type.
+;;; This is similar to VALID-FUNCTION-USE, but checks an
+;;; APPROXIMATE-FUNCTION-TYPE against a real function type.
 (declaim (ftype (function (approximate-function-type function-type
                           &optional function function function)
                          (values boolean boolean))
                valid-approximate-type))
 (defun valid-approximate-type (call-type type &optional
                                         (*test-function* #'types-intersect)
-                                        (*error-function* #'compiler-warning)
+                                        (*error-function*
+                                         #'compiler-style-warning)
                                         (*warning-function* #'compiler-note))
   (let* ((*lossage-detected* nil)
         (*slime-detected* nil)
     (let ((call-min (approximate-function-type-min-args call-type)))
       (when (< call-min min-args)
        (note-lossage
-        "Function previously called with ~R argument~:P, but wants at least ~R."
+        "~:@<The function was previously called with ~R argument~:P, ~
+          but wants at least ~R.~:>"
         call-min min-args)))
 
     (let ((call-max (approximate-function-type-max-args call-type)))
       (cond ((<= call-max max-args))
            ((not (or keyp rest))
             (note-lossage
-             "Function previously called with ~R argument~:P, but wants at most ~R."
+             "~:@<The function was previously called with ~R argument~:P, ~
+                but wants at most ~R.~:>"
              call-max max-args))
            ((and keyp (oddp (- call-max max-args)))
             (note-lossage
-             "Function previously called with an odd number of arguments in ~
-             the keyword portion.")))
+             "~:@<The function was previously called with an odd number of ~
+               arguments in the keyword portion.~:>")))
 
       (when (and keyp (> call-max max-args))
        (check-approximate-keywords call-type max-args type)))
       (check-approximate-arg-type (car types) decl-type "~:R" n)))
   (values))
 
-;;; Check that each of the call-types is compatible with Decl-Type,
+;;; Check that each of the call-types is compatible with DECL-TYPE,
 ;;; complaining if not or if we can't tell.
 (declaim (ftype (function (list ctype string &rest t) (values))
                check-approximate-arg-type))
 ;;; argument position. Check the validity of all keys that appeared in
 ;;; valid keyword positions.
 ;;;
-;;; ### We could check the Approximate-Function-Type-Types to make
+;;; ### We could check the APPROXIMATE-FUNCTION-TYPE-TYPES to make
 ;;; sure that all arguments in keyword positions were manifest
 ;;; keywords.
 (defun check-approximate-keywords (call-type max-args type)
 \f
 ;;;; ASSERT-DEFINITION-TYPE
 
-;;; Intersect Lambda's var types with Types, giving a warning if there
+;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
 ;;; is a mismatch. If all intersections are non-null, we return lists
 ;;; of the variables and intersections, otherwise we return NIL, NIL.
 (defun try-type-intersections (vars types where)
                                   (when info
                                     (arg-info-keyword info)))))
            (note-lossage
-            "Definition lacks the ~S keyword present in ~A."
+            "The definition lacks the ~S keyword present in ~A."
             (key-info-name key) where))))
 
       (try-type-intersections (vars) (res) where))))
   (flet ((frob (x what)
           (when x
             (note-lossage
-             "Definition has no ~A, but the ~A did."
+             "The definition has no ~A, but the ~A did."
              what where))))
     (frob (function-type-optional type) "optional args")
     (frob (function-type-keyp type) "keyword args")
         (req (function-type-required type))
         (nreq (length req)))
     (unless (= nvars nreq)
-      (note-lossage "Definition has ~R arg~:P, but the ~A has ~R."
+      (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
                    nvars where nreq))
     (if *lossage-detected*
        (values nil nil)
        (try-type-intersections vars req where))))
 
 ;;; Check for syntactic and type conformance between the definition
-;;; Functional and the specified Function-Type. If they are compatible
-;;; and Really-Assert is T, then add type assertions to the definition
-;;; from the Function-Type.
+;;; FUNCTIONAL and the specified FUNCTION-TYPE. If they are compatible
+;;; and REALLY-ASSERT is T, then add type assertions to the definition
+;;; from the FUNCTION-TYPE.
 ;;;
 ;;; If there is a syntactic or type problem, then we call
-;;; Error-Function with an error message using Where as context
-;;; describing where Function-Type came from.
+;;; ERROR-FUNCTION with an error message using WHERE as context
+;;; describing where FUNCTION-TYPE came from.
 ;;;
-;;; If there is no problem, we return T (even if Really-Assert was
+;;; If there is no problem, we return T (even if REALLY-ASSERT was
 ;;; false). If there was a problem, we return NIL.
 (defun assert-definition-type
        (functional type &key (really-assert t)
-                  ((:error-function *error-function*) #'compiler-warning)
+                  ((:error-function *error-function*)
+                   #'compiler-style-warning)
                   warning-function
                   (where "previous declaration"))
   (declare (type functional functional)
index 98548ee..92548d9 100644 (file)
@@ -65,9 +65,7 @@
       (let* ((where (info :function :where-from name))
             (*compiler-error-context* (lambda-bind (main-entry leaf)))
             (global-def (gethash name *free-functions*))
-            (global-p
-             (and (defined-function-p global-def)
-                  (eq (defined-function-functional global-def) leaf))))
+            (global-p (defined-function-p global-def)))
        (note-name-defined name :function)
        (when global-p
          (remhash name *free-functions*))
@@ -81,8 +79,8 @@
           (setf (info :function :where-from name) :defined))
          (:declared); Just keep declared type.
          (:defined
-          (when global-p
-            (setf (info :function :type name) dtype)))))))
+           (when global-p
+             (setf (info :function :type name) dtype)))))))
   (values))
 
 ;;; Find all calls in Component to assumed functions and update the assumed
index 3c99417..9c853d1 100644 (file)
        ((valid-function-use call type
                             :argument-test #'always-subtypep
                             :result-test #'always-subtypep
-                            :error-function #'compiler-warning
+                            ;; KLUDGE: Common Lisp is such a dynamic
+                            ;; language that all we can do here in
+                            ;; general is issue a STYLE-WARNING. It
+                            ;; would be nice to issue a full WARNING
+                            ;; in the special case of of type
+                            ;; mismatches within a compilation unit
+                            ;; (as in section 3.2.2.3 of the spec)
+                            ;; but at least as of sbcl-0.6.11, we
+                            ;; don't keep track of whether the
+                            ;; mismatched data came from the same
+                            ;; compilation unit, so we can't do that.
+                            ;; -- WHN 2001-02-11
+                            ;;
+                            ;; FIXME: Actually, I think we could
+                            ;; issue a full WARNING if the call
+                            ;; violates a DECLAIM FTYPE.
+                            :error-function #'compiler-style-warning
                             :warning-function #'compiler-note)
         (assert-call-type call type)
         (maybe-terminate-block call ir1-p)
index 70d4cec..268afc5 100644 (file)
 
 ;;; Check a new global function definition for consistency with
 ;;; previous declaration or definition, and assert argument/result
-;;; types if appropriate. This this assertion is suppressed by the
+;;; types if appropriate. This assertion is suppressed by the
 ;;; EXPLICIT-CHECK attribute, which is specified on functions that
 ;;; check their argument types as a consequence of type dispatching.
 ;;; This avoids redundant checks such as NUMBERP on the args to +,
        (info (info :function :info (leaf-name var))))
     (assert-definition-type
      fun type
-     :error-function #'compiler-warning
-     :warning-function (cond (info #'compiler-warning)
+     ;; KLUDGE: Common Lisp is such a dynamic language that in general
+     ;; all we can do here in general is issue a STYLE-WARNING. It
+     ;; would be nice to issue a full WARNING in the special case of
+     ;; of type mismatches within a compilation unit (as in section
+     ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't
+     ;; keep track of whether the mismatched data came from the same
+     ;; compilation unit, so we can't do that. -- WHN 2001-02-11
+     ;;
+     ;; FIXME: Actually, I think we could issue a full WARNING if the
+     ;; new definition contradicts a DECLAIM FTYPE.
+     :error-function #'compiler-style-warning
+     :warning-function (cond (info #'compiler-style-warning)
                             (for-real #'compiler-note)
                             (t nil))
      :really-assert
index 14e699c..ed6f948 100644 (file)
           ;; but as long as we continue to use that policy, that's the
           ;; not our biggest problem.:-| When we fix that policy, this
           ;; should come back into compliance. (So fix that policy!)
+          ;;   ..but..
+          ;; FIXME, continued: Except that section "3.2.2.3 Semantic
+          ;; Constraints" says that if it's within the same file, it's
+          ;; wrong. And we're in locall.lisp here, so it's probably
+          ;; (haven't checked this..) a call to something in the same
+          ;; file. So maybe it deserves a full warning anyway.
           (compiler-warning
            "function called with ~R argument~:P, but wants exactly ~R"
            call-args nargs)
        (max-args (optional-dispatch-max-args fun))
        (call-args (length (combination-args call))))
     (cond ((< call-args min-args)
-          ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
-          ;; Compiler" that calling a function with "the wrong number of
-          ;; arguments" be only a STYLE-ERROR. I think, though, that this
-          ;; should only apply when the number of arguments is inferred
-          ;; from a previous definition. If the number of arguments
-          ;; is DECLAIMed, surely calling with the wrong number is a
-          ;; real WARNING. As long as SBCL continues to use CMU CL's
-          ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
-          ;; but as long as we continue to use that policy, that's the
-          ;; not our biggest problem.:-| When we fix that policy, this
-          ;; should come back into compliance. (So fix that policy!)
+          ;; FIXME: See FIXME note at the previous
+          ;; wrong-number-of-arguments warnings in this file.
           (compiler-warning
            "function called with ~R argument~:P, but wants at least ~R"
            call-args min-args)
          ((optional-dispatch-more-entry fun)
           (convert-more-call ref call fun))
          (t
-          ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
-          ;; Compiler" that calling a function with "the wrong number of
-          ;; arguments" be only a STYLE-ERROR. I think, though, that this
-          ;; should only apply when the number of arguments is inferred
-          ;; from a previous definition. If the number of arguments
-          ;; is DECLAIMed, surely calling with the wrong number is a
-          ;; real WARNING. As long as SBCL continues to use CMU CL's
-          ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
-          ;; but as long as we continue to use that policy, that's the
-          ;; not our biggest problem.:-| When we fix that policy, this
-          ;; should come back into compliance. (So fix that policy!)
+          ;; FIXME: See FIXME note at the previous
+          ;; wrong-number-of-arguments warnings in this file.
           (compiler-warning
            "function called with ~R argument~:P, but wants at most ~R"
            call-args max-args)
diff --git a/tests/info.impure.lisp b/tests/info.impure.lisp
new file mode 100644 (file)
index 0000000..8376d67
--- /dev/null
@@ -0,0 +1,48 @@
+;;;; tests of the INFO/globaldb system
+;;;;
+;;;; KLUDGE: Unlike most of the system's tests, these are not in the
+;;;; problem domain, but in the implementation domain, so modification
+;;;; of the system could cause these tests to fail even if the system
+;;;; was still a correct implementation of ANSI Common Lisp + SBCL
+;;;; extensions. Perhaps such tests should be separate from tests in
+;;;; the problem domain. -- WHN 2001-02-11
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+(defun foo (a) (list a))
+(let ((x 1)) (foo x))
+
+(assert (eq (sb-int:info :function :where-from 'foo)
+            :defined))
+
+(defun foo (a b) (list a b))
+(let ((x 1)) (foo x 2))
+
+(flet ((foo (a b c)
+         (list a b c)))
+  (foo 1 2 3))
+
+;;; FIXME: This one is commented out since it doesn't work when
+;;; the DEFUN is just LOADed instead of COMPILE-FILEd, and it's
+;;; not immediately obvious what's the best way to set up
+;;; the COMPILE-FILE test.
+#|
+(assert
+  (equal
+   (format nil "~A" (sb-int:info :function :type 'foo))
+   "#<FUNCTION-TYPE (FUNCTION (T T) LIST)>"))
+|#
+
+;;; success
+(quit :unix-status 104)
index 28fb7e2..2c75b03 100644 (file)
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.10.14"
+"0.6.10.15"