From: Alexey Dejneka <adejneka@comail.ru>
Date: Sat, 21 Sep 2002 05:43:20 +0000 (+0000)
Subject: 0.7.7.34:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dea9bd5c1afe23d9e061c60db654b88187ba9a5e;p=sbcl.git

0.7.7.34:
        Fix BUG 181
---

diff --git a/BUGS b/BUGS
index 25d6de4..ea797df 100644
--- a/BUGS
+++ b/BUGS
@@ -999,18 +999,6 @@ WORKAROUND:
     (defun bug178alternative (x)
       (funcall (the nil x)))
 
-181: "bad type specifier drops compiler into debugger"
-  Compiling 
-    (in-package :cl-user)
-    (defun bar (x)
-      (declare (type 0 x))
-      (cons x x))
-  signals 
-    bad thing to be a type specifier: 0
-  which seems fine, but also enters the debugger (instead of having
-  the compiler handle the error, convert it into a COMPILER-ERROR, and
-  continue compiling) which seems wrong.
-
 183: "IEEE floating point issues"
   Even where floating point handling is being dealt with relatively
   well (as of sbcl-0.7.5, on sparc/sunos and alpha; see bug #146), the
diff --git a/NEWS b/NEWS
index d05cd03..f8da51f 100644
--- a/NEWS
+++ b/NEWS
@@ -1275,6 +1275,8 @@ changes in sbcl-0.7.8 relative to sbcl-0.7.7:
   * The compiler's handling TYPE-ERRORs which it can prove will
     inevitably happen at runtime has been cleaned up and corrected
     in several ways. (thanks to Alexey Dejneka)
+  * fixed bug 181: compiler checks validity of user supplied type
+    specifiers
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe
diff --git a/install.sh b/install.sh
index 5cad78c..e58871d 100644
--- a/install.sh
+++ b/install.sh
@@ -2,6 +2,9 @@
 
 # Install SBCL files into the usual places.
 
+cp /usr/local/bin/sbcl /usr/local/bin/sbcl.old
+cp /usr/local/lib/sbcl.core /usr/local/lib/sbcl.core.old
+
 cp src/runtime/sbcl /usr/local/bin/
 cp output/sbcl.core /usr/local/lib/
 cp doc/sbcl.1 /usr/local/man/man1/
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 06685d9..b71f70d 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -126,23 +126,24 @@
   (let ((simple (and (unsupplied-or-nil adjustable)
 		     (unsupplied-or-nil displaced-to)
 		     (unsupplied-or-nil fill-pointer))))
-    (specifier-type
-     `(,(if simple 'simple-array 'array)
-       ,(cond ((not element-type) t)
-	      ((constant-continuation-p element-type)
-	       (continuation-value element-type))
-	      (t
-	       '*))
-       ,(cond ((not simple)
-	       '*)
-	      ((constant-continuation-p dims)
-	       (let ((val (continuation-value dims)))
-		 (if (listp val) val (list val))))
-	      ((csubtypep (continuation-type dims)
-			  (specifier-type 'integer))
-	       '(*))
-	      (t
-	       '*))))))
+    (or (careful-specifier-type
+         `(,(if simple 'simple-array 'array)
+            ,(cond ((not element-type) t)
+                   ((constant-continuation-p element-type)
+                    (continuation-value element-type))
+                   (t
+                    '*))
+            ,(cond ((not simple)
+                    '*)
+                   ((constant-continuation-p dims)
+                    (let ((val (continuation-value dims)))
+                      (if (listp val) val (list val))))
+                   ((csubtypep (continuation-type dims)
+                               (specifier-type 'integer))
+                    '(*))
+                   (t
+                    '*))))
+        (specifier-type 'array))))
 
 ;;; Complex array operations should assert that their array argument
 ;;; is complex.  In SBCL, vectors with fill-pointers are complex.
@@ -267,7 +268,7 @@
 			 "ELEMENT-TYPE is not constant."))
 		       (t
 			(continuation-value element-type))))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*))
@@ -279,7 +280,7 @@
 
     (unless saetp
       (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
-    
+
     (cond ((or (null initial-element)
 	       (and (constant-continuation-p initial-element)
 		    (eql (continuation-value initial-element)
@@ -307,7 +308,7 @@
 		 (%data-vector-and-index array 0)
 	       (fill vector initial-element))
 	     array)))))
-			 
+
 ;;; The integer type restriction on the length ensures that it will be
 ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
 ;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
@@ -325,7 +326,7 @@
 		  (continuation-value length)
 		  '*))
 	 (result-type-spec `(simple-array ,eltype (,len)))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*)))
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a3a4e1e..8c11111 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -720,7 +720,7 @@
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))
-  (let* ((ctype (if (typep type 'ctype) type (values-specifier-type type)))
+  (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
 	 (old-type (or (lexenv-find cont type-restrictions)
 		       *wild-type*))
 	 (intersects (values-types-equal-or-intersect old-type ctype))
@@ -747,7 +747,7 @@
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)
-  (with-continuation-type-assertion (cont (values-specifier-type type)
+  (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
                                           "in THE declaration")
     (ir1-convert start cont value)))
 
@@ -762,7 +762,7 @@
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc
   (declare (inline member))
-  (let ((type (values-specifier-type type))
+  (let ((type (compiler-values-specifier-type type))
 	(old (find-uses cont)))
     (ir1-convert start cont value)
     (do-uses (use cont)
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 8f392dc..456e025 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -896,7 +896,7 @@
 ;;; macro, we just wrap a THE around the expansion.
 (defun process-type-decl (decl res vars)
   (declare (list decl vars) (type lexenv res))
-  (let ((type (specifier-type (first decl))))
+  (let ((type (compiler-specifier-type (first decl))))
     (collect ((restr nil cons)
 	      (new-vars nil cons))
       (dolist (var-name (rest decl))
@@ -944,7 +944,7 @@
 ;;; functions.
 (defun process-ftype-decl (spec res names fvars)
   (declare (list spec names fvars) (type lexenv res))
-  (let ((type (specifier-type spec)))
+  (let ((type (compiler-specifier-type spec)))
     (collect ((res nil cons))
       (dolist (name names)
 	(let ((found (find name fvars
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 7dd4459..926e183 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1378,6 +1378,29 @@
 	  (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
 	  (return-from careful-call (values nil nil))))))
    t))
+
+;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
+;;; specifiers.
+(macrolet
+    ((deffrob (basic careful compiler transform)
+       `(progn
+          (defun ,careful (specifier)
+            (handler-case (,basic specifier)
+              (simple-error (condition)
+                (values nil (list* (simple-condition-format-control condition)
+                                   (simple-condition-format-arguments condition))))))
+          (defun ,compiler (specifier)
+            (multiple-value-bind (type error-args) (,careful specifier)
+              (or type
+                  (apply #'compiler-error error-args))))
+          (defun ,transform (specifier)
+            (multiple-value-bind (type error-args) (,careful specifier)
+              (or type
+                  (apply #'give-up-ir1-transform
+                         error-args)))))))
+  (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
+  (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
+
 
 ;;;; utilities used at run-time for parsing &KEY args in IR1
 
diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 2814fda..ea1ec4a 100644
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -253,6 +253,6 @@
     (declare (type combination call))
     (let ((cont (nth (1- n) (combination-args call))))
       (when (and cont (constant-continuation-p cont))
-	(specifier-type (continuation-value cont))))))
+	(careful-specifier-type (continuation-value cont))))))
 
 (/show0 "knownfun.lisp end of file")
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 08b8f3f..9792a4b 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -93,7 +93,7 @@
 		 `(sequence-of-checked-length-given-type ,bare
 							 result-type-arg))
 		(t
-		 (let ((result-ctype (specifier-type result-type)))
+		 (let ((result-ctype (ir1-transform-specifier-type result-type)))
 		   (if (array-type-p result-ctype)
 		       (let* ((dims (array-type-dimensions result-ctype))
 			      (dim (first dims)))
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index ce18d78..f41a060 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -81,7 +81,7 @@
     (give-up-ir1-transform))
   (ir1-transform-type-predicate
    object
-   (specifier-type (continuation-value type))))
+   (ir1-transform-specifier-type (continuation-value type))))
 
 ;;; This is the IR1 transform for simple type predicates. It checks
 ;;; whether the single argument is known to (not) be of the
@@ -492,8 +492,12 @@
   ;; source transform another chance, so it all works out OK, in a
   ;; weird roundabout way. -- WHN 2001-03-18
   (if (and (consp spec) (eq (car spec) 'quote))
-      (let ((type (specifier-type (cadr spec))))
-	(or (let ((pred (cdr (assoc type *backend-type-predicates*
+      (let ((type (careful-specifier-type (cadr spec))))
+	(or (when (not type)
+              (compiler-warn "illegal type specifier for TYPEP: ~S"
+                             (cadr spec))
+              `(%typep ,object ,spec))
+            (let ((pred (cdr (assoc type *backend-type-predicates*
 				    :test #'type=))))
 	      (when pred `(,pred ,object)))
 	    (typecase type
@@ -528,7 +532,7 @@
 (deftransform coerce ((x type) (* *) *)
   (unless (constant-continuation-p type)
     (give-up-ir1-transform))
-  (let ((tspec (specifier-type (continuation-value type))))
+  (let ((tspec (ir1-transform-specifier-type (continuation-value type))))
     (if (csubtypep (continuation-type x) tspec)
 	'x
 	;; Note: The THE here makes sure that specifiers like
@@ -536,7 +540,7 @@
 	`(the ,(continuation-value type)
 	   ,(cond
 	     ((csubtypep tspec (specifier-type 'double-float))
-	      '(%double-float x))	
+	      '(%double-float x))
 	     ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
 	     ((csubtypep tspec (specifier-type 'float))
 	      '(%single-float x))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 47fc4c1..c54e61e 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -168,3 +168,12 @@
 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
 	   17))
+
+;;; bug 181: bad type specifier dropped compiler into debugger
+(assert (list (compile nil '(lambda (x)
+                             (declare (type (0) x))
+                             x))))
+
+(let ((f (compile nil '(lambda (x)
+                        (make-array 1 :element-type '(0))))))
+  (assert (null (ignore-errors (funcall f)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 1534906..a977e77 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; internal versions off the main CVS branch, it gets hairier, e.g.
 ;;; "0.pre7.14.flaky4.13".)
 
-"0.7.7.33"
+"0.7.7.34"