From: Brian Mastenbrook <bmastenb@cs.indiana.edu>
Date: Thu, 11 Aug 2005 01:07:44 +0000 (+0000)
Subject: 0.9.3.39: TYPE-ERROR fun
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=be2e8599a25b1a21fac40d963ec71820b74cf3f3;p=sbcl.git

0.9.3.39: TYPE-ERROR fun

* Fix an obvious FIXME involving the expected type in a type error
  thrown by MAP when the passed type specifier is not a subtype of
  LIST or VECTOR. The expected-type cell was previously SEQUENCE, and
  it's very likely that a type specifier is of that type :-)

* DISASSEMBLE should throw a TYPE-ERROR when the argument does not
  name a function, not a SIMPLE-ERROR.
---

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 5fe1f97..d4026d3 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -145,9 +145,7 @@
 (sb!xc:defmacro bad-sequence-type-error (type-spec)
   `(error 'simple-type-error
           :datum ,type-spec
-          ;; FIXME: This is actually wrong, and should be something
-          ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P).
-          :expected-type 'sequence
+          :expected-type '(satisfies is-a-valid-sequence-type-specifier-p)
           :format-control "~S is a bad type specifier for sequences."
           :format-arguments (list ,type-spec)))
 
@@ -173,14 +171,19 @@
   ;; ANSI.  Essentially, we are justified in throwing this on
   ;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI)
   ;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18
-  `(error 'simple-type-error
-          :datum ,type-spec
-          ;; FIXME: as in BAD-SEQUENCE-TYPE-ERROR, this is wrong.
-          :expected-type 'sequence
+
+  ;; On the other hand, I'm not sure it deserves to be a type-error,
+  ;; either. -- bem, 2005-08-10
+  `(error 'simple-program-error
           :format-control "~S is too hairy for sequence functions."
           :format-arguments (list ,type-spec)))
 ) ; EVAL-WHEN
 
+(defun is-a-valid-sequence-type-specifier-p (type)
+  (let ((type (specifier-type type)))
+    (or (csubtypep type (specifier-type 'list))
+        (csubtypep type (specifier-type 'vector)))))
+
 ;;; It's possible with some sequence operations to declare the length
 ;;; of a result vector, and to be safe, we really ought to verify that
 ;;; the actual result has the declared length.
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index da487e6..2500787 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -308,6 +308,28 @@
 ;;; is open if either X or Y is open.
 ;;;
 ;;; FIXME: only used in this file, not needed in target runtime
+
+;;; ANSI contaigon specifies coercion to floating point if one of the
+;;; arguments is floating point. Here we should check to be sure that
+;;; the other argument is within the bounds of that floating point
+;;; type.
+
+(defmacro safely-binop (op x y)
+  `(cond
+    ((typep ,x 'single-float)
+     (if (<= most-negative-single-float ,y most-positive-single-float)
+         (,op ,x ,y)))
+    ((typep ,x 'double-float)
+     (if (<= most-negative-double-float ,y most-positive-double-float)
+         (,op ,x ,y)))
+    ((typep ,y 'single-float)
+     (if (<= most-negative-single-float ,x most-positive-single-float)
+         (,op ,x ,y)))
+    ((typep ,y 'double-float)
+     (if (<= most-negative-double-float ,x most-positive-double-float)
+         (,op ,x ,y)))
+    (t (,op ,x ,y))))
+
 (defmacro bound-binop (op x y)
   `(and ,x ,y
        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 9bcfd33..24ad018 100644
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1495,7 +1495,7 @@
       (error "can't compile a lexical closure"))
     (compile nil lambda)))
 
-(defun compiled-fun-or-lose (thing &optional (name thing))
+(defun valid-extended-function-designator-for-disassemble-p (thing)
   (cond ((legal-fun-name-p thing)
          (compiled-fun-or-lose (fdefinition thing) thing))
         ((functionp thing)
@@ -1503,8 +1503,17 @@
         ((and (listp thing)
               (eq (car thing) 'lambda))
          (compile nil thing))
-        (t
-         (error "can't make a compiled function from ~S" name))))
+        (t nil)))
+
+(defun compiled-fun-or-lose (thing &optional (name thing))
+  (let ((fun (valid-extended-function-designator-for-disassemble-p thing)))
+    (if fun
+        fun
+        (error 'simple-type-error
+               :datum thing
+               :expected-type '(satisfies valid-extended-function-designator-for-disassemble-p)
+               :format-control "can't make a compiled function from ~S"
+               :format-arguments (list name)))))
 
 (defun disassemble (object &key
                            (stream *standard-output*)
diff --git a/version.lisp-expr b/version.lisp-expr
index 0661f99..96dcbfb 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.3.38"
+"0.9.3.39"