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))
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))
+ => #<ARRAY-TYPE SIMPLE-ARRAY> 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)
"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"
(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)
(: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))
(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
;;; 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
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))
(/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)
(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))))))
(/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)
(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))
(delete type (pprint-dispatch-table-entries table)
:key #'pprint-dispatch-entry-type
:test #'equal))))
+ (/show0 "about to return NIL from SET-PPRINT-DISPATCH")
nil)
\f
;;;; standard pretty-printing routines
;;; 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)
;;;
;;; 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)
(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
(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)
`(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))))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
(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))))))
\f
;;;; SUBSEQ
;;;;
(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)))))
(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)))))
\f
;;;; FILL
(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)
(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)))
) ; EVAL-WHEN
\f
+;;; 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
(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
;;; 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
;; 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
#!+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?
(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))
;;; %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)
(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))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
;; 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)))))))
;;; 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)))))
-\f
;;; success
(quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff