From: William Harold Newman Date: Mon, 23 Sep 2002 16:18:11 +0000 (+0000) Subject: 0.7.7.40: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8ac4c19014a23665e5842d0a989cb9d22d1592ed;p=sbcl.git 0.7.7.40: removed 0.7.7.33 changes (by "patch --reverse" on "cvs diff -D '2002-09-20 16:29 GMT' -D '2002-09-20 16:49 GMT'") because they're too slow. (The patches are basically a nice idea and the performance problems look fixable, but it doesn't look like a few lines of tweaking will fix them. Since I'd like to release 0.7.8 in a few days, I don't want a lot of development in the main tree, and since the patch still unapplies 100% cleanly, this is an appealing way to deal with the problem for now.) (Actually the "cleanly" above doesn't mean that it actually works, because the then-unused COERCE-TO-SIMPLE-VECTOR removed in package-data-list.lisp-expr needs to be restored too. But once C-TO-S-V is restored, it does work.) --- diff --git a/BUGS b/BUGS index 0177a1f..b7c3b53 100644 --- a/BUGS +++ b/BUGS @@ -254,6 +254,14 @@ 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)) @@ -363,6 +371,26 @@ 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 1c4f69a..ca4183e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1006,7 +1006,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "CODE-INSTRUCTIONS" "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUN" "COERCE-TO-LEXENV" "COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING" - "COERCE-TO-VECTOR" + "COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR" "*COLD-INIT-COMPLETE-P*" "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P" diff --git a/src/code/class.lisp b/src/code/class.lisp index 7d9b77d..ffda24a 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1203,8 +1203,6 @@ (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 dfd208d..5d0ffa3 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -27,11 +27,21 @@ (:list '(pop in-object)) (:vector '(aref in-object index)))))))) - (def list-to-vector* (make-sequence type length) + (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) aref :list t) - (def vector-to-vector* (make-sequence type length) - aref :vector 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)) (defun vector-to-list* (object) (let ((result (list nil)) @@ -43,6 +53,24 @@ (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 @@ -52,7 +80,7 @@ ;;; argument type is known. It might be better to do this with ;;; DEFTRANSFORMs, though. (declaim (inline coerce-to-list)) -(declaim (inline coerce-to-vector)) +(declaim (inline coerce-to-simple-string coerce-to-bit-vector 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 @@ -88,11 +116,22 @@ 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)) @@ -106,7 +145,10 @@ (/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)))) + :format-arguments (list object output-type-spec))) + (check-result (result) + #!+high-security (aver (typep result output-type-spec)) + result)) (let ((type (specifier-type output-type-spec))) (cond ((%typep object output-type-spec) @@ -194,12 +236,28 @@ (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)) - (typecase object - (list (list-to-vector* object output-type-spec)) - (vector (vector-to-vector* object output-type-spec)) - (t - (coerce-error)))) + (check-result + (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/interr.lisp b/src/code/interr.lisp index 2ff5f81..0e7cde6 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -448,10 +448,17 @@ (/show0 "about to bind ERROR-NUMBER and ARGUMENTS") (multiple-value-bind (error-number arguments) (sb!vm:internal-error-args alien-context) + + ;; There's a limit to how much error reporting we can usefully + ;; do before initialization is complete, but try to be a little + ;; bit helpful before we die. (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..") (/hexstr error-number) (/show0 "cold/low ARGUMENTS=..") (/hexstr arguments) + (unless *cold-init-complete-p* + (%primitive print "can't recover from error in cold init, halting") + (%primitive sb!c:halt)) (multiple-value-bind (name sb!debug:*stack-top-hint*) (find-interrupted-name) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index f28a76f..baf4088 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -928,6 +928,8 @@ (declare (type (or null function) function) (type real priority) (type pprint-dispatch-table table)) + (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") + (/hexstr type) (if function (if (cons-type-specifier-p type) (setf (gethash (second (second type)) @@ -962,6 +964,7 @@ (delete type (pprint-dispatch-table-entries table) :key #'pprint-dispatch-entry-type :test #'equal)))) + (/show0 "about to return NIL from SET-PPRINT-DISPATCH") nil) ;;;; standard pretty-printing routines diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 0f901a3..9299521 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -149,23 +149,9 @@ ;;; producing a symbol in the current package. (eval-when (:compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest 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))))) + (values (intern (apply #'concatenate + 'string + (mapcar #'string things)))))) ;;; like SYMBOLICATE, but producing keywords (defun keywordicate (&rest things) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 68753f0..9ccda2a 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 tends to make code run faster but be bigger; some benchmarking +;;; It tend 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,28 +36,11 @@ (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc "Return a sequence of the same type as SEQUENCE and the given LENGTH." - (let ((type (gensym "TYPE-"))) - `(if *type-system-initialized* - (let ((,type (specifier-type (type-of ,sequence)))) - (if (csubtypep ,type (specifier-type 'list)) - (make-sequence 'list ,length) - (progn - (aver (csubtypep ,type (specifier-type 'vector))) - (aver (array-type-p ,type)) - (setf (array-type-dimensions ,type) (list '*)) - (make-sequence (type-specifier ,type) ,length)))) - (if (typep ,sequence 'string) - (make-string ,length) - (error "MAKE-SEQUENCE-LIKE on non-STRING too early in cold-init"))))) - -(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))) + `(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))) ) ; EVAL-WHEN @@ -86,6 +69,33 @@ (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) @@ -107,6 +117,22 @@ `(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." @@ -154,42 +180,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) - ;; 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)))))) + (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)))))) ;;;; SUBSEQ ;;;; @@ -246,11 +272,11 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-copy-seq (sequence) +(sb!xc:defmacro vector-copy-seq (sequence type) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (copy (make-sequence-like ,sequence length))) + (copy (make-sequence-of-type ,type length))) ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) @@ -280,7 +306,16 @@ (defun vector-copy-seq* (sequence) (declare (type vector sequence)) - (vector-copy-seq 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))))) ;;;; FILL @@ -463,7 +498,7 @@ (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence ,type length))) + (new-sequence (make-sequence-of-type ,type length))) ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) @@ -562,7 +597,7 @@ (do ((sequences ,sequences (cdr sequences)) (lengths lengths (cdr lengths)) (index 0) - (result (make-sequence ,output-type-spec total-length))) + (result (make-sequence-of-type ,output-type-spec total-length))) ((= index total-length) result) (declare (fixnum index)) (let ((sequence (car sequences))) @@ -585,19 +620,24 @@ ) ; 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." - (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)) + (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)) (t - (bad-sequence-type-error output-type-spec))))) + (apply #'concatenate (result-type-or-lose output-type-spec) sequences)))) ;;; internal frobs ;;; FIXME: These are weird. They're never called anywhere except in @@ -717,7 +757,7 @@ (declare (type index counter)))))) (declare (type index min-len)) (with-map-state sequences - (let ((result (make-sequence output-type-spec min-len)) + (let ((result (make-sequence-of-type output-type-spec min-len)) (index 0)) (declare (type index index)) (loop with updated-map-apply-args @@ -746,8 +786,7 @@ ;;; 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)) - (type (specifier-type result-type))) + (let ((really-fun (%coerce-callable-to-fun function))) ;; 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 @@ -760,21 +799,36 @@ ;; 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))) - (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)) + (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) (%map-to-vector result-type really-fun sequences)) (t - (bad-sequence-type-error result-type))))))) + (apply #'map + (result-type-or-lose result-type t) + really-fun + sequences))))))) (defun map (result-type function first-sequence &rest more-sequences) - (apply #'%map - result-type - function - first-sequence - 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)) ;;; 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 4120a0e..67234e0 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -33,30 +33,14 @@ #!+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. - ;; - ;; 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) + #-sb-xc-host (sb!sys:%primitive + print + (concatenate 'string "/can't /SHOW: " string)) (values)) ;;; Should /SHOW output be suppressed at this point? diff --git a/src/code/sort.lisp b/src/code/sort.lisp index e312715..de92015 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 result-type - (+ length-1 length-2)))) + (result (make-sequence-of-type result-type + (+ length-1 length-2)))) (declare (vector vector-1 vector-2) (fixnum length-1 length-2)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 9792a4b..0ece88a 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -652,12 +652,10 @@ ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. -;;; -;;; FIXME: currently KLUDGEed because of bug 188 +#+nil ; FIXME: currently commented out because of bug 188 (deftransform concatenate ((rtype &rest sequences) (t &rest simple-string) - simple-string - :policy (< safety 3)) + simple-string) (collect ((lets) (forms) (all-lengths) @@ -672,19 +670,16 @@ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset res start ,n-length)) - (forms `(setq start (opaque-identity (+ start ,n-length)))))) + (forms `(setq start (+ start ,n-length))))) `(lambda (rtype ,@(args)) (declare (ignore rtype)) - ;; 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))))) + (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 f41a060..ad9986e 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -544,7 +544,8 @@ ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) ((csubtypep tspec (specifier-type 'float)) '(%single-float x)) - ;; FIXME: VECTOR types? + ((csubtypep tspec (specifier-type 'simple-vector)) + '(coerce-to-simple-vector x)) (t (give-up-ir1-transform))))))) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 4f41277..ef70526 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -207,60 +207,5 @@ ;;; 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 61c7d28..69903f4 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.7.39" +"0.7.7.40"