Merge pull request #4 from ajberkley/ajb/handle-bad-array-element-types

Handle bad array element-types

Author: ajberkley

README.md

@@ -302,4 +302,4 @@ See [benchmarking.md](benchmarking.md).
 - [ ] Speed up cl-binary-store on ABCL and ECL so it is less than 10x slower than on SBCL
 - [ ] Handle specialized multi-dimensional array data on non-SBCL faster.  See babel for all the variants on with-array-data
 - [ ] Faster standard-object serialization / deserialization using direct slot location accessors
-- [ ] Handle ECL does not like array element type nil (like what happens when you have a zero size array) with invalid-data condition
+

src/array.lisp

@@ -1,5 +1,11 @@
 (in-package :cl-binary-store)
 
+(defun is-type-specifier-p (type-specifier)
+  "Returns true if TYPE-SPECIFIER is a valid type specifier."
+  (or #+sbcl (sb-ext:valid-type-specifier-p type-specifier)
+      #+ccl (ccl:type-specifier-p type-specifier)
+      #+ecl (c::valid-type-specifier type-specifier)))
+
 (defun restore-array (storage restore-object)
   (declare (type function restore-object) (optimize (speed 3) (safety 1)))
   (let* ((has-fill-pointer (funcall restore-object))
@@ -9,9 +15,15 @@
 	 (dimensions (loop repeat array-rank
                            collect (restore-tagged-unsigned-fixnum storage)))
 	 (displaced (funcall restore-object))
-         (array-total-size (if dimensions (reduce #'* dimensions) 0)))
+         (array-total-size (if dimensions (reduce #'* dimensions) 0))
+         (element-type (funcall restore-object)))
     (unless (and (typep array-total-size 'fixnum) (>= array-total-size 0))
       (unexpected-data "Array total size is too large"))
+    #+ecl
+    (unless element-type
+      (unexpected-data "ECL does not support empty arrays with nil element type"))
+    (unless (is-type-specifier-p element-type)
+      (unexpected-data "Invalid array element-type"))
     (check-if-too-much-data (read-storage-max-to-read storage) array-total-size)
     (labels ((check-fill-pointer (dimensions)
                (when has-fill-pointer
@@ -21,8 +33,7 @@
                    (unexpected-data "fill-pointer > vector length")))
                (values)))
       (if displaced
-	  (let ((element-type (funcall restore-object))
-	        (offset (restore-tagged-unsigned-fixnum storage))
+	  (let ((offset (restore-tagged-unsigned-fixnum storage))
 	        (displaced-to (funcall restore-object)))
             (unless (typep displaced-to 'array)
               (unexpected-data "displaced to a non array?!"))
@@ -37,9 +48,8 @@
           (progn
             (when has-fill-pointer (check-fill-pointer dimensions))
 	    (let ((array
-		    (let* ((element-type (funcall restore-object)))
-		      (make-array dimensions :element-type element-type :adjustable adjustable
-					     :fill-pointer fill-pointer))))
+		    (make-array dimensions :element-type element-type :adjustable adjustable
+					   :fill-pointer fill-pointer)))
               ;; We need to make our array first in case any of the array elements refer to it!
               ;; If we are ever referred to, then there will already be a fixup in place for
               ;; our array handled by `restore-new-reference-indicator'.

src/cl-binary-store.lisp

@@ -213,10 +213,10 @@
 (define-condition invalid-input-data (simple-error)
   ())
 
-(defun unexpected-data (expected &optional (data nil data-provided-p))
+(defun unexpected-data (message &optional (data nil data-provided-p))
   (error 'invalid-input-data
-         :format-control "Expected ~A~A"
-         :format-arguments (list expected
+         :format-control "~A~A"
+         :format-arguments (list message
                                  (if data-provided-p
                                      ;; be careful not to provide anything
                                      ;; that cannot be printed trivially here!

src/numbers.lisp

@@ -329,9 +329,9 @@
 	       (#.+fixnum-code+
                 (let ((fixnum (restore-fixnum storage)))
                   (unless (<= 0 fixnum (- most-positive-fixnum +interior-coded-max-integer+ 1))
-                    (unexpected-data "unsigned fixnum/interior" fixnum))
+                    (unexpected-data "expected unsigned fixnum/interior" fixnum))
                   (truly-the fixnum fixnum)))
-               (otherwise (unexpected-data "tag for unsigned fixnum" tag)))
+               (otherwise (unexpected-data "expected tag for unsigned fixnum" tag)))
 	     +interior-coded-max-integer+ 1)))))
 
 (declaim (ftype (function (read-storage)
@@ -349,7 +349,7 @@
 	  (#.+ub16-code+ (restore-ub16 storage))
 	  (#.+ub32-code+ (restore-ub32 storage))
 	  (#.+fixnum-code+ (restore-fixnum storage))
-          (otherwise (unexpected-data "tag for unsigned fixnum" tag))))))
+          (otherwise (unexpected-data "expected tag for unsigned fixnum" tag))))))
 
 (declaim (ftype (function (read-storage)
 			  #+sbcl (values fixnum &optional)
@@ -367,7 +367,7 @@
 	  (#.+sb8-code+ (restore-sb8 storage))
 	  (#.+sb16-code+ (restore-sb16 storage))
 	  (#.+sb32-code+ (restore-sb32 storage))
-          (otherwise (unexpected-data "tag for fixnum" tag))))))
+          (otherwise (unexpected-data "expected tag for fixnum" tag))))))
 
 (declaim (inline store-tagged-unsigned-integer))
 

src/user.lisp

@@ -191,7 +191,7 @@
           (vector
            (restore-from-vector place)))
       (babel:character-decoding-error (e)
-        (unexpected-data "UTF-8 data" e)))))
+        (unexpected-data "Expected UTF-8 data" e)))))
 
 (defun store (place data &key (track-references *track-references*)
 			   (support-shared-list-structures *support-shared-list-structures*)

test/cl-binary-store-tests.lisp

@@ -721,7 +721,6 @@
      (invalid-input-data ()))))
 
 (define-test other-fuzzing-tests
-  #-ecl
   (finish
    (handler-case
        (restore #(24 53 197 0 44 60 123 20))