0.7.8.45:

	Some more maintenance on MAKE-SEQUENCE, this time on LIST-like
		type specifiers, motivated by Paul Dietz' ansi-tests
		example of (MERGE 'NULL '(1 3) '(2 4) #'>)
	... abstract some more of the errors into helper
		macros, in preparation for their use in
		MAP/MERGE/CONCATENATE/COERCE;
	... make MAKE-SEQUENCE detect (most) wrong uses of CONS/NULL
		and friends, and error on too-hairy cases.
	... probably still non-compliant (throwing an error) on e.g.
		(MAKE-SEQUENCE '(CONS * (CONS * NULL)) 2) :-(

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index e602e10..93bfa19 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -56,6 +56,34 @@
           :format-control "~S is a bad type specifier for sequences."
           :format-arguments (list ,type-spec)))
 
           :format-control "~S is a bad type specifier for sequences."
           :format-arguments (list ,type-spec)))
 

+(sb!xc:defmacro sequence-type-length-mismatch-error (type length)
+  `(error 'simple-type-error
+          :datum ,length
+          :expected-type (cond ((array-type-p ,type)
+                               `(eql ,(car (array-type-dimensions ,type))))
+                              ((type= ,type (specifier-type 'null))
+                               '(eql 0))
+                              ((cons-type-p ,type)
+                               '(integer 1))
+                              (t (bug "weird type in S-T-L-M-ERROR")))
+          ;; FIXME: this format control causes ugly printing.  There's
+          ;; probably some ~<~@:_~> incantation that would make it
+          ;; nicer. -- CSR, 2002-10-18
+          :format-control "The length requested (~S) does not match the type restriction in ~S."
+          :format-arguments (list ,length (type-specifier ,type))))
+
+(sb!xc:defmacro sequence-type-too-hairy (type-spec)
+  ;; FIXME: Should this be a BUG? I'm inclined to think not; there are
+  ;; words that give some but not total support to this position in
+  ;; 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
+          :format-control "~S is too hairy for sequence functions."
+          :format-arguments (list ,type-spec)))

 ) ; EVAL-WHEN
 
 ;;; It's possible with some sequence operations to declare the length
 ) ; EVAL-WHEN
 
 ;;; It's possible with some sequence operations to declare the length

