mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-28 07:22:27 -08:00
Code Issues Projects Releases Packages Wiki Activity

coerce: allow coercing to si:complex-*-float

Browse source 
Previously coerce didn't understand these atomic specifiers.
This commit is contained in:
Daniel Kochmański 2019-05-15 14:09:13 +02:00
parent 19526d4032
commit b8c328b558
2 changed files with 28 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

18
src/cmp/cmpopt.lsp
View file

@ -215,13 +215,27 @@
(single-float . (float x 0.0f0))
(double-float . (float x 0.0d0))
(long-float . (float x 0.0l0))
#+complex-float
(si:complex-single-float . (let ((y x))
(declare (:read-only y))
(complex (float (realpart y) 0.0f0)
(float (imagpart y) 0.0f0))))
#+complex-float
(si:complex-double-float . (let ((y x))
(declare (:read-only y))
(complex (float (realpart y) 0.0d0)
(float (imagpart y) 0.0d0))))
#+complex-float
(si:complex-long-float . (let ((y x))
(declare (:read-only y))
(complex (float (realpart y) 0.0l0)
(float (imagpart y) 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))
))
(function . (si::coerce-to-function x))))
(defun expand-coerce (form value type env)
(declare (si::c-local))

12
src/lsp/predlib.lsp
View file

@ -768,6 +768,18 @@ if not possible."
(DOUBLE-FLOAT (float object 0.0D0))
(LONG-FLOAT (float object 0.0L0))
(COMPLEX (complex (realpart object) (imagpart object)))
#+complex-float
(si:complex-single-float
(complex (coerce (realpart object) 'single-float)
(coerce (imagpart object) 'single-float)))
#+complex-float
(si:complex-double-float
(complex (coerce (realpart object) 'double-float)
(coerce (imagpart object) 'double-float)))
#+complex-float
(si:complex-long-float
(complex (coerce (realpart object) 'long-float)
(coerce (imagpart object) 'long-float)))
(FUNCTION (coerce-to-function object))
((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING
#+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)