0.7.7.34:

        Fix BUG 181

diff --git a/BUGS b/BUGS
index 25d6de4..ea797df 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -999,18 +999,6 @@ WORKAROUND:
     (defun bug178alternative (x)
       (funcall (the nil x)))
 
     (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
 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 (file)
--- 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)
   * 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
 
 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 (file)
--- a/install.sh
+++ b/install.sh
@@ -2,6 +2,9 @@
 
 # Install SBCL files into the usual places.
 
 
 # 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/
 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 (file)
--- 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))))
   (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.
 
 ;;; 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))))
                         "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*))
         (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))
 
     (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)
     (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)))))
                 (%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
 ;;; 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)))
                  (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*)))
         (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 (file)
--- 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))
 ;;; 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))
         (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)
 ;;; 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)))
 
                                           "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))
 (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)
        (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 (file)
--- 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))
 ;;; 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))
     (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))
 ;;; 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
     (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 (file)
--- 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))
          (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))
+

 \f
 ;;;; utilities used at run-time for parsing &KEY args in IR1
 
 \f
 ;;;; 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 (file)
--- 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))
     (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")
 
 (/show0 "knownfun.lisp end of file")

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 08b8f3f..9792a4b 100644 (file)
--- 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
                 `(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)))
                   (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 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -81,7 +81,7 @@
     (give-up-ir1-transform))
   (ir1-transform-type-predicate
    object
     (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
 
 ;;; 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))
   ;; 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
                                    :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))
 (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
     (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))
        `(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))
             ;; 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 (file)
--- 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))
 ;;; "(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 (file)
--- 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".)
 
 ;;; 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"