From e3f68bde025bd0602cf554e1eaf5935aaa74662a Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 20 Oct 2003 13:31:06 +0000 Subject: [PATCH] 0.8.4.36: Fix bug 213a ... CONS-TYPE-LENGTH-INFO to walk CONS-TYPE lists ... delete the neat but ultimately flawed (CONS NIL T) test and use a proper test instead ... test suite additions. Add idea from Michael Hudson (sbcl-devel 2003-08-26) to exit early from Darwin compilations when the stack size limit is too small. --- BUGS | 6 +----- NEWS | 3 +++ make-config.sh | 8 ++++++++ src/code/coerce.lisp | 31 ++++++++++++++++++------------ src/code/early-type.lisp | 18 ++++++++++++++++++ src/code/seq.lisp | 47 +++++++++++++++++++++++----------------------- src/code/sort.lisp | 14 ++++++++++---- tests/seq.impure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 9 files changed, 94 insertions(+), 45 deletions(-) diff --git a/BUGS b/BUGS index 4e3f36c..7e35c3c 100644 --- a/BUGS +++ b/BUGS @@ -727,11 +727,7 @@ WORKAROUND: all of the arguments are circular is probably desireable). 213: "Sequence functions and type checking" - a. MAKE-SEQUENCE, COERCE, MERGE and CONCATENATE cannot deal with - various complicated, though recognizeable, CONS types [e.g. - (CONS * (CONS * NULL)) - which according to ANSI should be recognized] (and, in SAFETY 3 - code, should return a list of LENGTH 2 or signal an error) + a. (fixed in 0.8.4.36) b. MAP, when given a type argument that is SUBTYPEP LIST, does not check that it will return a sequence of the given type. Fixing it along the same lines as the others (cf. work done around diff --git a/NEWS b/NEWS index df18876..ee8ebef 100644 --- a/NEWS +++ b/NEWS @@ -2129,6 +2129,9 @@ changes in sbcl-0.8.5 relative to sbcl-0.8.4: * bug fix: LOOP forms using NIL as a for-as-arithmetic counter no longer raise an error; further, using a list as a for-as-arithmetic counter now raises a meaningful error. + * fixed bug 213a: even fairly unreasonable CONS type specifiers are + now understood by sequence creation functions such as MAKE-SEQUENCE + and COERCE. * compiler enhancement: SIGNUM is now better able to derive the type of its result. * type declarations inside WITH-SLOTS are checked. (reported by diff --git a/make-config.sh b/make-config.sh index 438c969..6990175 100644 --- a/make-config.sh +++ b/make-config.sh @@ -178,6 +178,14 @@ elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then # versions 2.3.1 and 2.3.2 $GNUMAKE -C tools-for-build where-is-mcontext tools-for-build/where-is-mcontext > src/runtime/ppc-linux-mcontext.h +elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "darwin" ]; then + # The default stack ulimit under darwin is too small to run PURIFY. + # Best we can do is complain and exit at this stage + if [ $(ulimit -s) = "512" ]; then + echo "Your stack size limit is too small to build SBCL." + echo "See the limit(1) or ulimit(1) commands and the README file." + exit 1 + fi else # Nothing need be done in this case, but sh syntax wants a placeholder. echo > /dev/null diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index f1dca41..575083f 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -203,18 +203,25 @@ res)))) ((csubtypep type (specifier-type 'list)) (if (vectorp object) - (cond ((type= type (specifier-type 'list)) - (vector-to-list* object)) - ((type= type (specifier-type 'null)) - (if (= (length object) 0) - 'nil - (sequence-type-length-mismatch-error type - (length object)))) - ((csubtypep (specifier-type '(cons nil t)) type) - (if (> (length object) 0) - (vector-to-list* object) - (sequence-type-length-mismatch-error type 0))) - (t (sequence-type-too-hairy (type-specifier type)))) + (cond + ((type= type (specifier-type 'list)) + (vector-to-list* object)) + ((type= type (specifier-type 'null)) + (if (= (length object) 0) + 'nil + (sequence-type-length-mismatch-error type + (length object)))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (length object))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (vector-to-list* object)))) + (t (sequence-type-too-hairy (type-specifier type)))) (coerce-error))) ((csubtypep type (specifier-type 'vector)) (typecase object diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 56aac8c..53137ba 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -460,6 +460,24 @@ (eq cdr-type *empty-type*)) *empty-type* (%make-cons-type car-type cdr-type))) + +(defun cons-type-length-info (type) + (declare (type cons-type type)) + (do ((min 1 (1+ min)) + (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr))) + ((not (cons-type-p cdr)) + (cond + ((csubtypep cdr (specifier-type 'null)) + (values min t)) + ((csubtypep *universal-type* cdr) + (values min nil)) + ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*) + (values min nil)) + ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*) + (values min t)) + (t (values min :maybe)))) + ())) + ;;;; type utilities diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 2d0b5a7..777ee4a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -264,7 +264,7 @@ (defun make-sequence (type length &key (initial-element nil iep)) #!+sb-doc "Return a sequence of the given TYPE and LENGTH, with elements initialized - to :INITIAL-ELEMENT." + to INITIAL-ELEMENT." (declare (fixnum length)) (let* ((adjusted-type (typecase type @@ -290,15 +290,15 @@ (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))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (make-list length :initial-element initial-element))) ;; 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. @@ -736,19 +736,20 @@ (and (vectorp x) (= (length x) 0)))) sequences) 'nil - (sequence-type-length-mismatch-error type - ;; FIXME: circular - ;; list issues. And - ;; rightward-drift. - (reduce #'+ - (mapcar #'length - sequences))))) - ((csubtypep (specifier-type '(cons nil t)) type) - (if (notevery (lambda (x) (or (null x) - (and (vectorp x) (= (length x) 0)))) - sequences) - (apply #'concat-to-list* sequences) - (sequence-type-length-mismatch-error type 0))) + (sequence-type-length-mismatch-error + type + ;; FIXME: circular list issues. + (reduce #'+ sequences :key #'length)))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (reduce #'+ sequences :key #'length))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (apply #'concat-to-list* sequences)))) (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) (apply #'concat-to-simple* output-type-spec sequences)) diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 99494de..f30c67d 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -396,10 +396,16 @@ (sequence-type-length-mismatch-error type (+ (length s1) (length s2))))) - (if (csubtypep (specifier-type '(cons nil t)) type) - (if (and (null s1) (null s2)) - (sequence-type-length-mismatch-error type 0) - (values (merge-lists* s1 s2 pred-fun key-fun))) + (if (cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (+ (length s1) (length s2)))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (values (merge-lists* s1 s2 pred-fun key-fun)))) (sequence-type-too-hairy result-type)))) ((csubtypep type (specifier-type 'vector)) (let* ((vector-1 (coerce sequence1 'vector)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 3470c35..e41d17d 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -299,31 +299,41 @@ ;; MAKE-SEQUENCE (assert-type-error (make-sequence 'cons 0)) (assert-type-error (make-sequence 'null 1)) + (assert-type-error (make-sequence '(cons t null) 0)) + (assert-type-error (make-sequence '(cons t null) 2)) ;; KLUDGE: I'm not certain that this test actually tests for what ;; it should test, in that the type deriver and optimizers might ;; be too smart for the good of an exhaustive test system. ;; However, it makes me feel good. -- CSR, 2002-10-18 (assert (null (make-sequence 'null 0))) (assert (= (length (make-sequence 'cons 3)) 3)) + (assert (= (length (make-sequence '(cons t null) 1)) 1)) ;; and NIL is not a valid type for MAKE-SEQUENCE (assert-type-error (make-sequence 'nil 0)) ;; COERCE (assert-type-error (coerce #(1) 'null)) (assert-type-error (coerce #() 'cons)) + (assert-type-error (coerce #() '(cons t null))) + (assert-type-error (coerce #(1 2) '(cons t null))) (assert (null (coerce #() 'null))) (assert (= (length (coerce #(1) 'cons)) 1)) + (assert (= (length (coerce #(1) '(cons t null))) 1)) (assert-type-error (coerce #() 'nil)) ;; MERGE (assert-type-error (merge 'null '(1 3) '(2 4) '<)) (assert-type-error (merge 'cons () () '<)) (assert (null (merge 'null () () '<))) (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4)) + (assert (= (length (merge '(cons t (cons t (cons t (cons t null)))) + '(1 3) '(2 4) '<)) 4)) (assert-type-error (merge 'nil () () '<)) ;; CONCATENATE (assert-type-error (concatenate 'null '(1) "2")) (assert-type-error (concatenate 'cons #() ())) + (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6))) (assert (null (concatenate 'null () #()))) (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4)) + (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3)) (assert-type-error (concatenate 'nil '(3))) ;; FIXME: tests for MAP to come when some brave soul implements ;; the analogous type checking for MAP/%MAP. diff --git a/version.lisp-expr b/version.lisp-expr index 04610ef..bb50b24 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.8.4.35" +"0.8.4.36" -- 1.7.10.4