@@ -158,7 +186,28 @@
   (declare (fixnum length))
   (let ((type (specifier-type type)))
     (cond ((csubtypep type (specifier-type 'list))
   (declare (fixnum length))
   (let ((type (specifier-type type)))
     (cond ((csubtypep type (specifier-type 'list))

-          (make-list length :initial-element initial-element))
+          (cond
+            ((type= type (specifier-type 'list))
+             (make-list length :initial-element initial-element))
+            ((eq type *empty-type*)
+             (bad-sequence-type-error nil))
+            ((type= type (specifier-type 'null))
+             (if (= length 0)
+                 'nil
+                 (sequence-type-length-mismatch-error type length)))
+            ((csubtypep (specifier-type '(cons nil t)) type)
+             ;; The above is quite a neat way of finding out if
+             ;; there's a type restriction on the CDR of the
+             ;; CONS... if there is, I think it's probably fair to
+             ;; give up; if there isn't, then the list to be made
+             ;; must have a length of more than 0.
+             (if (> length 0)
+                 (make-list length :initial-element initial-element)
+                 (sequence-type-length-mismatch-error type length)))
+            ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)),
+            ;; which may seem strange and non-ideal, but then I'd say
+            ;; it was stranger to feed that type in to MAKE-SEQUENCE.
+            (t (sequence-type-too-hairy (type-specifier type)))))

          ((csubtypep type (specifier-type 'vector))
           (if (typep type 'array-type)
               ;; KLUDGE: the above test essentially asks "Do we know
          ((csubtypep type (specifier-type 'vector))
           (if (typep type 'array-type)
               ;; KLUDGE: the above test essentially asks "Do we know

@@ -171,13 +220,7 @@
                       (type-length (car (array-type-dimensions type))))
                   (unless (or (eq type-length '*)
                               (= type-length length))
                       (type-length (car (array-type-dimensions type))))
                   (unless (or (eq type-length '*)
                               (= type-length length))

-                    (error 'simple-type-error
-                           :datum length
-                           :expected-type `(eql ,type-length)
-                           :format-control "The length requested (~S) ~
-                            does not match the length type restriction in ~S."
-                           :format-arguments (list length 
-                                                   (type-specifier type))))
+                    (sequence-type-length-mismatch-error type length))

                   ;; FIXME: These calls to MAKE-ARRAY can't be
                   ;; open-coded, as the :ELEMENT-TYPE argument isn't
                   ;; constant.  Probably we ought to write a
                   ;; FIXME: These calls to MAKE-ARRAY can't be
                   ;; open-coded, as the :ELEMENT-TYPE argument isn't
                   ;; constant.  Probably we ought to write a

@@ -187,13 +230,7 @@
                       (make-array length :element-type etype
                                   :initial-element initial-element)
                       (make-array length :element-type etype))))
                       (make-array length :element-type etype
                                   :initial-element initial-element)
                       (make-array length :element-type etype))))

-              ;; We have a subtype of VECTOR, but it isn't an array
-              ;; type.  Maybe this should be a BUG instead?
-              (error 'simple-type-error
-                     :datum type
-                     :expected-type 'sequence
-                     :format-control "~S is too hairy for MAKE-SEQUENCE."
-                     :format-arguments (list (type-specifier type)))))
+              (sequence-type-too-hairy (type-specifier type))))

          (t (bad-sequence-type-error (type-specifier type))))))
 \f
 ;;;; SUBSEQ
          (t (bad-sequence-type-error (type-specifier type))))))
 \f
 ;;;; SUBSEQ

@@ -1477,7 +1514,7 @@
    which case the one later in the sequence is discarded. The resulting
    sequence is returned.
 
    which case the one later in the sequence is discarded. The resulting
    sequence is returned.
 

-   The :TEST-NOT argument is depreciated."
+   The :TEST-NOT argument is deprecated."

   (declare (fixnum start))
   (seq-dispatch sequence
                (if sequence
   (declare (fixnum start))
   (seq-dispatch sequence
                (if sequence

@@ -1550,7 +1587,7 @@
    discarded. The resulting sequence, which may be formed by destroying the
    given sequence, is returned.
 
    discarded. The resulting sequence, which may be formed by destroying the
    given sequence, is returned.
 

-   The :TEST-NOT argument is depreciated."
+   The :TEST-NOT argument is deprecated."

   (seq-dispatch sequence
     (if sequence
        (list-delete-duplicates* sequence test test-not key from-end start end))
   (seq-dispatch sequence
     (if sequence
        (list-delete-duplicates* sequence test test-not key from-end start end))

@@ -1961,12 +1998,8 @@
 ;;;     perhaps it's worth optimizing the -if-not versions in the same
 ;;;     way as the others?
 ;;;
 ;;;     perhaps it's worth optimizing the -if-not versions in the same
 ;;;     way as the others?
 ;;;

-;;; That sounds reasonable, so if someone wants to submit patches to
-;;; make the -IF-NOT functions compile as efficiently as the
-;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06)
-;;;
-;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT
-;;; too) within the implementation of SBCL.
+;;; FIXME: Maybe remove uses of these deprecated functions (and
+;;; definitely of :TEST-NOT) within the implementation of SBCL.

 (declaim (inline find-if-not position-if-not))
 (macrolet ((def-find-position-if-not (fun-name values-index)
             `(defun ,fun-name (predicate sequence
 (declaim (inline find-if-not position-if-not))
 (macrolet ((def-find-position-if-not (fun-name values-index)
             `(defun ,fun-name (predicate sequence

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 92dff11..5aea01c 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -285,6 +285,25 @@
 (assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
 ;;; and also with types that weren't precicely LIST
 (assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))
 (assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
 ;;; and also with types that weren't precicely LIST
 (assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))

+
+;;; but wait, there's more! The NULL and CONS types also have implicit
+;;; length requirements:
+(macrolet ((assert-type-error (form)
+            `(assert (typep (nth-value 1 (ignore-errors ,form)) 
+                            'type-error))))
+  (locally
+      (declare (optimize safety))
+    ;; MAKE-SEQUENCE
+    (assert-type-error (make-sequence 'cons 0))
+    (assert-type-error (make-sequence 'null 1))
+    (assert (null (make-sequence 'null 0)))
+    (assert (= (length (make-sequence 'cons 3)) 3))
+    ;; and NIL is not a valid type for MAKE-SEQUENCE
+    (assert-type-error (make-sequence 'nil 0))
+    ;; tests for MAP/MERGE/CONCATENATE/COERCE to come.
+    ))
+
+            

 \f
 ;;; success
 (quit :unix-status 104)
 \f
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 236eb25..64b4fcf 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 

-"0.7.8.44"
+"0.7.8.45"