From: Christophe Rhodes Date: Fri, 27 Jan 2006 22:42:55 +0000 (+0000) Subject: 0.9.9.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d59fb3b0953c8d14427b60f949a0e567a8b79fe0;p=sbcl.git 0.9.9.9: Fix bug #399 (gwking on #lisp / paste 16110; reduced case by NJF) ... we need to be able to derive DATA-VECTOR-REF's return type when we have a SIMPLE-STRING, even if the array's type isn't represented directly as an ARRAY-TYPE --- diff --git a/BUGS b/BUGS index 7816958..ed32c27 100644 --- a/BUGS +++ b/BUGS @@ -2152,18 +2152,4 @@ WORKAROUND: (c-string :deport-gen) ...) in host-c-call.lisp. 399: LOOP FOR ACROSS and full call to DATA-VECTOR-REF - The following is a simplified version of code that Gary King posted - to #lisp which triggers a BUG on a full call to DATA-VECTOR-REF: - - (defun foo (x) - (declare (type (or (simple-array character (6)) - (simple-array character (5))) x)) - (aref x 0)) - - The similar code: - - (defun foo (x) - (declare (type (simple-array character (5)) x)) - (aref x 0)) - - does not trigger the full call. + (fixed in sbcl-0.9.9.x) diff --git a/NEWS b/NEWS index c046afc..27782b1 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-0.9.10 relative to sbcl-0.9.9: + * fixed bug #399: full call to DATA-VECTOR-REF in accesses to + certain complicated string types. (reported by Gary King) + changes in sbcl-0.9.9 relative to sbcl-0.9.8: * new platform: experimental support for the Windows operating system has been added. (thanks to Alastair Bridgewater) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 0af3b83..fd4e9a9 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -28,18 +28,33 @@ ;;; type is going to be the array upgraded element type. (defun extract-upgraded-element-type (array) (let ((type (lvar-type array))) - ;; Note that this IF mightn't be satisfied even if the runtime - ;; value is known to be a subtype of some specialized ARRAY, because - ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), - ;; which are represented in the compiler as INTERSECTION-TYPE, not - ;; array type. - (if (array-type-p type) - (array-type-specialized-element-type type) - ;; KLUDGE: there is no good answer here, but at least - ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be - ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR, - ;; 2002-08-21 - *wild-type*))) + (cond + ;; Note that this IF mightn't be satisfied even if the runtime + ;; value is known to be a subtype of some specialized ARRAY, because + ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), + ;; which are represented in the compiler as INTERSECTION-TYPE, not + ;; array type. + ((array-type-p type) (array-type-specialized-element-type type)) + ;; fix for bug #396. This type logic corresponds to the special + ;; case for strings in HAIRY-DATA-VECTOR-REF + ;; (generic/vm-tran.lisp) + ((csubtypep type (specifier-type 'simple-string)) + (cond + ((csubtypep type (specifier-type '(simple-array character (*)))) + (specifier-type 'character)) + #!+sb-unicode + ((csubtypep type (specifier-type '(simple-array base-char (*)))) + (specifier-type 'base-char)) + ((csubtypep type (specifier-type '(simple-array nil (*)))) + *empty-type*) + ;; see KLUDGE below. + (t *wild-type*))) + (t + ;; KLUDGE: there is no good answer here, but at least + ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be + ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR, + ;; 2002-08-21 + *wild-type*)))) (defun extract-declared-element-type (array) (let ((type (lvar-type array))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 26a5b3a..1246cdb 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1157,7 +1157,7 @@ c 0))))) -;; Put this in a separate function. +;;; Put this in a separate function. (defun test-constraint-propagation/cast (x) (when (the double-float (multiple-value-prog1 x @@ -1168,4 +1168,37 @@ (assert (assertoid:raises-error? (test-constraint-propagation/cast 1) type-error))) +;;; bug #399 +(let ((result (make-array 50000 :fill-pointer 0 :adjustable t))) + (defun string->html (string &optional (max-length nil)) + (when (and (numberp max-length) + (> max-length (array-dimension result 0))) + (setf result (make-array max-length :fill-pointer 0 :adjustable t))) + (let ((index 0) + (left-quote? t)) + (labels ((add-char (it) + (setf (aref result index) it) + (incf index)) + (add-string (it) + (loop for ch across it do + (add-char ch)))) + (loop for char across string do + (cond ((char= char #\<) + (add-string "<")) + ((char= char #\>) + (add-string ">")) + ((char= char #\&) + (add-string "&")) + ((char= char #\') + (add-string "'")) + ((char= char #\newline) + (add-string "
")) + ((char= char #\") + (if left-quote? (add-string "“") (add-string "”")) + (setf left-quote? (not left-quote?))) + (t + (add-char char)))) + (setf (fill-pointer result) index) + (coerce result 'string))))) + ;;; success diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9376ba1..ef90f49 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1915,3 +1915,9 @@ (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0))) (1+ x))))) +;;; bug #399 +(with-test (:name :string-union-types) + (compile nil '(lambda (x) + (declare (type (or (simple-array character (6)) + (simple-array character (5))) x)) + (aref x 0)))) diff --git a/version.lisp-expr b/version.lisp-expr index bdf26c7..e93c3b4 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.9.9.6" +"0.9.9.7"