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

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.

src/compile.lsp.in

@@ -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"))
 
 ;;;

src/lsp/predlib.lsp

@@ -476,13 +476,7 @@ 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
+  (if (complex-float-feature env)
-  ;; 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)
@@ -491,10 +485,9 @@ and is not adjustable."
             ((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))))
+            (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
+          (and (complex-float-feature env)
                (case upgraded-real
                  (real
-             (logior (canonical-complex-type '(complex single-float))
+                  (logior (canonical-complex-type '(complex single-float) env)
-                     (canonical-complex-type '(complex double-float))
+                          (canonical-complex-type '(complex double-float) env)
-                     (canonical-complex-type '(complex long-float))
+                          (canonical-complex-type '(complex long-float) env)
-                     (canonical-complex-type '(complex rational))))
+                          (canonical-complex-type '(complex rational) env)))
                  (float
-             (logior (canonical-complex-type '(complex single-float))
+                  (logior (canonical-complex-type '(complex single-float) env)
-                     (canonical-complex-type '(complex double-float))
+                          (canonical-complex-type '(complex double-float) env)
-                     (canonical-complex-type '(complex long-float)))))
+                          (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)))