From 627c66211b93537e90c08b34b387edbd7e301011 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 2 Oct 2002 12:09:17 +0000 Subject: [PATCH] 0.7.8.8: Reintroduce patch to fix handling of type arguments to MAP/MERGE/... as per CSR sbcl-devel 2002-10-02 ... changes from 0.7.7.33 version: * smarter MAKE-SEQUENCE-LIKE implementation * reintroduction of (COERCE 'SIMPLE-VECTOR) transform * one or two more deleted symbols from package-data-list.lisp-expr Performance problems are gone, I think. --- BUGS | 28 ----- package-data-list.lisp-expr | 9 +- src/code/class.lisp | 2 + src/code/coerce.lisp | 82 ++----------- src/code/early-fasl.lisp | 4 +- src/code/primordial-extensions.lisp | 20 +++- src/code/seq.lisp | 217 +++++++++++++---------------------- src/code/show.lisp | 22 +++- src/code/sort.lisp | 4 +- src/compiler/fndb.lisp | 4 - src/compiler/seqtran.lisp | 25 ++-- src/compiler/typetran.lisp | 10 +- tests/seq.impure.lisp | 55 +++++++++ version.lisp-expr | 2 +- 14 files changed, 216 insertions(+), 268 deletions(-) diff --git a/BUGS b/BUGS index 9577381..369b3f7 100644 --- a/BUGS +++ b/BUGS @@ -253,14 +253,6 @@ WORKAROUND: 46: type safety errors reported by Peter Van Eynde July 25, 2000: - a: (COERCE (QUOTE (A B C)) (QUOTE (VECTOR * 4))) - => #(A B C) - In general lengths of array type specifications aren't - checked by COERCE, so it fails when the spec is - (VECTOR 4), (STRING 2), (SIMPLE-BIT-VECTOR 3), or whatever. - b: CONCATENATE has the same problem of not checking the length - of specified output array types. MAKE-SEQUENCE and MAP and - MERGE also have the same problem. c: (COERCE 'AND 'FUNCTION) returns something related to (MACRO-FUNCTION 'AND), but ANSI says it should raise an error. h: (MAKE-CONCATENATED-STREAM (MAKE-STRING-OUTPUT-STREAM)) @@ -370,26 +362,6 @@ WORKAROUND: the new output block should start indented 2 or more characters rightward of the correct location. -66: - ANSI specifies that the RESULT-TYPE argument of CONCATENATE must be - a subtype of SEQUENCE, but CONCATENATE doesn't check this properly: - (CONCATENATE 'SIMPLE-ARRAY #(1 2) '(3)) => #(1 2 3) - This also leads to funny behavior when derived type specifiers - are used, as originally reported by Milan Zamazal for CMU CL (on the - Debian bugs mailing list (?) 2000-02-27), then reported by Martin - Atzmueller for SBCL (2000-10-01 on sbcl-devel@lists.sourceforge.net): - (DEFTYPE FOO () 'SIMPLE-ARRAY) - (CONCATENATE 'FOO #(1 2) '(3)) - => # is a bad type specifier for - sequence functions. - The derived type specifier FOO should act the same way as the - built-in type SIMPLE-ARRAY here, but it doesn't. That problem - doesn't seem to exist for sequence types: - (DEFTYPE BAR () 'SIMPLE-VECTOR) - (CONCATENATE 'BAR #(1 2) '(3)) => #(1 2 3) - See also bug #46a./b., and discussion and patch sbcl-devel and - cmucl-imp 2002-07 - 67: As reported by Winton Davies on a CMU CL mailing list 2000-01-10, and reported for SBCL by Martin Atzmueller 2000-10-20: (TRACE GETHASH) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1d0ec00..5639584 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1004,9 +1004,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "CODE-COMPONENT" "CODE-COMPONENT-P" "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-INSTRUCTIONS" - "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUN" "COERCE-TO-LEXENV" - "COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING" - "COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR" + "COERCE-TO-FUN" "COERCE-TO-LEXENV" + "COERCE-TO-LIST" "COERCE-TO-VECTOR" "*COLD-INIT-COMPLETE-P*" "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P" @@ -1081,7 +1080,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "ANSI-STREAM-IN-INDEX" "ANSI-STREAM-MISC" "ANSI-STREAM-N-BIN" "ANSI-STREAM-OUT" "ANSI-STREAM-SOUT" - "LIST-TO-SIMPLE-STRING*" "LIST-TO-BIT-VECTOR*" "LIST-TO-VECTOR*" "LOGICAL-HOST" "LOGICAL-HOST-DESIGNATOR" "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" @@ -1230,8 +1228,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" "VALUES-TYPES" "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P" - "VECTOR-TO-VECTOR*" "VECTOR-TO-SIMPLE-STRING*" - "VECTOR-TO-BIT-VECTOR*" "VECTOR-TO-SIMPLE-BIT-VECTOR*" + "VECTOR-TO-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" "WRONG-NUMBER-OF-INDICES-ERROR" diff --git a/src/code/class.lisp b/src/code/class.lisp index ffda24a..7d9b77d 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1203,6 +1203,8 @@ (inherits-list (second x)) (class (make-standard-class :name name)) (class-cell (find-class-cell name))) + ;; Needed to open-code the MAP, below + (declare (type list inherits-list)) (setf (class-cell-class class-cell) class (info :type :class name) class-cell (info :type :kind name) :instance) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 5d0ffa3..dfd208d 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -27,21 +27,11 @@ (:list '(pop in-object)) (:vector '(aref in-object index)))))))) - (def list-to-simple-string* (make-string length) schar :list) - - (def list-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :list) - - (def list-to-vector* (make-sequence-of-type type length) + (def list-to-vector* (make-sequence type length) aref :list t) - (def vector-to-vector* (make-sequence-of-type type length) - aref :vector t) - - (def vector-to-simple-string* (make-string length) schar :vector) - - (def vector-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :vector)) + (def vector-to-vector* (make-sequence type length) + aref :vector t)) (defun vector-to-list* (object) (let ((result (list nil)) @@ -53,24 +43,6 @@ (declare (fixnum index)) (rplacd splice (list (aref object index)))))) -(defun string-to-simple-string* (object) - (if (simple-string-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-string data)) - (subseq data start end)))) - -(defun bit-vector-to-simple-bit-vector* (object) - (if (simple-bit-vector-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-bit-vector data)) - (subseq data start end)))) - (defvar *offending-datum*); FIXME: Remove after debugging COERCE. ;;; These are used both by the full DEFUN function and by various @@ -80,7 +52,7 @@ ;;; argument type is known. It might be better to do this with ;;; DEFTRANSFORMs, though. (declaim (inline coerce-to-list)) -(declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector)) +(declaim (inline coerce-to-vector)) (defun coerce-to-fun (object) ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because ;; it's so big and because optimizing away the outer ETYPECASE @@ -116,22 +88,11 @@ cons) :format-control "~S can't be coerced to a function." :format-arguments (list object))))))) + (defun coerce-to-list (object) (etypecase object (vector (vector-to-list* object)))) -(defun coerce-to-simple-string (object) - (etypecase object - (list (list-to-simple-string* object)) - (string (string-to-simple-string* object)) - (vector (vector-to-simple-string* object)))) -(defun coerce-to-bit-vector (object) - (etypecase object - (list (list-to-bit-vector* object)) - (vector (vector-to-bit-vector* object)))) -(defun coerce-to-simple-vector (x) - (if (simple-vector-p x) - x - (replace (make-array (length x)) x))) + (defun coerce-to-vector (object output-type-spec) (etypecase object (list (list-to-vector* object output-type-spec)) @@ -145,10 +106,7 @@ (/show0 "entering COERCE-ERROR") (error 'simple-type-error :format-control "~S can't be converted to type ~S." - :format-arguments (list object output-type-spec))) - (check-result (result) - #!+high-security (aver (typep result output-type-spec)) - result)) + :format-arguments (list object output-type-spec)))) (let ((type (specifier-type output-type-spec))) (cond ((%typep object output-type-spec) @@ -236,28 +194,12 @@ (if (vectorp object) (vector-to-list* object) (coerce-error))) - ((csubtypep type (specifier-type 'string)) - (check-result - (typecase object - (list (list-to-simple-string* object)) - (string (string-to-simple-string* object)) - (vector (vector-to-simple-string* object)) - (t - (coerce-error))))) - ((csubtypep type (specifier-type 'bit-vector)) - (check-result - (typecase object - (list (list-to-bit-vector* object)) - (vector (vector-to-bit-vector* object)) - (t - (coerce-error))))) ((csubtypep type (specifier-type 'vector)) - (check-result - (typecase object - (list (list-to-vector* object output-type-spec)) - (vector (vector-to-vector* object output-type-spec)) - (t - (coerce-error))))) + (typecase object + (list (list-to-vector* object output-type-spec)) + (vector (vector-to-vector* object output-type-spec)) + (t + (coerce-error)))) (t (coerce-error)))))) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index be855f6..34798cd 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -42,7 +42,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 32) +(def!constant +fasl-file-version+ 33) ;;; (record of versions before 0.7.0 deleted in 0.7.1.41) ;;; 23 = sbcl-0.7.0.1 deleted no-longer-used EVAL-STACK stuff, ;;; causing changes in *STATIC-SYMBOLS*. @@ -63,6 +63,8 @@ ;;; is currently external to its package ;;; 32: (2002-09-21) changes in implementation of sequence functions, ;;; causing old utility functions like COERCE-TO-SIMPLE-VECTOR to go away +;;; 33: (2002-10-02) (again) changes in implementation of sequence functions, +;;; causing old utility functions like COERCE-TO-SIMPLE-VECTOR to go away ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 9299521..0f901a3 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -149,9 +149,23 @@ ;;; producing a symbol in the current package. (eval-when (:compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest things) - (values (intern (apply #'concatenate - 'string - (mapcar #'string things)))))) + (let ((name (case (length things) + ;; why isn't this just the value in the T branch? + ;; Well, this is called early in cold-init, before + ;; the type system is set up; however, now that we + ;; check for bad lengths, the type system is needed + ;; for calls to CONCATENATE. So we need to make sure + ;; that the calls are transformed away: + (1 (concatenate 'string (the simple-string (string (car things))))) + (2 (concatenate 'string + (the simple-string (string (car things))) + (the simple-string (string (cadr things))))) + (3 (concatenate 'string + (the simple-string (string (car things))) + (the simple-string (string (cadr things))) + (the simple-string (string (caddr things))))) + (t (apply #'concatenate 'string (mapcar #'string things)))))) + (values (intern name))))) ;;; like SYMBOLICATE, but producing keywords (defun keywordicate (&rest things) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 9ccda2a..9269296 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -26,7 +26,7 @@ ;;; ;;; FIXME: It might be worth making three cases here, LIST, ;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR. -;;; It tend to make code run faster but be bigger; some benchmarking +;;; It tends to make code run faster but be bigger; some benchmarking ;;; is needed to decide. (sb!xc:defmacro seq-dispatch (sequence list-form array-form) `(if (listp ,sequence) @@ -36,11 +36,25 @@ (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc "Return a sequence of the same type as SEQUENCE and the given LENGTH." - `(make-sequence-of-type (type-of ,sequence) ,length)) - -(sb!xc:defmacro type-specifier-atom (type) - #!+sb-doc "Return the broad class of which TYPE is a specific subclass." - `(if (atom ,type) ,type (car ,type))) + `(if (typep ,sequence 'list) + (make-list ,length) + (progn + ;; This is only called from places which have already deduced + ;; that the SEQUENCE argument is actually a sequence. So + ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE + ;; 'VECTOR)), except that this seems to be a performance + ;; hotspot. + (make-array ,length + :element-type (array-element-type ,sequence))))) + +(sb!xc:defmacro bad-sequence-type-error (type-spec) + `(error 'simple-type-error + :datum ,type-spec + ;; FIXME: This is actually wrong, and should be something + ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P). + :expected-type 'sequence + :format-control "~S is a bad type specifier for sequences." + :format-arguments (list ,type-spec))) ) ; EVAL-WHEN @@ -69,33 +83,6 @@ (vector-of-checked-length-given-length sequence declared-length)))))) -;;; Given an arbitrary type specifier, return a sane sequence type -;;; specifier that we can directly match. -(defun result-type-or-lose (type &optional nil-ok) - (let ((type (specifier-type type))) - (cond - ((eq type *empty-type*) - (if nil-ok - nil - (error 'simple-type-error - :datum type - :expected-type '(or vector cons) - :format-control - "A NIL output type is invalid for this sequence function." - :format-arguments ()))) - ((dolist (seq-type '(list string simple-vector bit-vector)) - (when (csubtypep type (specifier-type seq-type)) - (return seq-type)))) - ((csubtypep type (specifier-type 'vector)) - (type-specifier type)) - (t - (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control - "~S is not a legal type specifier for sequence functions." - :format-arguments (list type)))))) - (defun signal-index-too-large-error (sequence index) (let* ((length (length sequence)) (max-index (and (plusp length) @@ -117,22 +104,6 @@ `(integer 0 ,max-end) ;; This seems silly, is there something better? '(integer (0) 0))))) - -(defun make-sequence-of-type (type length) - #!+sb-doc "Return a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) - (case (type-specifier-atom type) - (list (make-list length)) - ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-string base-string simple-base-string) - (make-string length)) - (simple-vector (make-array length)) - ((array simple-array vector) - (if (listp type) - (make-array length :element-type (cadr type)) - (make-array length))) - (t - (make-sequence-of-type (result-type-or-lose type) length)))) (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -180,42 +151,42 @@ (let ((type (specifier-type type))) (cond ((csubtypep type (specifier-type 'list)) (make-list length :initial-element initial-element)) - ((csubtypep type (specifier-type 'string)) - (if iep - (make-string length :initial-element initial-element) - (make-string length))) - ((csubtypep type (specifier-type 'simple-vector)) - (make-array length :initial-element initial-element)) - ((csubtypep type (specifier-type 'bit-vector)) - (if iep - (make-array length :element-type '(mod 2) - :initial-element initial-element) - (make-array length :element-type '(mod 2)))) ((csubtypep type (specifier-type 'vector)) (if (typep type 'array-type) - (let ((etype (type-specifier - (array-type-specialized-element-type type))) - (vlen (car (array-type-dimensions type)))) - (if (and (numberp vlen) (/= vlen length)) - (error 'simple-type-error - ;; These two are under-specified by ANSI. - :datum (type-specifier type) - :expected-type (type-specifier type) - :format-control - "The length of ~S does not match the specified ~ - length=~S." - :format-arguments - (list (type-specifier type) length))) - (if iep - (make-array length :element-type etype - :initial-element initial-element) - (make-array length :element-type etype))) - (make-array length :initial-element initial-element))) - (t (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control "~S is a bad type specifier for sequences." - :format-arguments (list type)))))) + ;; KLUDGE: the above test essentially asks "Do we know + ;; what the upgraded-array-element-type is?" [consider + ;; (OR STRING BIT-VECTOR)] + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let ((etype (type-specifier + (array-type-specialized-element-type type))) + (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)))) + ;; 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 + ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, + ;; 2002-07-22 + (if iep + (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))))) + (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ ;;;; @@ -272,11 +243,11 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-copy-seq (sequence type) +(sb!xc:defmacro vector-copy-seq (sequence) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (copy (make-sequence-of-type ,type length))) + (copy (make-sequence-like ,sequence length))) ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) @@ -306,16 +277,7 @@ (defun vector-copy-seq* (sequence) (declare (type vector sequence)) - (vector-copy-seq sequence - (typecase sequence - ;; Pick off the common cases so that we don't have to... - ((vector t) 'simple-vector) - (string 'simple-string) - (bit-vector 'simple-bit-vector) - ((vector single-float) '(simple-array single-float 1)) - ((vector double-float) '(simple-array double-float 1)) - ;; ...do a full call to TYPE-OF. - (t (type-of sequence))))) + (vector-copy-seq sequence)) ;;;; FILL @@ -498,7 +460,7 @@ (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence-of-type ,type length))) + (new-sequence (make-sequence ,type length))) ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) @@ -597,7 +559,7 @@ (do ((sequences ,sequences (cdr sequences)) (lengths lengths (cdr lengths)) (index 0) - (result (make-sequence-of-type ,output-type-spec total-length))) + (result (make-sequence ,output-type-spec total-length))) ((= index total-length) result) (declare (fixnum index)) (let ((sequence (car sequences))) @@ -620,24 +582,19 @@ ) ; EVAL-WHEN -;;; FIXME: Make a compiler macro or transform for this which efficiently -;;; handles the case of constant 'STRING first argument. (It's not just time -;;; efficiency, but space efficiency..) (defun concatenate (output-type-spec &rest sequences) #!+sb-doc "Return a new sequence of all the argument sequences concatenated together which shares no structure with the original argument sequences of the specified OUTPUT-TYPE-SPEC." - (case (type-specifier-atom output-type-spec) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) ; FIXME: unifying principle here? - (let ((result (apply #'concat-to-simple* output-type-spec sequences))) - #!+high-security (aver (typep result output-type-spec)) - result)) - (list (apply #'concat-to-list* sequences)) + (let ((type (specifier-type output-type-spec))) + (cond + ((csubtypep type (specifier-type 'vector)) + (apply #'concat-to-simple* output-type-spec sequences)) + ((csubtypep type (specifier-type 'list)) + (apply #'concat-to-list* sequences)) (t - (apply #'concatenate (result-type-or-lose output-type-spec) sequences)))) + (bad-sequence-type-error output-type-spec))))) ;;; internal frobs ;;; FIXME: These are weird. They're never called anywhere except in @@ -757,7 +714,7 @@ (declare (type index counter)))))) (declare (type index min-len)) (with-map-state sequences - (let ((result (make-sequence-of-type output-type-spec min-len)) + (let ((result (make-sequence output-type-spec min-len)) (index 0)) (declare (type index index)) (loop with updated-map-apply-args @@ -786,7 +743,8 @@ ;;; length of the output sequence matches any length specified ;;; in RESULT-TYPE. (defun %map (result-type function first-sequence &rest more-sequences) - (let ((really-fun (%coerce-callable-to-fun function))) + (let ((really-fun (%coerce-callable-to-fun function)) + (type (specifier-type result-type))) ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn ;; it into something which can be DEFTRANSFORMed away. (It's ;; fairly important to handle this case efficiently, since @@ -799,36 +757,21 @@ ;; approach, consing O(N-ARGS) temporary storage (which can have ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time. (let ((sequences (cons first-sequence more-sequences))) - (case (type-specifier-atom result-type) - ((nil) (%map-for-effect really-fun sequences)) - (list (%map-to-list really-fun sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) + (cond + ((eq type *empty-type*) (%map-for-effect really-fun sequences)) + ((csubtypep type (specifier-type 'list)) + (%map-to-list really-fun sequences)) + ((csubtypep type (specifier-type 'vector)) (%map-to-vector result-type really-fun sequences)) (t - (apply #'map - (result-type-or-lose result-type t) - really-fun - sequences))))))) + (bad-sequence-type-error result-type))))))) (defun map (result-type function first-sequence &rest more-sequences) - (sequence-of-checked-length-given-type (apply #'%map - result-type - function - first-sequence - more-sequences) - ;; (The RESULT-TYPE isn't - ;; strictly the type of the - ;; result, because when - ;; RESULT-TYPE=NIL, the result - ;; actually has NULL type. But - ;; that special case doesn't - ;; matter here, since we only - ;; look closely at vector - ;; types; so we can just pass - ;; RESULT-TYPE straight through - ;; as a type specifier.) - result-type)) + (apply #'%map + result-type + function + first-sequence + more-sequences)) ;;; KLUDGE: MAP has been rewritten substantially since the fork from ;;; CMU CL in order to give reasonable performance, but this diff --git a/src/code/show.lisp b/src/code/show.lisp index 67234e0..4120a0e 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -33,14 +33,30 @@ #!+sb-show (defvar */show* t) (defun cannot-/show (string) + (declare (type simple-string string)) #+sb-xc-host (error "can't /SHOW: ~A" string) ;; We end up in this situation when we execute /SHOW too early in ;; cold init. That happens to me often enough that it's really ;; annoying for it to cause a hard failure -- which at that point is ;; hard to recover from -- instead of just diagnostic output. - #-sb-xc-host (sb!sys:%primitive - print - (concatenate 'string "/can't /SHOW: " string)) + ;; + ;; FIXME: The following is what we'd like to have. However, + ;; including it as is causes compilation of make-host-2 to fail, + ;; with "caught WARNING: defining setf macro for AREF when (SETF + ;; AREF) was previously treated as a function" during compilation of + ;; defsetfs.lisp + ;; + ;; #-sb-xc-host (sb!sys:%primitive print + ;; (concatenate 'simple-string "/can't /SHOW:" string)) + ;; + ;; because the CONCATENATE is transformed to an expression involving + ;; (SETF AREF). Not declaring the argument as a SIMPLE-STRING (or + ;; otherwise inhibiting the transform; e.g. with (SAFETY 3)) would + ;; help, but full calls to CONCATENATE don't work this early in + ;; cold-init, because they now need the full assistance of the type + ;; system. So (KLUDGE): + #-sb-xc-host (sb!sys:%primitive print "/can't /SHOW:") + #-sb-xc-host (sb!sys:%primitive print string) (values)) ;;; Should /SHOW output be suppressed at this point? diff --git a/src/code/sort.lisp b/src/code/sort.lisp index de92015..e312715 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -431,8 +431,8 @@ (vector-2 (coerce sequence2 'vector)) (length-1 (length vector-1)) (length-2 (length vector-2)) - (result (make-sequence-of-type result-type - (+ length-1 length-2)))) + (result (make-sequence result-type + (+ length-1 length-2)))) (declare (vector vector-1 vector-2) (fixnum length-1 length-2)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6614a44..5d06047 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -36,12 +36,8 @@ ;; is FOLDABLE at all. Check this. (movable #-sb-xc-host foldable) :derive-type (result-type-specifier-nth-arg 2)) -(defknown list-to-simple-string* (list) simple-string) -(defknown list-to-bit-vector* (list) bit-vector) (defknown list-to-vector* (list type-specifier) vector) -(defknown list-to-simple-vector* (list) simple-vector) (defknown vector-to-vector* (vector type-specifier) vector) -(defknown vector-to-simple-string* (vector) vector) (defknown type-of (t) t (foldable flushable)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 0ece88a..9792a4b 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -652,10 +652,12 @@ ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. -#+nil ; FIXME: currently commented out because of bug 188 +;;; +;;; FIXME: currently KLUDGEed because of bug 188 (deftransform concatenate ((rtype &rest sequences) (t &rest simple-string) - simple-string) + simple-string + :policy (< safety 3)) (collect ((lets) (forms) (all-lengths) @@ -670,16 +672,19 @@ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset res start ,n-length)) - (forms `(setq start (+ start ,n-length))))) + (forms `(setq start (opaque-identity (+ start ,n-length)))))) `(lambda (rtype ,@(args)) (declare (ignore rtype)) - (let* (,@(lets) - (res (make-string (truncate (the index (+ ,@(all-lengths))) - sb!vm:n-byte-bits))) - (start ,vector-data-bit-offset)) - (declare (type index start ,@(all-lengths))) - ,@(forms) - res)))) + ;; KLUDGE + (flet ((opaque-identity (x) x)) + (declare (notinline opaque-identity)) + (let* (,@(lets) + (res (make-string (truncate (the index (+ ,@(all-lengths))) + sb!vm:n-byte-bits))) + (start ,vector-data-bit-offset)) + (declare (type index start ,@(all-lengths))) + ,@(forms) + res))))) ;;;; CONS accessor DERIVE-TYPE optimizers diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index ad9986e..6de64ea 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -529,7 +529,7 @@ ;;;; coercion -(deftransform coerce ((x type) (* *) *) +(deftransform coerce ((x type) (* *) * :node node) (unless (constant-continuation-p type) (give-up-ir1-transform)) (let ((tspec (ir1-transform-specifier-type (continuation-value type)))) @@ -544,8 +544,12 @@ ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) ((csubtypep tspec (specifier-type 'float)) '(%single-float x)) - ((csubtypep tspec (specifier-type 'simple-vector)) - '(coerce-to-simple-vector x)) + ((and (csubtypep tspec (specifier-type 'simple-vector)) + (policy node (< safety 3))) + `(if (simple-vector-p x) + x + (replace (make-array (length x)) x))) + ;; FIXME: other VECTOR types? (t (give-up-ir1-transform))))))) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index ef70526..4f41277 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -207,5 +207,60 @@ ;;; BUG 186, fixed in sbcl-0.7.5.5 (assert (null (ignore-errors (test-fill-typecheck 4097)))) +;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested +;;; result type (BUGs 46a, 46b, 66) +(macrolet ((assert-type-error (form) + `(assert (typep (nth-value 1 (ignore-errors ,form)) + 'type-error)))) + (dolist (type-stub '((simple-vector) + (vector *) + (vector (signed-byte 8)) + (vector (unsigned-byte 16)) + (vector (signed-byte 32)) + (simple-bit-vector))) + (declare (optimize safety)) + (format t "~&~S~%" type-stub) + ;; MAKE-SEQUENCE + (assert (= (length (make-sequence `(,@type-stub) 10)) 10)) + (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10)) + (assert-type-error (make-sequence `(,@type-stub 10) 11)) + ;; COERCE + (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3)) + (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3)) + (assert-type-error (coerce #*111 `(,@type-stub 4))) + ;; CONCATENATE + (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6)) + (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111) + (coerce #(0 0 0 1 1 1) `(,@type-stub)))) + (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6)) + (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111) + (coerce #(0 0 0 1 1 1) `(,@type-stub 6)))) + (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111)) + ;; MERGE + (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6)) + (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>) + (coerce #(1 1 1 0 1 0) `(,@type-stub)))) + (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6)) + (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>) + (coerce #(1 1 1 0 1 0) `(,@type-stub 6)))) + (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>)) + ;; MAP + (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4)) + (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1)) + (coerce #(0 1 1 0) `(,@type-stub)))) + (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))) + 4)) + (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)) + (coerce #(0 1 1 0) `(,@type-stub 4)))) + (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1)))) + ;; some more CONCATENATE tests for strings + (locally + (declare (optimize safety)) + (assert (string= (concatenate 'string "foo" " " "bar") "foo bar")) + (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar")) + (assert-type-error (concatenate '(string 6) "foo" " " "bar")) + (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar")) + (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index c7bc9ab..862f12f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; internal versions off the main CVS branch, it gets hairier, e.g. ;;; "0.pre7.14.flaky4.13".) -"0.7.8.7" +"0.7.8.8" -- 1.7.10.4