Commit 299f9fb1 authored by Marius Gerbershagen's avatar Marius Gerbershagen

Merge branch 'fix-complex-typep' into 'develop'

Fix complex typep

Closes #493

See merge request !144
parents 06b8e49d 155ccac2
Pipeline #57672508 passed with stage
......@@ -79,7 +79,7 @@
when (si::type= type a-type)
do (return `(,function-name ,object))))
;; Complex types defined with DEFTYPE.
;; Derived types defined with DEFTYPE.
((and (atom type)
(setq function (si:get-sysprop type 'SI::DEFTYPE-DEFINITION)))
(expand-typep form object `',(funcall function nil) env))
......@@ -90,7 +90,7 @@
;; CONS types. They must be checked _before_ sequence types. We
;; do not produce optimized forms because they can be recursive.
((and (consp type) (eq first 'CONS))
((and (consp type) (eq (first type) 'CONS))
;; The type denotes a known class and we can check it
......@@ -141,13 +141,19 @@
(setf ,var2 (truly-the ,first ,var1))
(AND ,@(expand-in-interval-p var2 rest)))))))
;; Compound COMPLEX types.
((and (eq first 'COMPLEX)
(= (list-length type) 2))
`(and (typep (realpart ,object) ',(second type))
(typep (imagpart ,object) ',(second type))))
;; (SATISFIES predicate)
((and (eq first 'SATISFIES)
(= (list-length type) 2)
(symbolp (setf function (second type))))
`(,function ,object))
;; Complex types with arguments.
;; Derived compound types.
((setf function (si:get-sysprop first 'SI::DEFTYPE-DEFINITION))
(expand-typep form object `',(funcall function rest) env))
......@@ -209,6 +215,9 @@
(single-float . (float x 0.0f0))
(double-float . (float x 0.0d0))
(long-float . (float x 0.0l0))
(complex . (let ((y x))
(declare (:read-only y))
(complex (realpart y) (imagpart y))))
(base-char . (character x))
(character . (character x))
(function . (si::coerce-to-function x))
......@@ -245,15 +254,7 @@
when (eq type a-type)
do (return (subst value 'x template))))
;; FIXME! COMPLEX cannot be in +coercion-table+ because
;; (type= '(complex) '(complex double-float)) == T
((eq type 'COMPLEX)
`(let ((y ,value))
(declare (:read-only y))
(complex (realpart y) (imagpart y))))
;; Complex types defined with DEFTYPE.
;; Derived types defined with DEFTYPE.
((and (atom type)
(setq first (si:get-sysprop type 'SI::DEFTYPE-DEFINITION)))
(expand-coerce form value `',(funcall first nil) env))
......@@ -568,9 +568,10 @@ Returns T if X belongs to TYPE; NIL otherwise."
(and (complexp object)
(or (null i)
;; type specifier may be i.e (complex integer) so we
;; should check both real and imag part (disregarding
;; the fact that both have the same upgraded type).
(and (typep (realpart object) (car i))
;;wfs--should only have to check one.
;;Illegal to mix real and imaginary types!
(typep (imagpart object) (car i))))
(SEQUENCE (or (listp object) (vectorp object)))
......@@ -1172,31 +1173,21 @@ if not possible."
;; bring the type to canonical form, which is a union of all specialized
;; complex types that can store an element of the corresponding type.
;; Don't be tempted to do "better" than that. CANONICAL-COMPLEX-TYPE
;; yields results for use of SUBTYPEP which has clearly specified to
;; return true when: T1 is a subtype of T2 or when the upgraded type
;; specifiers refer to the same sets of objects. TYPEP has a different
;; specification and TYPECASE should use it. -- jd 2019-04-19
(defun canonical-complex-type (real-type)
(declare (si::c-local))
(case real-type
((#+short-float SHORT-FLOAT
#+long-float LONG-FLOAT)
(let ((tag (new-type-tag)))
(push-type `(COMPLEX ,real-type) tag)))
((FLOAT) (canonical-type '(OR
#+short-float (COMPLEX SHORT-FLOAT)
#+long-float (COMPLEX LONG-FLOAT))))
((* NIL REAL) (canonical-type
#+short-float (COMPLEX SHORT-FLOAT)
#+long-float (COMPLEX LONG-FLOAT)
(otherwise (canonical-complex-type (upgraded-complex-part-type real-type)))))
;; UPGRADE-COMPLEX-PART-TYPE signals condition when REAL-TYPE is not
;; a subtype of REAL.
(let ((type (if (eq real-type '*)
`(complex real)
`(complex ,(upgraded-complex-part-type real-type)))))
(or (find-registered-tag type)
(let ((tag (new-type-tag)))
(push-type type tag)))))
;; CONS types. Only (CONS T T) and variants, as well as (CONS NIL *), etc
......@@ -1524,9 +1515,17 @@ if not possible."
(declare (si::c-local))
(when (eq t1 t2)
(return-from fast-type= (values t t)))
(let* ((tag1 (safe-canonical-type t1))
(tag2 (safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(let ((tag1 (safe-canonical-type t1))
(tag2 (safe-canonical-type t2))
(tag3 (safe-canonical-type 'complex)))
;; FAST-TYPE= can't rely on the CANONICAL-TYPE in case of complex
;; numbers which have an exceptional behavior define for TYPEP not
;; being consistent with SUBTYPEP. -- jd 2019-04-19
(cond ((and (numberp tag1)
(numberp tag2)
(/= tag2 tag3))
;; We must call safe-canonical-type again because one of
;; the calls above could have called UPDATE-TYPES.
(values (= (safe-canonical-type t1) (safe-canonical-type t2))
......@@ -1437,3 +1437,91 @@
(compile '(setf foo))
(is (and fun (null warn) (null err))
"compile: (setf foo) is a valid function name."))))
;;; Date 2019-04-02
;;; URL:
;;; Fixed: 177ad215ea91524756a00b24436273b065628081
;;; Description
;;; TYPECASE doesn't distinguish between different complex types
;;; when compiled.
(ext:with-clean-symbols (xxx)
(test cmp.0070.cmp-typecase-complex
(defun xxx ()
(let ((ci #c(5 7))
(cs #c(1.0s0 1.0s0))
(cd #c(1.0d0 1.0d0)))
(list (typecase ci
((complex integer) 'ci)
((complex single-float) 'csf)
((complex double-float) 'cdf))
(typecase cs
((complex integer) 'ci)
((complex single-float) 'csf)
((complex double-float) 'cdf))
(typecase cs
((complex integer) 'ci)
((complex double-float) 'cdf)
((complex single-float) 'csf))
(typecase cd
((complex integer) 'ci)
((complex single-float) 'csf)
((complex double-float) 'cdf))
(typecase cd
((complex integer) 'ci)
((complex double-float) 'cdf)
((complex single-float) 'csf))
(typecase ci
((complex (integer 0 3)) 'invalid)
((complex (integer 0 6)) 'invalid)
((complex (integer 4 8)) 'ci)
((complex integer) 'overboard)))))
(is-equal (xxx) '(ci csf csf cdf cdf ci))
(compile 'xxx)
(is-equal (xxx) '(ci csf csf cdf cdf ci))))
;;; Date 2019-04-19
;;; URL:
;;; Fixed: a73df694
;;; Description
;;; SUBTYPEP and TYPEP are not consistent for COMPLEX type in ANSI
;;; spec. SUBTYPEP pursues the internal representation (with
;;; UPGRADED-COMPLEX-PART-TYPE) while TYPEP goes after the type of
;;; the complex number parts to match the typespec. Problem was
;;; exhibited in compiled code. These are just a few examples which
;;; explore ECL potential failures. Test which goes more
;;; systematically across more types is defined in ansi-tests under
(test cmp.0071.cmp-typep-subtypep
(is (typep #c(1.0 2.0) '(complex single-float)))
(is (typep #c(1 2) '(complex fixnum)))
(is (typep #c(1 2) '(complex (integer 0 8))))
(is (not (typep #c(1.0 2.0) '(complex double-float))))
(is (not (typep #c(1 2) '(complex (integer 0 1)))))
(is (not (typep #c(1/2 2/3) '(complex (integer 0 1)))))
#-complex-float (is (subtypep '(complex single-float) '(complex double-float)))
#-complex-float (is (subtypep '(complex double-float) '(complex single-float)))
#-complex-float (is (subtypep '(complex double-float) '(complex float)))
#+complex-float (is (not (subtypep '(complex single-float) '(complex double-float))))
#+complex-float (is (not (subtypep '(complex double-float) '(complex single-float))))
(is (subtypep '(complex double-float) '(complex float)))
(is (subtypep '(complex fixnum) '(complex integer)))
(is (subtypep '(complex integer) '(complex fixnum)))
(is (subtypep '(complex ratio) '(complex fixnum)))
(is (subtypep '(complex bit) '(complex ratio)))
;; this should be true even if single-float has a specialized
;; representation because of the first rule:
;; (subtypep (complex t1) (complex t2)) is T, T when
;; 1. (subtypep t1 t2) is T, T or
;; 2. (equal (ucpt t1) (ucpt t2))
(is (subtypep '(complex single-float) '(complex real)))
(is (and (subtypep '(complex bit) '(complex double-float))
(subtypep '(complex double-float) '(complex bit))))
(is (and (not (subtypep '(complex bit) '(complex double-float)))
(not (subtypep '(complex double-float) '(complex bit) )))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment