From ad613f03c3e077e63ae871a4e1967ac57a4c59c9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 5 Dec 2002 10:44:43 +0000 Subject: [PATCH] 0.7.10.11: A couple of array fixes ... make DESCRIBE work on rank-0 arrays (Lutz Euler sbcl-devel 2002-12-03) ... make DEFTRANSFORM MAKE-ARRAY warn (or style-warn) in the various appropriate cases: * default :INITIAL-ELEMENT not compatible with :ELEMENT-TYPE * provided :INITIAL-ELEMENT not compatible with :ELEMENT-TYPE * provided :INITIAL-ELEMENT not compatible with (UPGRADED-ARRAY-ELEMENT-TYPE ELEMENT-TYPE) --- NEWS | 2 ++ src/code/describe.lisp | 14 ++++----- src/compiler/array-tran.lisp | 71 ++++++++++++++++++++++++++---------------- tests/interface.pure.lisp | 6 ++++ version.lisp-expr | 2 +- 5 files changed, 61 insertions(+), 34 deletions(-) diff --git a/NEWS b/NEWS index 27cbbca..e67a79c 100644 --- a/NEWS +++ b/NEWS @@ -1438,6 +1438,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: Valtteri Vuorikoski) * the compiler is now able to inline functions that were defined in a complex lexical environment (e.g. inside a MACROLET). + * fixed bug in DESCRIBE, which now works on rank-0 arrays. (thanks + to Lutz Euler) * fixed some more bugs revealed by Paul Dietz' test suite: ** As required by ANSI, LOOP now disallows anonymous collection clauses such as COLLECT I in conjunction with aggregate boolean diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 584e709..b89842f 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -43,18 +43,18 @@ (defmethod describe-object ((x array) s) (let ((rank (array-rank x))) - (cond ((> rank 1) - (format s "~S ~_is " x) - (write-string (if (%array-displaced-p x) "a displaced" "an") s) - (format s " array of rank ~S." rank) - (format s "~@:_Its dimensions are ~S." (array-dimensions x))) - (t + (cond ((= rank 1) (format s "~@:_~S is a ~:[~;displaced ~]vector of length ~S." x (and (array-header-p x) (%array-displaced-p x)) (length x)) (when (array-has-fill-pointer-p x) (format s "~@:_It has a fill pointer, currently ~S." - (fill-pointer x)))))) + (fill-pointer x)))) + (t + (format s "~S ~_is " x) + (write-string (if (%array-displaced-p x) "a displaced" "an") s) + (format s " array of rank ~S." rank) + (format s "~@:_Its dimensions are ~S." (array-dimensions x))))) (let ((array-element-type (array-element-type x))) (unless (eq array-element-type t) (format s diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 579064e..56641ac 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -278,37 +278,41 @@ (saetp (find-if (lambda (saetp) (csubtypep eltype-type (saetp-ctype saetp))) *specialized-array-element-type-properties*)) - (creation-form `(make-array dims :element-type ',eltype - ,@(when fill-pointer - '(:fill-pointer fill-pointer)) - ,@(when adjustable - '(:adjustable adjustable))))) + (creation-form `(make-array dims + :element-type ',(type-specifier (saetp-ctype saetp)) + ,@(when fill-pointer + '(:fill-pointer fill-pointer)) + ,@(when adjustable + '(:adjustable adjustable))))) (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) - (saetp-initial-element-default saetp)))) - (unless (csubtypep (ctype-of (saetp-initial-element-default saetp)) - eltype-type) - ;; This situation arises e.g. in (MAKE-ARRAY 4 - ;; :ELEMENT-TYPE '(INTEGER 1 5)) ANSI's definition of - ;; MAKE-ARRAY says "If INITIAL-ELEMENT is not supplied, - ;; the consequences of later reading an uninitialized - ;; element of new-array are undefined," so this could be - ;; legal code as long as the user plans to write before - ;; he reads, and if he doesn't we're free to do anything - ;; we like. But in case the user doesn't know to write - ;; elements before he reads elements (or to read manuals - ;; before he writes code:-), we'll signal a STYLE-WARNING - ;; in case he didn't realize this. - (compiler-style-warn "The default initial element ~S is not a ~S." - (saetp-initial-element-default saetp) - eltype)) + (cond ((and (constant-continuation-p initial-element) + (eql (continuation-value initial-element) + (saetp-initial-element-default saetp))) creation-form) (t + ;; error checking for target, disabled on the host because + ;; (CTYPE-OF #\Null) is not possible. + #-sb-xc-host + (when (constant-continuation-p initial-element) + (let ((value (continuation-value initial-element))) + (cond + ((not (csubtypep (ctype-of value) + (saetp-ctype saetp))) + ;; this case will cause an error at runtime, so we'd + ;; better WARN about it now. + (compiler-warn "~@<~S is not a ~S (which is the ~ + UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>" + value + (type-specifier (saetp-ctype saetp)) + eltype)) + ((not (csubtypep (ctype-of value) eltype-type)) + ;; this case will not cause an error at runtime, but + ;; it's still worth STYLE-WARNing about. + (compiler-style-warn "~S is not a ~S." + value eltype))))) `(let ((array ,creation-form)) (multiple-value-bind (vector) (%data-vector-and-index array 0) @@ -339,7 +343,22 @@ (unless saetp (give-up-ir1-transform "cannot open-code creation of ~S" result-type-spec)) - + #-sb-xc-host + (unless (csubtypep (ctype-of (saetp-initial-element-default saetp)) + eltype-type) + ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE + ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If + ;; INITIAL-ELEMENT is not supplied, the consequences of later + ;; reading an uninitialized element of new-array are undefined," + ;; so this could be legal code as long as the user plans to + ;; write before he reads, and if he doesn't we're free to do + ;; anything we like. But in case the user doesn't know to write + ;; elements before he reads elements (or to read manuals before + ;; he writes code:-), we'll signal a STYLE-WARNING in case he + ;; didn't realize this. + (compiler-style-warn "The default initial element ~S is not a ~S." + (saetp-initial-element-default saetp) + eltype)) (let* ((n-bits-per-element (saetp-n-bits saetp)) (typecode (saetp-typecode saetp)) (n-pad-elements (saetp-n-pad-elements saetp)) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index b3f8949..8ae4a04 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -27,3 +27,9 @@ (assert (< 0 (length (apropos-list "PRINT" :cl)) (length (apropos-list "PRINT")))) + +;;; DESCRIBE shouldn't fail on rank-0 arrays (bug reported and fixed +;;; by Lutz Euler sbcl-devel 2002-12-03) +(describe #0a0) +(describe #(1 2 3)) +(describe #2a((1 2) (3 4))) diff --git a/version.lisp-expr b/version.lisp-expr index ea842f6..7bff48d 100644 --- 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".) -"0.7.10.10" +"0.7.10.11" -- 1.7.10.4