mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: handle subtypep for cross compilation with mismatching complex float features

Browse source 
This is a bit tricky to solve since UPGRADED-COMPLEX-PART-TYPE and
SUBTYPEP behave differently depending on whether we have complex float
support or not and the behaviour is a special case compared to other
types due to the upgrading of part types that is happening.

What we do now is to add a custom declaration in the environment and
select the behaviour based on a runtime check.
This commit is contained in:
Marius Gerbershagen 2025-11-01 18:05:16 +01:00
parent f099a9082a
commit 4271c7594d
2 changed files with 41 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/compile.lsp.in
View file

@ -82,6 +82,10 @@
#+cross
(let ((*features* '(:cross @LSP_FEATURES@)))
(setf c::*cmp-env-root* (c::register-all-known-types c::*cmp-env-root*))
(setf c::*cmp-env-root* (c::cmp-env-add-declaration :feature
(cons :complex-float
(member :complex-float *features*))
c::*cmp-env-root*))
(c::write-target-info #P"build:target-info.lsp"))
;;;

70
src/lsp/predlib.lsp
View file

@ -476,25 +476,18 @@ and is not adjustable."
answer))))
(defun upgraded-complex-part-type (real-type &optional env)
;; ECL does not have specialized complex types. If we had them, the
;; code would look as follows
;; (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
;; (error "~S is not a valid part type for a complex." real-type))
;; (when (subtypep real-type v)
;; (return v))))
#+complex-float
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'rational env) 'rational)
((subtypep real-type 'single-float env) 'single-float)
((subtypep real-type 'double-float env) 'double-float)
((subtypep real-type 'long-float env) 'long-float)
((subtypep real-type 'float env) 'float)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type)))
#-complex-float
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type))))
(if (complex-float-feature env)
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'rational env) 'rational)
((subtypep real-type 'single-float env) 'single-float)
((subtypep real-type 'double-float env) 'double-float)
((subtypep real-type 'long-float env) 'long-float)
((subtypep real-type 'float env) 'float)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type)))
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type)))))
(defun in-interval-p (x interval)
(declare (si::c-local))
@ -1297,27 +1290,27 @@ if not possible."
;;; sets of objects. TYPEP has a different specification and TYPECASE should use
;;; it. -- jd 2019-04-19
;;;
(defun canonical-complex-type (complex-type)
(defun canonical-complex-type (complex-type env)
(declare (si::c-local))
;; UPGRADE-COMPLEX-PART-TYPE signals condition when REAL-TYPE is not a
;; subtype of REAL.
(destructuring-bind (&optional (real-type 'real)) (rest complex-type)
(when (eq real-type '*)
(setq real-type 'real))
(let* ((upgraded-real (upgraded-complex-part-type real-type))
(let* ((upgraded-real (upgraded-complex-part-type real-type env))
(upgraded-type `(complex ,upgraded-real)))
(or (find-registered-tag upgraded-type)
#+complex-float
(case upgraded-real
(real
(logior (canonical-complex-type '(complex single-float))
(canonical-complex-type '(complex double-float))
(canonical-complex-type '(complex long-float))
(canonical-complex-type '(complex rational))))
(float
(logior (canonical-complex-type '(complex single-float))
(canonical-complex-type '(complex double-float))
(canonical-complex-type '(complex long-float)))))
(and (complex-float-feature env)
(case upgraded-real
(real
(logior (canonical-complex-type '(complex single-float) env)
(canonical-complex-type '(complex double-float) env)
(canonical-complex-type '(complex long-float) env)
(canonical-complex-type '(complex rational) env)))
(float
(logior (canonical-complex-type '(complex single-float) env)
(canonical-complex-type '(complex double-float) env)
(canonical-complex-type '(complex long-float) env)))))
(register-complex-type upgraded-type)))))
(defun register-complex-type (upgraded-type)
@ -1325,6 +1318,17 @@ if not possible."
(let ((tag (new-type-tag)))
(push-new-type upgraded-type tag)))
(defun complex-float-feature (env)
(declare (si::c-local))
(dolist (record (car env))
(when (and (consp record)
(eq (first record) :declare)
(eq (second record) :feature)
(eq (third record) :complex-float))
(return-from complex-float-feature (fourth record))))
#+complex-float t
#-complex-float nil)
;;----------------------------------------------------------------------
;; CONS types. Only (CONS T T) and variants, as well as (CONS NIL *), etc
;; are strictly supported.
@ -1576,7 +1580,7 @@ if not possible."
(RATIO ,@(rest type)))
env))
(COMPLEX
(canonical-complex-type type))
(canonical-complex-type type env))
(CONS (apply #'register-cons-type env (rest type)))
(ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type)) env)
(register-array-type `(SIMPLE-ARRAY ,@(rest type)) env)))