...based on the type the host object will take in target,
which just needs to follow the same logic our dumper uses.
...fixing which shows the the new FILL transform didn't handle
complex single floats quite right yet.
(values (typep host-object target-type) t))
(t
(values nil t))))
(values (typep host-object target-type) t))
(t
(values nil t))))
- (;; Complexes suffer the same kind of problems as arrays
+ (;; Complexes suffer the same kind of problems as arrays.
+ ;; Our dumping logic is based on contents, however, so
+ ;; reasoning about them should be safe
(and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:complex))
(if (complexp host-object)
(and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:complex))
(if (complexp host-object)
- (warn-and-give-up) ; general-case complexes being way too hard
- (values nil t))) ; but "obviously not a complex" being easy
+ (let ((re (realpart host-object))
+ (im (imagpart host-object)))
+ (if (or (and (eq target-type 'complex)
+ (typep re 'rational) (typep im 'rational))
+ (and (equal target-type '(cl:complex single-float))
+ (typep re 'single-float) (typep im 'single-float))
+ (and (equal target-type '(cl:complex double-float))
+ (typep re 'double-float) (typep im 'double-float)))
+ (values t t)
+ (progn
+ ;; We won't know how to dump it either.
+ (warn "Host complex too complex: ~S" host-object)
+ (warn-and-give-up))))
+ (values nil t)))
;; Some types require translation between the cross-compilation
;; host Common Lisp and the target SBCL.
((target-type-is-in '(classoid))
;; Some types require translation between the cross-compilation
;; host Common Lisp and the target SBCL.
((target-type-is-in '(classoid))
(kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
((member element-type '(character base-char)) :char)
((eq element-type 'single-float) :single-float)
(kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
((member element-type '(character base-char)) :char)
((eq element-type 'single-float) :single-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((eq element-type 'double-float) :double-float)
((eq element-type 'double-float) :double-float)
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ ((equal element-type '(complex single-float))
+ :complex-single-float)
+ (t
+ (aver (integer-type-p element-ctype))
+ :bits)))
;; BASH-VALUE is a word that we can repeatedly smash
;; on the array: for less-than-word sized elements it
;; contains multiple copies of the fill item.
;; BASH-VALUE is a word that we can repeatedly smash
;; on the array: for less-than-word sized elements it
;; contains multiple copies of the fill item.
tmp)
(:single-float
(single-float-bits tmp))
tmp)
(:single-float
(single-float-bits tmp))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(:double-float
(logior (ash (double-float-high-bits tmp) 32)
(:double-float
(logior (ash (double-float-high-bits tmp) 32)
- (double-float-low-bits tmp))))))
+ (double-float-low-bits tmp)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ (logior (ash (single-float-bits (imagpart tmp)) 32)
+ (single-float-bits (realpart tmp)))))))
(res bits))
(loop for i of-type sb!vm:word from n-bits by n-bits
until (= i sb!vm:n-word-bits)
(res bits))
(loop for i of-type sb!vm:word from n-bits by n-bits
until (= i sb!vm:n-word-bits)
`item)
(:single-float
`(single-float-bits item))
`item)
(:single-float
`(single-float-bits item))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(:double-float
`(logior (ash (double-float-high-bits item) 32)
(:double-float
`(logior (ash (double-float-high-bits item) 32)
- (double-float-low-bits item))))))
+ (double-float-low-bits item)))
+ #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+ (:complex-single-float
+ `(logior (ash (single-float-bits (imagpart item)) 32)
+ (single-float-bits (realpart item)))))))
(res bits))
(declare (type sb!vm:word res))
,@(unless (= sb!vm:n-word-bits n-bits)
(res bits))
(declare (type sb!vm:word res))
,@(unless (= sb!vm:n-word-bits n-bits)
(= sb-vm:complex-double-float-widetag
(sb-kernel:widetag-of
(sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
(= sb-vm:complex-double-float-widetag
(sb-kernel:widetag-of
(sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
+
+(with-test (:name :complex-single-float-fill)
+ (assert (every (lambda (x) (= #c(1.0 2.0) x))
+ (funcall
+ (compile nil
+ `(lambda (n x)
+ (make-array (list n)
+ :element-type '(complex single-float)
+ :initial-element x)))
+ 10
+ #c(1.0 2.0)))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)