Merge branch 'cross-compilation' into 'develop'

Cross-compilation of user code

See merge request embeddable-common-lisp/ecl!358

Makefile.in

@@ -117,9 +117,15 @@ realclean: distclean
 check:
 	cd build && $(MAKE) check TESTS="$(TESTS)"
 
+cross-check:
+	cd build && $(MAKE) cross-check TESTS="$(TESTS)"
+
 ansi-test:
 	cd build && $(MAKE) ansi-test
 
+cross-ansi-test:
+	cd build && $(MAKE) cross-ansi-test
+
 # ==================== Various means of distribution ====================
 
 TAR_DIR=ecl-$(VERSION)

contrib/bytecmp/bytecmp.lsp

@@ -125,13 +125,18 @@
     (si::load-bytecodes output-file *compile-verbose* *load-print* :default))
   (values (truename output-file) nil nil))
 
+(defun bc-do-compilation-unit (closure &key override)
+  (declare (ignore override))
+  (funcall closure))
+
 (defun install-bytecodes-compiler ()
   (ext::package-lock (find-package :cl) nil)
   (pushnew :ecl-bytecmp *features*)
   (setf (fdefinition 'disassemble) #'bc-disassemble
         (fdefinition 'compile) #'bc-compile
         (fdefinition 'compile-file) #'bc-compile-file
-        (fdefinition 'compile-file-pathname) #'bc-compile-file-pathname)
+        (fdefinition 'compile-file-pathname) #'bc-compile-file-pathname
+        (fdefinition 'si::do-compilation-unit) #'bc-do-compilation-unit)
   (ext::package-lock (find-package :cl) t))
 
 (defun install-c-compiler ()

src/Makefile.in

@@ -201,9 +201,12 @@ install:
 	  $(INSTALL_DATA) ecl/$$i $(DESTDIR)$(includedir)/ecl/$$i; \
 	done
 	$(INSTALL_SCRIPT) bin/ecl-config $(DESTDIR)$(bindir)
-	for i in build-stamp help.doc TAGS ; do \
+	for i in build-stamp help.doc TAGS; do \
 	  $(INSTALL_DATA) $$i $(DESTDIR)$(ecldir); \
 	done
+	if [ -f target-info.lsp ]; then \
+	  $(INSTALL_DATA) target-info.lsp $(DESTDIR)$(ecldir); \
+	fi
 	for i in $(LSP_LIBRARIES) $(LIBRARIES); do \
 	  if test -s $$i ; then \
 	   if echo $$i | grep dll; then \
@@ -273,9 +276,15 @@ test_changes:
 check:
 	cd tests && $(MAKE) clean && $(MAKE) check TESTS="$(TESTS)"
 
+cross-check:
+	cd tests && $(MAKE) clean && $(MAKE) cross-check TESTS="$(TESTS)"
+
 ansi-test:
 	cd tests && $(MAKE) clean && $(MAKE) ansi-test
 
+cross-ansi-test:
+	cd tests && $(MAKE) clean && $(MAKE) cross-ansi-test
+
 #
 # Rebuild ECL using its own image and compare. Does not work
 # right now.

src/aclocal.m4

@@ -252,6 +252,7 @@ AC_SUBST(ARCHITECTURE)dnl Type of processor for which this is compiled
 AC_SUBST(SOFTWARE_TYPE)dnl Type of operating system
 AC_SUBST(SOFTWARE_VERSION)dnl	 Version number of operating system
 AC_SUBST(MACHINE_VERSION)dnl	 Version of the machine
+AC_SUBST(TARGET_IDENTIFIER)dnl Target identifier for cross compilation
 
 AC_SUBST(ECL_LDRPATH)dnl Sometimes the path for finding DLLs must be hardcoded.
 AC_SUBST(LIBPREFIX)dnl	Name components of a statically linked library
@@ -446,8 +447,10 @@ case "${host_os}" in
                 ECL_ADD_FEATURE([win32])
                 ECL_ADD_FEATURE([windows])
                 if test "x$host_cpu" = "xx86_64" ; then
-		   ECL_ADD_FEATURE([win64])
+                  ECL_ADD_FEATURE([win64])
                 fi
+                AC_CHECK_TOOL([WINDRES],[windres]) # set variable WINDRES to appropriate `windres' program
+                AC_SUBST(WINDRES)
                 ;;
         darwin*)
                 thehost='darwin'
@@ -611,6 +614,7 @@ AC_MSG_CHECKING(for required libraries)
 AC_MSG_RESULT([${clibs}])
 AC_MSG_CHECKING(for architecture)
 ARCHITECTURE=`echo "${host_cpu}" | tr a-z A-Z` # i386 -> I386
+TARGET_IDENTIFIER="${host}"
 AC_MSG_RESULT([${ARCHITECTURE}])
 AC_MSG_CHECKING(for software type)
 SOFTWARE_TYPE="$thehost"

src/bare.lsp.in

@@ -47,6 +47,8 @@
 ;;;
 
 (when (member "CROSS" *features* :test #'string-equal)
+  ;; List of target dependent constants. Must be kept in sync with the
+  ;; cross compilation setup in compile.lsp.in
   (sys:*make-constant 'most-negative-fixnum (parse-integer "@CL_FIXNUM_MIN@" :junk-allowed t))
   (sys:*make-constant 'most-positive-fixnum (parse-integer "@CL_FIXNUM_MAX@" :junk-allowed t))
   (sys:*make-constant 'cl-fixnum-bits @CL_FIXNUM_BITS@)

src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp

@@ -103,7 +103,8 @@ the environment variable TMPDIR to a different value." template))
 #+msvc
 (defun linker-cc (o-pathname object-files &key
                   (type :program)
-                  (ld-flags (split-program-options (if #-dlopen nil #+dlopen (eq type :program)
+                  (ld-flags (split-program-options (if (and (member :dlopen *features*)
+                                                            (eq type :program))
                                                        *ld-program-flags*
                                                        *ld-flags*)))
                   (ld-libs (split-program-options *ld-libs*)))
@@ -128,7 +129,8 @@ the environment variable TMPDIR to a different value." template))
 #-msvc
 (defun linker-cc (o-pathname object-files &key
                   (type :program)
-                  (ld-flags (split-program-options (if #-dlopen nil #+dlopen (eq type :program)
+                  (ld-flags (split-program-options (if (and (member :dlopen *features*)
+                                                            (eq type :program))
                                                        *ld-program-flags*
                                                        *ld-flags*)))
                   (ld-libs (split-program-options *ld-libs*)))
@@ -279,9 +281,10 @@ the environment variable TMPDIR to a different value." template))
 (defun ecl-library-directory ()
   "Finds the directory in which the ECL core library was installed."
   (cond ((and *ecl-library-directory*
-              (probe-file (merge-pathnames (compile-file-pathname "ecl" :type
+              (probe-file (merge-pathnames (compile-file-pathname
-                                            #+dlopen :shared-library
+                                            "ecl" :type (if (member :dlopen *features*)
-                                            #-dlopen :static-library)
+                                                            :shared-library
+                                                            :static-library))
                                            *ecl-library-directory*)))
          *ecl-library-directory*)
         ((probe-file "SYS:BUILD-STAMP")
@@ -360,7 +363,6 @@ filesystem or in the database of ASDF modules."
 
 ;;; Target-specific invocations.
 
-#+dlopen
 (defun shared-cc (o-pathname object-files)
   (let ((ld-flags (split-program-options *ld-shared-flags*))
         (ld-libs (split-program-options *ld-libs*)))
@@ -375,12 +377,11 @@ filesystem or in the database of ASDF modules."
                     (list (concatenate 'string "/LIBPATH:"
                                        (ecl-library-directory))
                           (concatenate 'string "/IMPLIB:" implib)))))
-    #+mingw32
+    (when (member :mingw32 *features*)
-    (setf ld-flags (list* "-shared" ld-flags))
+      (setf ld-flags (list* "-shared" ld-flags)))
     (linker-cc o-pathname object-files :type :dll
                :ld-flags ld-flags :ld-libs ld-libs)))
 
-#+dlopen
 (defun bundle-cc (o-pathname init-name object-files)
   (declare (ignore init-name))
   (let ((ld-flags (split-program-options *ld-bundle-flags*))
@@ -399,8 +400,8 @@ filesystem or in the database of ASDF modules."
                      (concatenate 'string "/LIBPATH:"
                                   (ecl-library-directory))
                      (concatenate 'string "/IMPLIB:" implib)))))
-    #+mingw32
+    (when (member :mingw32 *features*)
-    (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags))
+      (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags)))
     (linker-cc o-pathname object-files :type :fasl
                                        :ld-flags ld-flags :ld-libs ld-libs)))
 
@@ -508,7 +509,6 @@ extern int
 }
 ")
 
-#+:win32
 (defconstant +lisp-program-winmain+ "
 #include <windows.h>
 int
@@ -570,7 +570,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
                   (main-name nil)
                   (prologue-code "")
                   (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T)))
-                  #+:win32 (system :console)
+                  (system :console)
                   &aux
                     (*suppress-compiler-messages* (or *suppress-compiler-messages*
                                                       (not *compile-verbose*)))
@@ -678,10 +678,9 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
          ;; we don't need wrapper in the program, we have main for that
                                         ;(format c-file +lisp-init-wrapper+ wrap-name init-name)
          (format c-file
-                 #+:win32 (ecase system
+                 (ecase system
-                            (:console +lisp-program-main+)
+                   (:console +lisp-program-main+)
-                            (:windows +lisp-program-winmain+))
+                   (:windows +lisp-program-winmain+))
-                 #-:win32 +lisp-program-main+
                  prologue-code init-name epilogue-code)
          (close c-file)
          (compiler-cc c-name o-name)
@@ -698,7 +697,6 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
          (compiler-cc c-name o-name)
          (when (probe-file output-name) (delete-file output-name))
          (linker-ar output-name o-name ld-libs))
-        #+dlopen
         (:shared-library
          (format c-file +lisp-program-init+
                  init-name init-tag prologue-code submodules epilogue-code)
@@ -710,7 +708,6 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
          (compiler-cc c-name o-name)
          (shared-cc output-name (append ld-flags (list o-name)
                                         ld-libs)))
-        #+dlopen
         (:fasl
          (format c-file +lisp-program-init+ init-name init-tag prologue-code
                  submodules epilogue-code)
@@ -735,7 +732,6 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
   (apply #'builder :static-library args))
 
 (defun build-shared-library (&rest args)
-  #-dlopen
+  (if (member :dlopen *features*)
-  (error "Dynamically loadable libraries not supported in this system.")
+      (apply #'builder :shared-library args)
-  #+dlopen
+      (error "Dynamically loadable libraries not supported in this system.")))
-  (apply #'builder :shared-library args))

src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp

@@ -88,7 +88,7 @@
                              :arg-types arg-types
                              :exact-return-type exact-return-type
                              :multiple-values multiple-values
-                             ;; :side-effects (not (si:get-sysprop name 'no-side-effects))
+                             ;; :side-effects (function-may-have-side-effects name)
                              :one-liner one-liner
                              :expansion expansion)))
     (push inline-info (gethash (list name safety) *inline-information*))))

src/cmp/cmpbackend-cxx/cmpc-mach.lsp

@@ -102,9 +102,9 @@
     (:float              single-float             "float"                "ecl_make_single_float"             "ecl_to_float"              "ecl_single_float")
     (:double             double-float             "double"               "ecl_make_double_float"             "ecl_to_double"             "ecl_double_float")
     (:long-double        long-float               "long double"          "ecl_make_long_float"               "ecl_to_long_double"        "ecl_long_float")
-    (:csfloat            si::complex-single-float "_Complex float"       "ecl_make_csfloat"                  "ecl_to_csfloat"            "ecl_csfloat")
+    (:csfloat            (complex single-float)   "_Complex float"       "ecl_make_csfloat"                  "ecl_to_csfloat"            "ecl_csfloat")
-    (:cdfloat            si::complex-double-float "_Complex double"      "ecl_make_cdfloat"                  "ecl_to_cdfloat"            "ecl_cdfloat")
+    (:cdfloat            (complex double-float)   "_Complex double"      "ecl_make_cdfloat"                  "ecl_to_cdfloat"            "ecl_cdfloat")
-    (:clfloat            si::complex-long-float   "_Complex long double" "ecl_make_clfloat"                  "ecl_to_clfloat"            "ecl_clfloat")
+    (:clfloat            (complex long-float)     "_Complex long double" "ecl_make_clfloat"                  "ecl_to_clfloat"            "ecl_clfloat")
     (:unsigned-char      base-char                "unsigned char"        "ECL_CODE_CHAR"                     "ecl_base_char_code"        "ECL_CHAR_CODE")
     (:char               base-char                "char"                 "ECL_CODE_CHAR"                     "ecl_base_char_code"        "ECL_CHAR_CODE")
     (:wchar              character                "ecl_character"        "ECL_CODE_CHAR"                     "ecl_char_code"             "ECL_CHAR_CODE")

src/cmp/cmpbackend-cxx/cmpc-util.lsp

@@ -12,6 +12,14 @@
 (defvar *emitted-functions* nil)
 (defvar *inline-information* nil)
 
+(defconfig *c-compatible-variadic-dispatch*
+    #+c-compatible-variadic-dispatch t
+    #-c-compatible-variadic-dispatch nil)
+
+(defconfig *complex-float*
+    #+complex-float t
+    #-complex-float nil)
+
 ;;; Compiled code uses the following kinds of variables:
 ;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
 ;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)

src/cmp/cmpbackend-cxx/cmppass2-data.lsp

@@ -59,19 +59,18 @@
 (defun data-c-dump (filename)
   (labels ((produce-strings ()
              ;; Only Windows has a size limit in the strings it creates.
-             #-windows
+             (if (member :windows *features*)
-             (let ((s (data-dump-array)))
+                 (loop with string = (data-dump-array)
-               (when (plusp (length s))
+                       with max-string-size = 65530
-                 (list s)))
+                       with l = (length string)
-             #+windows
+                       for i from 0 below l by max-string-size
-             (loop with string = (data-dump-array)
+                       for this-l = (min (- l i) max-string-size)
-                   with max-string-size = 65530
+                       collect (make-array this-l :displaced-to string
-                   with l = (length string)
+                                           :element-type (array-element-type string)
-                   for i from 0 below l by max-string-size
+                                           :displaced-index-offset i))
-                   for this-l = (min (- l i) max-string-size)
+                 (let ((s (data-dump-array)))
-                   collect (make-array this-l :displaced-to string
+                   (when (plusp (length s))
-                                              :element-type (array-element-type string)
+                     (list s)))))
-                                              :displaced-index-offset i)))
            (output-one-c-string (name string stream)
              (let* ((*wt-string-size* 0)
                     (*wt-data-column* 80)
@@ -176,21 +175,18 @@
             "ecl_def_ct_complex(~A,&~A_data,&~A_data,static,const);"
             name name-real name-imag)))
 
-#+complex-float
 (defun static-csfloat-builder (name value stream)
   (let* ((*read-default-float-format* 'single-float)
          (*print-readably* t))
     (format stream "ecl_def_ct_csfloat(~A,(~S + I*~S),static,const);"
             name (realpart value) (imagpart value) stream)))
 
-#+complex-float
 (defun static-cdfloat-builder (name value stream)
   (let* ((*read-default-float-format* 'double-float)
          (*print-readably* t))
     (format stream "ecl_def_ct_cdfloat(~A,(~S + I*~S),static,const);"
             name (realpart value) (imagpart value) stream)))
 
-#+complex-float
 (defun static-clfloat-builder (name value stream)
   (let* ((*read-default-float-format* 'long-float)
          (*print-readably* t))
@@ -220,15 +216,16 @@
     (long-float (and (not (ext:float-nan-p object))
                      (not (ext:float-infinity-p object))
                      #'static-long-float-builder))
-    #+complex-float
+    (complex
-    (si:complex-single-float #'static-csfloat-builder)
+     (when (and (static-constant-expression (realpart object))
-    #+complex-float
+                (static-constant-expression (imagpart object)))
-    (si:complex-double-float #'static-cdfloat-builder)
+       (if *complex-float*
-    #+complex-float
+           (typecase (realpart object)
-    (si:complex-long-float #'static-clfloat-builder)
+             (single-float #'static-csfloat-builder)
-    (complex (and (static-constant-expression (realpart object))
+             (double-float #'static-cdfloat-builder)
-                  (static-constant-expression (imagpart object))
+             (long-float #'static-clfloat-builder)
-                  #'static-complex-builder))
+             (t #'static-complex-builder))
+           #'static-complex-builder)))
     #+sse2
     (ext:sse-pack #'static-sse-pack-builder)
     (t nil)))
@@ -401,7 +398,8 @@
     ((typep value 'character *cmp-env*)       (wt-character value vv))
     ((typep value 'float *cmp-env*)           (wt-number value vv))
     ((typep value '(complex float) *cmp-env*) (wt-number value vv))
-    (t (baboon "wt-vv-value: ~s is not an immediate value, but has no VV index~%" value))))
+    (t (baboon :format-control "wt-vv-value: ~s is not an immediate value, but has no VV index~%"
+               :format-arguments (list value)))))
 
 (defun wt-vv (vv-loc)
   (setf (vv-used-p vv-loc) t)

src/cmp/cmpbackend-cxx/cmppass2-loc.lsp

@@ -282,7 +282,7 @@
            ((eq loc-host-type :object)
             ;; We relax the check a bit, because it is valid in C to coerce
             ;; between COMPLEX floats of different types.
-            (ensure-valid-object-type 'SI:COMPLEX-FLOAT)
+            (ensure-valid-object-type '(COMPLEX FLOAT))
             (wt-from-object-conversion dest-type loc-type dest-host-type loc))
            (t
             (coercion-error))))

src/cmp/cmpbackend-cxx/cmppass2-top.lsp

@@ -358,10 +358,8 @@
 (defun fun-c-compatible-variadic-signature (fun)
   ;; Returns true if we need to generate a signature of the form
   ;; `cl_object f(cl_narg narg, ...)`
-  #-c-compatible-variadic-dispatch
+  (and *c-compatible-variadic-dispatch*
-  nil
+       (fun-needs-narg fun)
-  #+c-compatible-variadic-dispatch
-  (and (fun-needs-narg fun)
        ;; local functions or lexical closures are never called via a
        ;; function pointer
        (not (eq (fun-closure fun) 'LEXICAL))
@@ -404,25 +402,24 @@
       (t3function-header fun
                          (fun-variadic-entrypoint-cfun fun)
                          t
-                         #+c-compatible-variadic-dispatch t))
+                         *c-compatible-variadic-dispatch*))
     (wt-nl-open-brace)
     (wt-maybe-check-num-arguments t
                                   (fun-minarg fun)
                                   (fun-maxarg fun)
                                   (fun-name fun))
-    #-c-compatible-variadic-dispatch
+    (if (not *c-compatible-variadic-dispatch*)
-    (wt-return (fun-required-lcls fun))
+        (wt-return (fun-required-lcls fun))
-    #+c-compatible-variadic-dispatch
+        (let ((maxargs (min (fun-maxarg fun) (1+ si:c-arguments-limit))))
-    (let ((maxargs (min (fun-maxarg fun) (1+ si:c-arguments-limit))))
+          (when (plusp maxargs)
-      (when (plusp maxargs)
+            (wt-nl "cl_object x[" maxargs "];")
-        (wt-nl "cl_object x[" maxargs "];")
+            (wt-nl "va_list args; va_start(args,narg);")
-        (wt-nl "va_list args; va_start(args,narg);")
+            (loop for i below maxargs
-        (loop for i below maxargs
+                  do (wt-nl "x[" i "] = ") (wt-coerce-loc :object 'VA-ARG) (wt ";"))
-              do (wt-nl "x[" i "] = ") (wt-coerce-loc :object 'VA-ARG) (wt ";"))
+            (wt-nl "va_end(args);"))
-        (wt-nl "va_end(args);"))
+          (let ((args (loop for i below maxargs
-      (let ((args (loop for i below maxargs
+                            collect (concatenate 'string "x[" (write-to-string i) "]"))))
-                        collect (concatenate 'string "x[" (write-to-string i) "]"))))
+            (wt-return args))))))
-        (wt-return args)))))
 
 (defun fun-fixed-narg-main-entrypoint (fun)
   "Number of fixed arguments for fun. If both variadic and ordinary
@@ -430,8 +427,8 @@ entrypoints exist, return the number of fixed arguments for the
 variadic entrypoint. This may differ from the number of required
 parameters of the corresponding Lisp function if we are generating a C
 compatible variadic signature."
-  #+c-compatible-variadic-dispatch
+  (when (and *c-compatible-variadic-dispatch*
-  (when (or (fun-variadic-entrypoint fun) (fun-c-compatible-variadic-signature fun))
+             (or (fun-variadic-entrypoint fun) (fun-c-compatible-variadic-signature fun)))
     (return-from fun-fixed-narg-main-entrypoint 0))
   (min (fun-minarg fun) si:c-arguments-limit))
 

src/cmp/cmpbackend-cxx/cmppass2-var.lsp

@@ -32,9 +32,9 @@
                 (:float . "_ecl_float_loc")
                 (:double . "_ecl_double_loc")
                 (:long-double . "_ecl_long_double_loc")
-                #+complex-float (:csfloat . "_ecl_csfloat_loc")
+                (:csfloat . "_ecl_csfloat_loc")
-                #+complex-float (:cdfloat . "_ecl_cdfloat_loc")
+                (:cdfloat . "_ecl_cdfloat_loc")
-                #+complex-float (:clfloat . "_ecl_clfloat_loc")
+                (:clfloat . "_ecl_clfloat_loc")
                 #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
                 #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
                 #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")

src/cmp/cmpdefs.lsp

@@ -10,69 +10,83 @@
 
 (in-package "COMPILER")
 
+(defvar *config-options* '(*features*))
+
+(defmacro defconfig (name value &optional docstring)
+  "Define a configuration option. Like DEFVAR, but records the variable
+for cross-compilation."
+  `(progn
+     ,(if docstring
+          `(defvar ,name ,value ,docstring)
+          `(defvar ,name ,value))
+     (pushnew ',name *config-options*)))
+
 ;;; This is copied into each .h file generated, EXCEPT for system-p calls.
 ;;; The constant string *include-string* is the content of file "ecl.h".
 ;;; Here we use just a placeholder: it will be replaced with sed.
-(defvar *cmpinclude* "<ecl/ecl-cmp.h>")
+(defconfig *cmpinclude* "<ecl/ecl-cmp.h>")
 
-(defvar *cc* "@ECL_CC@"
+(defconfig *cc* "@ECL_CC@"
-"This variable controls how the C compiler is invoked by ECL.
+  "This variable controls how the C compiler is invoked by ECL.
 The default value is \"cc -I. -I/usr/local/include/\".
 The second -I option names the directory where the file ECL.h has been installed.
 One can set the variable appropriately adding for instance flags which the 
 C compiler may need to exploit special hardware features (e.g. a floating point
 coprocessor).")
 
-(defvar *ld* "@ECL_CC@"
+(defconfig *ld* "@ECL_CC@"
-"This variable controls the linker which is used by ECL.")
+  "This variable controls the linker which is used by ECL.")
 
-(defvar *ranlib* "@RANLIB@"
+(defconfig *ranlib* "@RANLIB@"
   "Name of the `ranlib' program on the hosting platform.")
 
-(defvar *ar* "@AR@"
+(defconfig *ar* "@AR@"
   "Name of the `AR' program on the hosting platform.")
 
-(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@")
+(defconfig *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@")
 
-(defvar *cc-optimize* #-msvc "-O2"
+(defconfig *cc-optimize* #-msvc "-O2"
-                      #+msvc "@CFLAGS_OPTIMIZE@")
+           #+msvc "@CFLAGS_OPTIMIZE@")
 
-(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@[~S~]~{ '~A'~} ~A"
+(defconfig *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@[~S~]~{ '~A'~} ~A"
-                    #+msvc "~A -Fe~S~* ~{~S ~} ~@[~S~]~{ '~A'~} ~A")
+           #+msvc "~A -Fe~S~* ~{~S ~} ~@[~S~]~{ '~A'~} ~A")
 
-(defvar *cc-format* (cond ((member :msvc *features*)
+(defconfig *cc-format* (cond ((member :msvc *features*)
-			   "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")
+			                     "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")
-			  ((member :nacl *features*) ;; pnacl-clang doesn't support -w
+			                    ((member :nacl *features*) ;; pnacl-clang doesn't support -w
-			   "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -c \"~A\" -o \"~A\"~{ '~A'~}")
+			                     "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -c \"~A\" -o \"~A\"~{ '~A'~}")
-			  (t
+			                    (t
-			   "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")))
+			                     "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")))
 
-(defvar *ld-flags* "@LDFLAGS@")
+(defconfig *ld-flags* "@LDFLAGS@")
 #-dlopen
-(defvar *ld-libs* "-lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@")
+(defconfig *ld-libs* "-lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@")
 #+dlopen
-(defvar *ld-libs* #-msvc "-lecl @FASL_LIBS@ @LIBS@"
+(defconfig *ld-libs* #-msvc "-lecl @FASL_LIBS@ @LIBS@"
-                  #+msvc "ecl.lib @CLIBS@")
+           #+msvc "ecl.lib @CLIBS@")
-#+dlopen
+(defconfig *ld-shared-flags* #+dlopen "@SHARED_LDFLAGS@ @LDFLAGS@")
-(defvar *ld-shared-flags* "@SHARED_LDFLAGS@ @LDFLAGS@")
+(defconfig *ld-bundle-flags* #+dlopen "@BUNDLE_LDFLAGS@ @LDFLAGS@")
-#+dlopen
+(defconfig *ld-program-flags* "@PROGRAM_LDFLAGS@ @LDFLAGS@")
-(defvar *ld-bundle-flags* "@BUNDLE_LDFLAGS@ @LDFLAGS@")
-(defvar *ld-program-flags* "@PROGRAM_LDFLAGS@ @LDFLAGS@")
 
-(defvar +shared-library-prefix+ "@SHAREDPREFIX@")
+(defconfig +shared-library-prefix+ "@SHAREDPREFIX@")
-(defvar +shared-library-extension+ "@SHAREDEXT@")
+(defconfig +shared-library-extension+ "@SHAREDEXT@")
-(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
+(defconfig +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
-(defvar +static-library-prefix+ "@LIBPREFIX@")
+(defconfig +static-library-prefix+ "@LIBPREFIX@")
-(defvar +static-library-extension+ "@LIBEXT@")
+(defconfig +static-library-extension+ "@LIBEXT@")
-(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
+(defconfig +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
-(defvar +object-file-extension+ "@OBJEXT@")
+(defconfig +object-file-extension+ "@OBJEXT@")
-(defvar +executable-file-format+ "~a@EXEEXT@")
+(defconfig +executable-file-format+ "~a@EXEEXT@")
 
-(defvar *ecl-include-directory* "@includedir\@/")
+(defconfig *ecl-include-directory* "@includedir\@/")
-(defvar *ecl-library-directory* "@libdir\@/")
+(defconfig *ecl-library-directory* "@libdir\@/")
-(defvar *ecl-data-directory* "@ecldir\@/")
+(defconfig *ecl-data-directory* "@ecldir\@/")
 
-(defvar *ld-rpath*
+(defconfig *ld-rpath*
-  (let ((x "@ECL_LDRPATH@"))
+    (let ((x "@ECL_LDRPATH@"))
-    (and (plusp (length x))
+      (and (plusp (length x))
-         (format nil x *ecl-library-directory*))))
+           (format nil x *ecl-library-directory*))))
+
+(defconfig *target-architecture* "@ARCHITECTURE@")
+(defconfig *target-software-type* "@SOFTWARE_TYPE@")
+(defconfig *target-lisp-implementation-version* "@PACKAGE_VERSION@")
+(defconfig *target-identifier* "@TARGET_IDENTIFIER@")

src/cmp/cmpenv-api.lsp

@@ -67,13 +67,15 @@ that are susceptible to be changed by PROCLAIM."
         (cmp-env-functions env))
   env)
 
-(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
+(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*) force)
   (cmp-env-register-symbol-macro-function name
                                           #'(lambda (whole env) (declare (ignore env whole)) form)
-                                          env))
+                                          env
+                                          force))
 
-(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*))
+(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*) force)
-  (when (or (constant-variable-p name) (special-variable-p name))
+  (when (and (not force)
+             (or (constant-variable-p name) (special-variable-p name)))
     (cmperr "Cannot bind the special or constant variable ~A with symbol-macrolet." name))
   (push (list name 'si:symbol-macro function)
         (cmp-env-variables env))
@@ -104,6 +106,18 @@ that are susceptible to be changed by PROCLAIM."
     (setf env (cmp-env-register-type (car def) (cdr def) env)))
   env)
 
+(defun register-all-known-types (&optional (env *cmp-env*))
+  ;; Used during cross-compilation in compile.lsp.in to populate the
+  ;; lexical environment with type definitions
+  (do-all-symbols (type)
+    (ext:when-let ((deftype-form (si:get-sysprop type 'SI::DEFTYPE-FORM)))
+      (unless (cmp-env-search-type type env)
+        (let ((type-definition (eval (destructuring-bind (name lambda-list &rest body)
+                                         (rest deftype-form)
+                                       (si::expand-defmacro name lambda-list body 'DEFTYPE)))))
+          (setf env (cmp-env-register-type type type-definition env))))))
+  env)
+
 (defun cmp-env-search-function (name &optional (env *cmp-env*))
   (let ((cfb nil)
         (unw nil)
@@ -213,11 +227,11 @@ that are susceptible to be changed by PROCLAIM."
      return (cddr i)
      finally (return default)))
 
-(defun cmp-env-search-type (name &optional (env *cmp-env*) (default name))
+(defun cmp-env-search-type (name &optional (env *cmp-env*))
   (loop for i in (car env)
         when (and (consp i)
                   (eq (first i) :type)
                   (eq (second i) name))
           return (third i)
-        finally (return default)))
+        finally (return nil)))
 

src/cmp/cmpenv-declare.lsp

@@ -22,7 +22,7 @@
            (every test x))))
 
 (defun type-name-p (name)
-  (or (cmp-env-search-type name *cmp-env* nil)
+  (or (cmp-env-search-type name *cmp-env*)
       (si:get-sysprop name 'SI::DEFTYPE-DEFINITION)
       (find-class name nil)
       (si:get-sysprop name 'SI::STRUCTURE-TYPE)))

src/cmp/cmpenv-fun.lsp

@@ -24,7 +24,7 @@
 ;;; The valid return type declaration is:
 ;;;     (( VALUES {type}* )) or ( {type}* ).
 
-(defun proclaim-function (fname decl)
+(defun proclaim-function (fname decl &optional destination)
   (if (si:valid-function-name-p fname)
       (let* ((arg-types '*)
              (return-types '*)
@@ -43,12 +43,12 @@
         (when (eq arg-types '())
           (setf arg-types '(&optional)))
         (if (eq arg-types '*)
-            (si:rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
+            (rem-property fname 'PROCLAIMED-ARG-TYPES destination)
-            (si:put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
+            (put-property fname 'PROCLAIMED-ARG-TYPES arg-types destination))
         (if (member return-types '(* (VALUES &rest t))
                     :test #'equalp)
-            (si:rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
+            (rem-property fname 'PROCLAIMED-RETURN-TYPE destination)
-            (si:put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
+            (put-property fname 'PROCLAIMED-RETURN-TYPE return-types destination)))
       (warn "The function proclamation ~s ~s is not valid." fname decl)))
 
 (defun add-function-declaration (fname ftype &optional (env *cmp-env*))
@@ -68,7 +68,7 @@
     (when may-be-global
       (let ((fun (cmp-env-search-function fname env)))
         (when (or (null fun) (and (fun-p fun) (fun-global fun)))
-          (si:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))))
+          (get-global-property fname 'PROCLAIMED-ARG-TYPES))))))
 
 (defun get-return-type (fname &optional (env *cmp-env*))
   (ext:if-let ((x (cmp-env-search-ftype fname env)))
@@ -77,7 +77,7 @@
         (values return-types t)))
     (let ((fun (cmp-env-search-function fname env)))
       (when (or (null fun) (and (fun-p fun) (fun-global fun)))
-        (si:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))))
+        (get-global-property fname 'PROCLAIMED-RETURN-TYPE)))))
 
 (defun get-local-arg-types (fun &optional (env *cmp-env*))
   (ext:if-let ((x (cmp-env-search-ftype (fun-name fun) env)))

src/cmp/cmpfun.lsp

@@ -175,10 +175,3 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
     (if (and (symbolp name) (setf cname (si:get-sysprop name 'Lfun)))
         (values cname t)
         (values (next-cfun "L~D~A" name) nil))))
-
-(defun function-may-have-side-effects (fname)
-  (not (si:get-sysprop fname 'no-side-effects)))
-
-(defun function-may-change-sp (fname)
-  (not (or (si:get-sysprop fname 'no-side-effects)
-           (si:get-sysprop fname 'no-sp-change))))

src/cmp/cmpglobals.lsp

@@ -66,7 +66,7 @@ running the compiler. It may be updated by running ")
 (defvar *functions* nil)
 
 ;;; --cmpc-machine.lsp, cmpffi.lsp ---
-(defvar *machine* nil)
+(defconfig *machine* nil)
 
 ;;; --cmpcall.lsp--
 (defvar *compiler-declared-globals*)
@@ -112,8 +112,8 @@ by the C compiler and they denote function and unwind-protect boundaries. Note
 that compared with the bytecodes compiler, these records contain an additional
 variable, block, tag or function object at the end.")
 
-(defvar *cmp-env-root*
+(defconfig *cmp-env-root*
-  (cons nil (list (list '#:no-macro 'si:macro (constantly nil))))
+  (cons nil (list (list '#:no-macro 'si:macro 'si::constantly-nil)))
 "This is the common environment shared by all toplevel forms. It can
 only be altered by DECLAIM forms and it is used to initialize the
 value of *CMP-ENV*.")
@@ -153,6 +153,11 @@ slashes before special characters.")
 (defvar *precompiled-header-flags* nil)
 (defvar *precompiled-header-cc-config* nil)
 
+(defvar *cross-compiling* nil
+  "Are we cross compiling?")
+(defvar *host-info* nil
+  "Information on the host configuration for cross compilation.")
+
 ;;;
 ;;; Compiler program and flags.
 ;;;
@@ -228,7 +233,7 @@ be deleted if they have been opened with LoadLibrary.")
     (*callbacks* nil)
     (*functions* nil)
     (*cmp-env-root* (copy-tree *cmp-env-root*))
-    (*cmp-env* nil)
+    (*cmp-env* *cmp-env-root*)
     (*load-objects* (make-hash-table :size 128 :test #'equal))
     (*make-forms* nil)
     (*referenced-objects* (make-array 256 :adjustable t :fill-pointer 0))

src/cmp/cmpmain.lsp

@@ -59,6 +59,7 @@
        (load nil)
        (external-format :default)
        output-file
+       (target nil)
      &aux
        (*standard-output* *standard-output*)
        (*error-output* *error-output*)
@@ -80,8 +81,13 @@ specifies whether to load the generated fasl file after compilation.  The
 :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to
 control the intermediate files generated by the ECL compiler.If the file was
 compiled successfully, returns the pathname of the compiled file."
-  #-dlopen
+  (when target
-  (unless system-p
+    (setf args (copy-list args))
+    (remf args :target)
+    (return-from compile-file
+      (compile-with-target-info #'(lambda () (apply #'compile-file input-pathname args))
+                                target)))
+  (unless (or (member :dlopen *features*) system-p)
     (format t "~%;;;~
 ~%;;; This system does not support loading dynamically linked libraries.~
 ~%;;; Therefore, COMPILE-FILE without :SYSTEM-P T is unsupported.~
@@ -97,7 +103,10 @@ compiled successfully, returns the pathname of the compiled file."
             (return)))))
   (when (and system-p load)
     (error "Cannot load system files."))
-  (cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname))
+  (cmpprogress "~&;;;~%;;; Compiling ~a~:[~; for target ~a~]."
+               (namestring input-pathname)
+               *cross-compiling*
+               *target-identifier*)
   (let* ((input-file (truename *compile-file-pathname*))
          (*compile-file-truename* input-file)
          (*compiler-in-use* *compiler-in-use*)
@@ -119,7 +128,9 @@ compiled successfully, returns the pathname of the compiled file."
           (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname))
           (cmperr "The C compiler failed to compile the intermediate file."))
       (when load
-        (load true-output-file :verbose *compile-verbose*))) ; with-compiler-env
+        (if *cross-compiling*
+            (load input-file :verbose *compile-verbose*)
+            (load true-output-file :verbose *compile-verbose*)))) ; with-compiler-env
     (compiler-output-values true-output-file compiler-conditions)))
 
 (defun compiler-output-values (main-value conditions)
@@ -170,6 +181,14 @@ after compilation."
   (unless (si:valid-function-name-p name)
     (error "~s is not a valid function name." name))
 
+  (when *cross-compiling*
+    (return-from compile
+      (compile-with-target-info
+       (lambda ()
+         (let ((*cross-compiling* nil))
+           (compile name def)))
+       *host-info*)))
+
   (cond ((and supplied-p def)
          (when (functionp def)
            (unless (function-lambda-expression def)
@@ -202,7 +221,7 @@ after compilation."
          (*cmp-env-root* *cmp-env-root*))
 
     (with-compiler-env (compiler-conditions)
-      (setf form (set-closure-env form lexenv *cmp-env-root*))
+      (setf form (set-closure-env form lexenv *cmp-env*))
       (compiler-pass1 form)
       (compiler-pass/propagate-types)
       (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
@@ -285,7 +304,7 @@ from the C language code.  NIL means \"do not create the file\"."
          (*cmp-env-root* *cmp-env-root*))
     (with-compiler-env (compiler-conditions)
       (with-cxx-env ()
-        (setf disassembled-form (set-closure-env disassembled-form lexenv *cmp-env-root*))
+        (setf disassembled-form (set-closure-env disassembled-form lexenv *cmp-env*))
         (unwind-protect
              (progn
                (setf (symbol-function 'T3FUNCTION)
@@ -334,9 +353,45 @@ from the C language code.  NIL means \"do not create the file\"."
   (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%"
                *safety* *space* *speed* *debug*))
 
-(defmacro with-compilation-unit (options &rest body)
+(defun compile-with-target-info (closure target-info)
-  (declare (ignore options))
+  (check-type target-info (or list pathname-designator))
-  `(progn ,@body))
+  (when (typep target-info 'pathname-designator)
+    (setf target-info (read-target-info target-info)))
+  (let ((*host-info* (or *host-info* (get-target-info))))
+    (progv (mapcar #'car target-info) (mapcar #'cdr target-info)
+      (unless (string= *target-lisp-implementation-version* (lisp-implementation-version))
+        (error "Cannot cross compile as the target ECL version ~a does not match the host ECL version ~a"
+               *target-lisp-implementation-version* (lisp-implementation-version)))
+      (let* ((features-to-match '(#-unicode :unicode #-clos :clos))
+             (missing-features (intersection features-to-match *features*)))
+        (unless (null missing-features)
+          (warn "Cross compiling to a target with ~{~#[~;~(~a~)~;~(~a~) and ~(~a~)~:;~@{~(~a~)~#[~; and ~:;, ~]~}~]~} support from a host ECL which doesn't include these features is unsupported. Please use a host with matching feature set."
+                missing-features)))
+      (multiple-value-prog1 (let ((*cross-compiling* t))
+                              (funcall closure))
+        (let ((features (find '*features* target-info :key #'car)))
+          ;; Remember newly added keywords in *features* for future
+          ;; compilations
+          (setf (cdr features) *features*))))))
+
+;;; This function is located in the si package because the bytecodes
+;;; compiler will override it when calling
+;;; (install-bytecodes-compiler) since it supports fewer options than
+;;; the C compiler.
+(defun si::do-compilation-unit (closure &key override target)
+  (cond (override
+         (let* ((*active-protection* nil))
+           (si::do-compilation-unit closure :target target)))
+        ((null *active-protection*)
+         (let* ((*active-protection* t)
+                (*pending-actions* nil))
+           (unwind-protect (si::do-compilation-unit closure :target target)
+             (loop for action in *pending-actions*
+                   do (funcall action)))))
+        (target
+         (compile-with-target-info closure target))
+        (t
+         (funcall closure))))
 
 (ext:package-lock "CL" t)
 
@@ -345,14 +400,16 @@ from the C language code.  NIL means \"do not create the file\"."
 (let* ((compile #'compile)
        (disassemble #'disassemble)
        (compile-file #'compile-file)
-       (compile-file-pathname #'compile-file-pathname))
+       (compile-file-pathname #'compile-file-pathname)
+       (do-compilation-unit #'si::do-compilation-unit))
   (defun ext:install-c-compiler ()
     (ext:package-lock (find-package :cl) nil)
     (setf *features* (delete :ecl-bytecmp *features*))
     (setf (fdefinition 'disassemble) disassemble
           (fdefinition 'compile) compile
           (fdefinition 'compile-file) compile-file
-          (fdefinition 'compile-file-pathname) compile-file-pathname)
+          (fdefinition 'compile-file-pathname) compile-file-pathname
+          (fdefinition 'si::do-compilation-unit) do-compilation-unit)
     (ext:package-lock (find-package :cl) t)))
 
 (provide 'cmp)

src/cmp/cmpopt-constant.lsp

@@ -17,7 +17,7 @@
       (and (consp form)
            (let ((head (car form)))
              (or (member head '(IF OR AND NULL NOT PROGN))
-                 (and (si:get-sysprop head 'pure)
+                 (and (function-is-pure head)
                       (inline-possible head))))
            (loop for c in (rest form)
               always (constant-expression-p c env)))))

src/cmp/cmpopt.lsp

@@ -53,7 +53,7 @@
          first rest function)
     ;; Type must be constant to optimize
     (if (constantp type env)
-        (setf type (cmp-env-search-type (ext:constant-form-value type env) env))
+        (setf type (si::search-type-in-env (ext:constant-form-value type env) env))
         (return-from expand-typep form))
     (cond ;; compound function type specifier: signals an error
           ((contains-compound-function-type type)
@@ -227,21 +227,6 @@
     (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))))
@@ -261,7 +246,7 @@
          first rest)
     ;; Type must be constant to optimize
     (if (constantp type env)
-        (setf type (cmp-env-search-type (ext:constant-form-value type env) env))
+        (setf type (si::search-type-in-env (ext:constant-form-value type env) env))
         (return-from expand-coerce form))
     (cond ;; Trivial case
           ((subtypep 't type *cmp-env*)
@@ -275,6 +260,17 @@
           ((not (policy-inline-type-checks))
            form)
           ;;
+          ;; Complex floats
+          ((and *complex-float* (member type '(si:complex-single-float si:complex-double-float si:complex-long-float)))
+           (let ((prototype (case type
+                              (si:complex-single-float 0.0f0)
+                              (si:complex-double-float 0.0d0)
+                              (si:complex-long-float 0.0l0))))
+            `(let ((y ,value))
+               (declare (:read-only y))
+               (complex (float (realpart y) ,prototype)
+                        (float (imagpart y) ,prototype)))))
+          ;;
           ;; Search for a simple template above, replacing X by the value.
           ((loop for (a-type . template) in +coercion-table+
               when (eq type a-type)

src/cmp/cmppackage.lsp

@@ -48,7 +48,10 @@
    "COMPILER-MESSAGE-FORM"
    ;; Other operators.
    "INSTALL-C-COMPILER"
-   "UPDATE-COMPILER-FEATURES"))
+   "UPDATE-COMPILER-FEATURES"
+   ;; Target information for cross compilation.
+   "READ-TARGET-INFO"
+   "WRITE-TARGET-INFO"))
 
 
 

src/cmp/cmppass1-call.lsp

@@ -251,7 +251,7 @@
                   :args (c1expr `(function ,fname)) forms fname :global)))
 
 (defun c1call-constant-fold (fname forms)
-  (when (and (si:get-sysprop fname 'pure)
+  (when (and (function-is-pure fname)
              (policy-evaluate-forms)
              (inline-possible fname))
     (handler-case

src/cmp/cmppass1-ffi.lsp

@@ -97,6 +97,7 @@
 ;;;;
 ;;;;  CMPCBK --  Callbacks: lisp functions that can be called from the C world
 
+
 (defconstant +foreign-elt-type-codes+
   '(                (:char               . "ECL_FFI_CHAR")
                     (:unsigned-char      . "ECL_FFI_UNSIGNED_CHAR")
@@ -122,9 +123,9 @@
                     (:float              . "ECL_FFI_FLOAT")
                     (:double             . "ECL_FFI_DOUBLE")
                     (:long-double        . "ECL_FFI_LONG_DOUBLE")
-    #+complex-float (:csfloat            . "ECL_FFI_CSFLOAT")
+                    (:csfloat            . "ECL_FFI_CSFLOAT")
-    #+complex-float (:cdfloat            . "ECL_FFI_CDFLOAT")
+                    (:cdfloat            . "ECL_FFI_CDFLOAT")
-    #+complex-float (:clfloat            . "ECL_FFI_CLFLOAT")
+                    (:clfloat            . "ECL_FFI_CLFLOAT")
                     (:void               . "ECL_FFI_VOID")))
 
 (defun foreign-elt-type-code (type)

src/cmp/cmppass1-special.lsp

@@ -67,7 +67,7 @@
              (make-c1form* 'FUNCTION
                            :type 'FUNCTION
                            :sp-change (not (and (symbolp fun)
-                                                (si:get-sysprop fun 'NO-SP-CHANGE)))
+                                                (function-no-sp-change fun)))
                            :args fun)))
           ((and (consp fun) (member (car fun) '(LAMBDA EXT:LAMBDA-BLOCK)))
            (cmpck (endp (cdr fun))

src/cmp/cmppass1-top.lsp

@@ -11,9 +11,7 @@
 
 (defun t1expr (form)
   (let* ((*current-toplevel-form* nil)
-         (*cmp-env* (if *cmp-env*
+         (*cmp-env* (cmp-env-copy *cmp-env*)))
-                        (cmp-env-copy *cmp-env*)
-                        (cmp-env-root))))
     (push (t1expr* form) *top-level-forms*)))
 
 (defvar *toplevel-forms-to-print*

src/cmp/cmptype.lsp

@@ -42,7 +42,7 @@
                                  (long-float   . 0.0L1)
                                  (double-float . 0.0D1)
                                  (single-float . 0.0F1)
-                                 ,@(when (member :complex-float *features*)
+                                 ,@(when *complex-float*
                                      '((si:complex-single-float . #c(0.0f0 0.0f0))
                                        (si:complex-double-float . #c(0.0d0 0.0d0))
                                        (si:complex-long-float . #c(0.0l0 0.0l0)))))

src/cmp/cmputil.lsp

@@ -43,22 +43,6 @@
                  (setf output f)))
        finally (return output))))
 
-(defun do-compilation-unit (closure &key override)
-  (cond (override
-         (let* ((*active-protection* nil))
-           (do-compilation-unit closure)))
-        ((null *active-protection*)
-         (let* ((*active-protection* t)
-                (*pending-actions* nil))
-           (unwind-protect (do-compilation-unit closure)
-             (loop for action in *pending-actions*
-                do (funcall action)))))
-        (t
-         (funcall closure))))
-
-(defmacro with-compilation-unit ((&rest options) &body body)
- `(do-compilation-unit #'(lambda () ,@body) ,@options))
-
 (defmacro with-compiler-env ((compiler-conditions) &body body)
   `(let ((*compiler-conditions* nil))
      (declare (special *compiler-conditions*))
@@ -69,7 +53,7 @@
                         (compiler-error #'handle-compiler-error)
                         (serious-condition #'handle-compiler-internal-error))
            (mp:with-lock (mp:+load-compile-lock+)
-             (let ,+init-env-form+
+             (let* ,+init-env-form+
                (with-compilation-unit ()
                  ,@body))))
        (abort ()))
@@ -490,3 +474,28 @@ comparing circular objects."
     (list (null item))
     (vector (zerop (length item)))
     (hash-table (zerop (hash-table-count item)))))
+
+(defun read-target-info (filename)
+  (unless (pathname-name filename)
+    (let* ((path1 (merge-pathnames "target-info.lsp" filename)) ; flat install
+           (path2 (merge-pathnames "*/*/target-info.lsp" filename)) ; file in lib/ecl-x.x.x/
+           (files-found (nconc (directory path1) (directory path2))))
+      (when (null files-found)
+        (cmperror "Can't find the target information for cross compilation at ~s or ~s." path1 path2))
+      (setf filename (first files-found))))
+  (with-open-file (s filename)
+    (with-standard-io-syntax
+      (read s))))
+
+(defun get-target-info ()
+  (mapcar #'(lambda (option) (cons option (symbol-value option)))
+          c::*config-options*))
+
+(defun write-target-info (filename)
+  (with-open-file (s filename
+                     :direction :output
+                     :if-exists :supersede
+                     :if-does-not-exist :create)
+    (with-standard-io-syntax
+      (let ((*print-circle* t))
+        (format s "~S~%" (get-target-info))))))

src/cmp/load.lsp.in

@@ -3,8 +3,8 @@
 
 (defconstant +cmp-module-files+
   '("src:cmp;cmppackage.lsp"
-    "src:cmp;cmpglobals.lsp"
     "build:cmp;cmpdefs.lsp"
+    "src:cmp;cmpglobals.lsp"
     "src:cmp;cmputil.lsp"
     "src:cmp;cmpcond.lsp"
     "src:cmp;cmptype-arith.lsp"

src/cmp/proclamations.lsp

@@ -44,24 +44,64 @@
 
 (in-package "C")
 
+(defun put-property (symbol property value collection)
+  (if collection
+      (setf (getf (gethash symbol collection) property) value)
+      (si:put-sysprop symbol property value)))
+
+(defun rem-property (symbol property collection)
+  (if collection
+      (remf (gethash symbol collection) property)
+      (si:rem-sysprop symbol property)))
+
+(let ((not-found (cons nil nil)))
+  (defun get-property (symbol property collection)
+    (if collection
+        (let ((value
+                (getf (gethash symbol collection) property not-found)))
+          (if (eq value not-found)
+              (values nil nil)
+              (values value t)))
+        (si:get-sysprop symbol property)))
+
+  (defun get-global-property (symbol property)
+    (let ((value (getf (gethash symbol *static-proclamations*)
+                       property not-found)))
+      (if (eq value not-found)
+          (si:get-sysprop symbol property)
+          (values value t)))))
+
+(defun function-is-pure (fname)
+  (get-property fname 'pure *static-proclamations*))
+
+(defun function-may-have-side-effects (fname)
+  (not (get-property fname 'no-side-effects *static-proclamations*)))
+
+(defun function-may-change-sp (fname)
+  (not (or (get-property fname 'no-side-effects *static-proclamations*)
+           (get-property fname 'no-sp-change *static-proclamations*))))
+
+(defun function-no-sp-change (fname)
+  (get-property fname 'no-sp-change *static-proclamations*))
+
 (defun parse-function-proclamation
     (name arg-types return-type &rest properties)
-  (when (si:get-sysprop name 'proclaimed-arg-types)
+  (when (get-property name 'proclaimed-arg-types *static-proclamations*)
     (warn "Duplicate proclamation for ~A" name))
-  (proclaim-function
+  (proclaim-function name (list arg-types return-type) *static-proclamations*)
-   name (list arg-types return-type))
   (loop for p in properties
-     do (case p
+        do (case p
-          (:no-sp-change
+             (:no-sp-change
-           (si:put-sysprop name 'no-sp-change t))
+              (put-property name 'no-sp-change t *static-proclamations*))
-          ((:predicate :pure)
+             ((:predicate :pure)
-           (si:put-sysprop name 'pure t)
+              (put-property name 'pure t *static-proclamations*)
-           (si:put-sysprop name 'no-side-effects t))
+              (put-property name 'no-side-effects t *static-proclamations*))
-          ((:no-side-effects :reader)
+             ((:no-side-effects :reader)
-           (si:put-sysprop name 'no-side-effects t))
+              (put-property name 'no-side-effects t *static-proclamations*))
-          (otherwise
+             (otherwise
-           (error "Unknown property ~S in function proclamation for ~S"
+              (error "Unknown property ~S in function proclamation for ~S"
-                  p name)))))
+                     p name)))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; AUXILIARY TYPES
@@ -1582,9 +1622,17 @@
 (proclamation ext:non-negative-long-float-p (t) gen-bool :pure) 
 (proclamation ext:non-positive-long-float-p (t) gen-bool :pure) 
 (proclamation ext:positive-long-float-p (t) gen-bool :pure) 
+))
 
-))) ; eval-when
+(defun collect-proclamations ()
-
+  (let ((*static-proclamations* (make-hash-table :test 'equal :size 1024)))
-(loop for i in '#.(mapcar #'rest +proclamations+)
+    (declare (special *static-proclamations*))
-   do (apply #'parse-function-proclamation i))
+    (loop for i in (mapcar #'rest +proclamations+)
+          do (apply #'parse-function-proclamation i))
+    *static-proclamations*))
+) ; eval-when
 
+;;; The declarations from proclamations.lsp are collected in
+;;; *STATIC-PROCLAMATIONS* instead of the main system properties to
+;;; allow for switching them out for cross compilation.
+(defconfig *static-proclamations* #.(collect-proclamations))

src/compile.lsp.in

@@ -18,7 +18,8 @@
   (setq *features* '(@LSP_FEATURES@ @COMPILATION_FEATURES@))
   (when (member :ecl-min *host-features*)
     (setq *features* (cons :ecl-min *features*)))
-  (when (member :uname *host-features*)
+  (when (and (member :uname *host-features*)
+             (not (member :windows *features*)))
     (setq *features* (cons :uname *features*)))
   (when (member :cross *host-features*)
     (setq *features* (cons :cross *features*))))
@@ -41,8 +42,9 @@
 (progn
   (c::update-compiler-features
    :executable
-   #+(or windows cygwin mingw32) "build:ecl_min.exe"
+   (if (intersection '(:windows :cygwin :mingw32) *host-features*)
-   #-(or windows cygwin mingw32) "build:@ECL_MIN@")
+       "build:ecl_min.exe"
+       "build:@ECL_MIN@"))
   (format t "~&;;; System features: ~A~%" c::*compiler-features*))
 
 ;;;
@@ -76,6 +78,24 @@
   (load "@true_srcdir@/doc/help.lsp")
   (si::dump-documentation "@true_builddir@/help.doc"))
 
+;;;
+;;; * Dump compiler configuration (for cross compilation)
+;;;
+#+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*))
+  (dolist (s '(most-negative-fixnum most-positive-fixnum cl-fixnum-bits array-dimension-limit
+               array-total-size-limit ffi:c-short-min ffi:c-short-max ffi:c-ushort-max
+               ffi:c-int-min ffi:c-int-max ffi:c-uint-max ffi:c-long-min ffi:c-long-max
+               ffi:c-ulong-max #+long-long ffi:c-long-long-min #+long-long ffi:c-long-long-max
+               #+long-long ffi:c-ulong-long-max))
+    (c::cmp-env-register-symbol-macro s (symbol-value s) c::*cmp-env-root* t))
+  (c::write-target-info #P"build:target-info.lsp"))
+
 ;;;
 ;;; * Trick to make names shorter in C files
 ;;;
@@ -363,7 +383,7 @@
   (write-line "id ICON \"ecl.ico\"" s))
  (ext:copy-file #p"src:util;ecl.ico" "ecl.ico")
  #+msvc (ext:system "rc /nologo /r ecl.rc")
- #-msvc (ext:system "windres ecl.rc -O coff ecl.res"))
+ #-msvc (ext:system "@WINDRES@ ecl.rc -O coff ecl.res"))
 
 (si::pathname-translations "SYS" '(("**;*.*.*" "@true_builddir@/**/*.*")))
 

src/doc/manual/extensions/building.txi

@@ -4,6 +4,7 @@
 @menu
 * Compiling with ECL::
 * Compiling with ASDF::
+* Cross compilation::
 * C compiler configuration::
 @end menu
 @c * Compiling with Matroska::
@@ -538,6 +539,212 @@ here, since our Lisp library is statically bundled with the executable.
 The result is the same as the shared library example above. You can also
 build all dependent libraries separately as static libraries.
 
+@node Cross compilation
+@subsection Cross compilation
+
+ECL supports cross compiling Lisp files for a target system that differs
+from the host system on which the compilation takes place. This section
+of the manual describes how to use this feature and explains important
+things to keep in mind when cross compiling Common Lisp.
+
+@node Getting started with cross compilation
+@subsubsection Getting started with cross compilation
+
+To get started, follow the steps described below:
+
+@enumerate
+@item
+Cross compile ECL itself following the steps described in @ref{Building
+ECL}.
+@item
+Step one will create a Lisp file called @file{target-info.lsp}
+containing all the information necessary for the ECL compiler to create
+compiled files for the chosen target system. Load this information into
+a running ECL process on the host system by calling
+@code{c:read-target-info} on this file.
+@item
+Supply the resulting target information to the @code{:target} option of
+@coderef{compile-file} or @coderef{with-compilation-unit}.
+@end enumerate
+
+For an example, consider two files @file{a.lisp} and @file{b.lisp} which
+are supposed to be linked into a shared library. This can be
+accomplished with the following steps:
+
+@example
+(defvar *target* (c:read-target-info "/path/to/ecl/installation/lib/ecl-xx.x.x/target-info.lsp"))
+
+(compile-file "a.lisp" :target *target* :system-p t)
+(load "a.lisp") ; make macro definitions in "a.lisp" accessible to "b.lisp"
+(compile-file "b.lisp" :target *target* :system-p t)
+
+(with-compilation-unit (:target *target*)
+  (c:build-shared-library "example"
+                          :lisp-files '("a.o" "b.o")
+                          :init-name "init_example"))
+@end example
+
+Cross compilation using ASDF is not supported yet but is planned for the
+future.
+
+@node Limitations and pitfalls for cross compiling Common Lisp
+@subsubsection Limitations and pitfalls for cross compiling Common Lisp
+
+The ubiquity with which typical Common Lisp programs run code at compile
+time in macros or other similar constructs makes cross compilation
+somewhat more challenging than in other programming languages. Since
+compilation happens on a different system than the one in which the code
+generated by a macro is run, differences between the host and target
+environment can lead to bugs if the macro hasn't been written with cross
+compilation in mind. Consider for instance the following example macro
+iterating over prime number in the range from @code{a} to @code{b}:
+
+@example
+(defmacro do-prime-numbers ((a b) p &body body)
+  `(loop with ,p = (next-prime ,a)
+         until (> ,p ,b)
+         do ,(if (typep b 'fixnum)
+                 `(locally (declare (fixnum ,p))
+                    ,@@body)
+                 `(progn ,@@body))
+            (setf ,p (next-prime (1+ ,p)))))
+@end example
+
+While this macro works fine in a standard setting, it will produce
+an incorrect declaration when cross compiling if the size of a fixnum
+is larger in the host than in the target and the upper bound @code{b} is
+larger than @code{most-positive-fixnum} in the target but smaller than
+@code{most-positive-fixnum} in the host. In general, any observable
+difference between target and host system may contribute to such issues.
+In the list below, we collect a number of such potential issues and
+explain strategies to solve them.
+
+@itemize
+@item
+Different type or subtype definitions. This may arise from differing
+word sizes, as in the fixnum example above, or different feature support
+such as complex floating point number support in the C compiler leading
+to differing subtype relationships for complex numbers in Lisp. There
+are two main strategies for dealing with this problem.
+@enumerate
+@item
+Avoid the problem by rewriting the code not to rely on target specific
+information. For instance, in the above example we can change the
+declaration as follows to avoid relying on fixnums:
+@example
+(defmacro do-prime-numbers ((a b) p &body body)
+  `(loop with ,p = (next-prime ,a)
+         until (> ,p ,b)
+         do (locally (declare (type (integer ,a ,b) ,p))
+              ,@@body)
+            (setf ,p (next-prime (1+ ,p)))))
+@end example
+If the declared integer type is a subtype of fixnum, the ECL compiler
+will automatically take this into account and optimize the same as if a
+fixnum declaration had been made.
+@item
+Use the lexical environment parameter to @clhs{f_typep.htm,typep} and
+@clhs{f_subtpp.htm,subtypep}. Both functions take an optional parameter
+which can be used to supply information about type relationships in the
+target system. In the above example, this works as follows:
+@example
+(defmacro do-prime-numbers ((a b) p &body body &environment env)
+  `(loop with ,p = (next-prime ,a)
+         until (> ,p ,b)
+         do ,(if (typep b 'fixnum env)
+                 `(locally (declare (fixnum ,p))
+                    ,@@body)
+                 `(progn ,@@body))
+            (setf ,p (next-prime (1+ ,p)))))
+@end example
+It is important, however, not to blindly modify every occurrence of
+@code{typep} and @code{subtypep} in this way. Some calls to these
+functions may check for types in the host environment, in which case
+they should not receive an environment parameter. It is necessary to
+know for which environment the call is meant in order to decide what to
+do.
+@end enumerate
+@item
+Different value of @code{*features*}, leading to mismatched @code{#+}
+and @code{#-} read time conditionals. During cross compilation,
+@code{*features*} will be rebound to the value in the target
+system.@footnote{Changes to @code{*features*} during compilation are
+carried over in the target information structure. This means that in a
+scenario where one cross compiles a file @file{a.lisp} containing
+@code{(eval-when (:compile-toplevel) (push :my-feature *features*))}
+before cross compiling another file @file{b.lisp} containing
+@code{#+my-feature}, the read time conditional in @file{b.lisp} will
+evaluate to true.} However, macros that are defined in the host system
+will see the host @code{*features*} during read time. Consider again the
+example given above where @file{a.lisp} was cross compiled, then loaded
+before @file{b.lisp} was cross compiled. If @file{a.lisp} contains a
+macro definition
+@example
+(defmacro my-macro (...)
+  #+android `(do-something ...)
+  #-android `(do-something-else ...))
+@end example
+then @code{my-macro} will expand to @code{do-something} in @file{a.lisp}
+but @code{do-something-else} in @file{b.lisp} if cross compiling for the
+android target. There are several ways to deal with this issue:
+@enumerate
+@item
+Load source files containing macro definitions in an environment where
+@code{*features*} has the same value as in the target system. This can
+be accomplished either by wrapping @code{load} in a
+@coderef{with-compilation-unit} call with a @code{:target} option given
+or by using the @code{:load} keyword option of @coderef{compile-file} in
+conjunction with @code{:target}. In the above example, we would compile
+as follows:
+@example
+(compile-file "a.lisp" :target *target* :system-p t :load t)
+(compile-file "b.lisp" :target *target* :system-p t)
+@end example
+Note that this will not work if the file contains read time conditionals
+selecting between different compile time code paths due to differences
+in the host system (let's say for example some code generation from a
+file that is located in a different location for different compilation
+hosts).
+@item
+Replace read time conditionals by lookups that run during macro
+expansion, e.g.
+@example
+(defmacro my-macro (...)
+  (if (member :android *features*)
+      `(do-something ...)
+      `(do-something-else ...)))
+@end example
+@item
+Add feature keywords for the target system to @code{*features*} in the
+host before compilation. This is best suited for conditionals which only
+add but not subtract code (keywords which only appear in @code{#+}
+conditionals). In our example, we would call
+@example
+(push :android *features*)
+@end example
+before starting cross compilation.
+@end enumerate
+@item
+Floating point accuracy issues. ECL relies on the C standard library for
+numerical functions which may return slightly different values for
+different systems. If your code depends sensitively on numerical
+functions returning bitwise identical results, it is best not to run any
+numerical code at compile time and restrict yourself to only running run
+time code.
+@end itemize
+
+Another option to avoid the aformentioned issues entirely is to use
+emulation instead of cross compilation. Even if full-blown emulation is
+too complicated, simply cross compiling from a version of ECL compiled
+for the same word size as the target system would for instance avoid the
+fixnum issues in our example macro alltogether.
+
+Whether the compiler is switched to cross compilation mode or not can be
+diagnosed from the presence of a @code{:cross} keyword in
+@code{*features*}. If necessary, this can be used to select different
+code paths as well.
+
+
 @node C compiler configuration
 @subsection C compiler configuration
 

src/doc/manual/standards/sys-constr.txi

@@ -1,6 +1,58 @@
 @node System construction
 @section System construction
 
+@node System construction - Dictionary
+@subsection Dictionary
+
+@subsubsection Extensions
+
+See also @ref{System building}.
+
+@lspdef compile-file
+@defun compile-file input-file &key output-file verbose print external-format target system-p load c-file h-file data-file
+Additional options for @clhs{f_cmp_fi.htm,compile-file} include:
+@table @code
+@item :system-p
+Create an object file (.o)
+@item :target
+Cross compilation target, see @ref{Cross compilation}. Can be either the
+target information obtained by calling @code{c:read-target-info} or a
+pathname pointing to the installation directory of the target ECL for
+which to compile.
+@item :load
+Load the output file after compilation. If a @code{:target} argument is
+given alongside @code{:load}, load the source file in the target
+environment.
+@item :c-file, :h-file, :data-file
+Boolean flags controlling whether to keep temporary files created by the compiler
+@end table
+@end defun
+
+@lspdef compile-file-pathname
+@defun compile-file-pathname input-file &key output-file type system-p
+Additional options for @clhs{f_cmp__1.htm,compile-file-pathname} include:
+@table @code
+@item :type
+Specify the type of output file. One of @code{:fasl} (default, alias @code{:fas}), @code{:c}, @code{:h}, @code{:data}, @code{:object}, @code{:program}, @code{:shared-library} (alias @code{:dll}), @code{:static-library} (alias @code{:library}, @code{:lib}), @code{:precompiled-header} or @code{:import-library} (MSVC only)
+@item :system-p
+If no type is supplied, default to @code{:object} type instead of @code{:fasl}
+@end table
+@end defun
+
+@lspdef with-compilation-unit
+@deffn {Macro} with-compilation-unit (&key override target) &body body
+Additional options for @clhs{m_w_comp.htm,with-compilation-unit} include:
+@table @code
+@item :target
+Cross compilation target, see @ref{Cross compilation}. Any compilation
+operation produces outputs for the specified target system. This
+includes @clhs{f_cmp_fi.htm,compile-file},
+@clhs{f_disass.htm,disassemble} and all ECL specific functions described
+in the section on @ref{Compiling with ECL}. The only exception is
+@clhs{f_cmp.htm,compile} which continues to work as usual.
+@end table
+@end deffn
+
 @subsection C Reference
 
 @subsubsection ANSI Dictionary

src/lsp/autoload.lsp

@@ -33,9 +33,12 @@ Gives a global declaration.  See DECLARE for possible DECL-SPECs."
   (when (eq (car d) 'SPECIAL) (mapc #'sys::*make-special (cdr d))))
 )
 
-(defmacro with-compilation-unit (options &rest body)
+(defun si::do-compilation-unit (closure &rest options)
   (declare (ignore options))
-  `(progn ,@body))
+  (funcall closure))
+
+(defmacro with-compilation-unit (options &rest body)
+  `(si::do-compilation-unit #'(lambda () ,@body) ,@options))
 
 ;;; Editor.
 

src/lsp/loop.lsp

@@ -192,7 +192,8 @@ constructed.
 
 (defun make-loop-minimax (answer-variable type)
   (declare (si::c-local))
-  (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep))))
+  (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist*
+                                   :test #'(lambda (t1 t2) (subtypep t1 t2 *loop-macro-environment*))))))
     (make-loop-minimax-internal
       :answer-variable answer-variable
       :type type
@@ -563,7 +564,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
     (when (setq constantp (constantp new-form))
       (setq constant-value (eval new-form)))
     (when (and constantp expected-type)
-      (unless (typep constant-value expected-type)
+      (unless (typep constant-value expected-type *loop-macro-environment*)
         (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
                    form constant-value expected-type)
         (setq constantp nil constant-value nil)))
@@ -636,7 +637,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
   (declare (si::c-local))
   (if (null specified-type)
       default-type
-      (multiple-value-bind (a b) (subtypep specified-type required-type)
+      (multiple-value-bind (a b) (subtypep specified-type required-type *loop-macro-environment*)
         (cond ((not b)
                (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
                           specified-type required-type))
@@ -975,7 +976,7 @@ collected result will be returned as the value of the LOOP."
          (unless (or (eq dtype t) (member (truly-the symbol name) *loop-nodeclare*))
            (when (and initialization-p (constantp initialization))
              (let ((init-type (type-of initialization)))
-               (unless (subtypep init-type dtype)
+               (unless (subtypep init-type dtype *loop-macro-environment*)
                  (setf dtype `(or ,dtype ,init-type)))))
            ;; Allow redeclaration of a variable. This can be used by
            ;; the loop constructors to make the type more and more
@@ -1325,7 +1326,7 @@ Note that this is not a valid ANSI code."))
 (defun loop-do-repeat ()
   (loop-disallow-conditional :repeat)
   (let* ((form (loop-get-form))
-         (type (if (fixnump form) 'fixnum 'real))
+         (type (if (typep form 'fixnum *loop-macro-environment*) 'fixnum 'real))
          (var (loop-make-variable (gensym) form type))
          (form `(loop-unsafe (when (minusp (decf ,var)) (go end-loop)))))
       (push form *loop-before-loop*)
@@ -1705,10 +1706,10 @@ Note that this is not a valid ANSI code."))
          ;; We can make the number type more precise when we know the
          ;; start, end and step values.
          (let ((new-type (typecase (+ start-value stepby)
-                           (integer (if (and (fixnump start-value)
+                           (integer (if (and (typep start-value 'fixnum *loop-macro-environment*)
                                              limit-constantp
-                                             (< limit-value most-positive-fixnum)
+                                             (typep (1+ limit-value) 'fixnum *loop-macro-environment*)
-                                             (> limit-value most-negative-fixnum))
+                                             (typep (1- limit-value) 'fixnum *loop-macro-environment*))
                                         'fixnum
                                         'integer))
                            (single-float 'single-float)
@@ -1716,12 +1717,12 @@ Note that this is not a valid ANSI code."))
                            (long-float 'long-float)
                            (short-float 'short-float)
                            (t indexv-type))))
-           (unless (subtypep (type-of start-value) new-type)
+           (unless (subtypep (type-of start-value) new-type *loop-macro-environment*)
              ;; The start type may not be a subtype of the type during
              ;; iteration. Happens e.g. when stepping a fixnum start
              ;; value by a float.
              (setf new-type `(or ,(type-of start-value) ,new-type)))
-           (unless (subtypep indexv-type new-type)
+           (unless (subtypep indexv-type new-type *loop-macro-environment*)
              (loop-declare-variable indexv new-type)))
          (when (and limit-constantp
                     (setq first-test (funcall (symbol-function testfn)

src/lsp/predlib.lsp

@@ -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
+  (if (complex-float-feature env)
-  ;; code would look as follows
+      (cond ((subtypep real-type 'null env)         nil)
-  ;;   (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
+            ((subtypep real-type 'rational env)     'rational)
-  ;;       (error "~S is not a valid part type for a complex." real-type))
+            ((subtypep real-type 'single-float env) 'single-float)
-  ;;     (when (subtypep real-type v)
+            ((subtypep real-type 'double-float env) 'double-float)
-  ;;       (return v))))
+            ((subtypep real-type 'long-float env)   'long-float)
-  #+complex-float
+            ((subtypep real-type 'float env)        'float)
-  (cond ((subtypep real-type 'null env)         nil)
+            ((subtypep real-type 'real env)         'real)
-        ((subtypep real-type 'rational env)     'rational)
+            (t (error "~S is not a valid part type for a complex." real-type)))
-        ((subtypep real-type 'single-float env) 'single-float)
+      (cond ((subtypep real-type 'null env) nil)
-        ((subtypep real-type 'double-float env) 'double-float)
+            ((subtypep real-type 'real env) 'real)
-        ((subtypep real-type 'long-float env)   'long-float)
+            (t (error "~S is not a valid part type for a complex." real-type)))))
-        ((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))))
 
 (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
+               (case upgraded-real
-            (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
+                 (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)))
@@ -1687,6 +1691,6 @@ if not possible."
                  (eq (second record) type-name))
         (return-from search-type-in-env
           (if (typep (third record) 'function)
-              (funcall (third record) type-args)
+              (funcall (third record) (cons type-name type-args) env)
               (third record))))))
   type)

src/tests/Makefile.in

@@ -15,6 +15,13 @@ check: config.lsp
                --eval "(ext:quit)" \
                2>&1 | tee test.log
 
+cross-check: config.lsp
+	$(ECL) --norc \
+               --load config.lsp \
+               --eval "(ecl-tests::run-tests '($(TESTS)) t)" \
+               --eval "(ext:quit)" \
+               2>&1 | tee test.log
+
 clean:
 	rm -rf regressions.log cache
 
@@ -26,3 +33,9 @@ ansi-test: ansi-test/doit.lsp
                --load config.lsp \
                --eval "(ext:quit (if (ecl-tests::run-ansi-test) 0 2))" \
                2>&1 | tee ansi-test.log
+
+cross-ansi-test: ansi-test/doit.lsp
+	$(ECL) --norc \
+               --load config.lsp \
+               --eval "(ext:quit (if (ecl-tests::run-ansi-test nil t) 0 2))" \
+               2>&1 | tee ansi-test.log

src/tests/config.lsp.in

@@ -75,7 +75,7 @@
 ;;;
 ;;; RUNNING TESTS
 ;;;
-(defun run-tests (suites
+(defun run-tests (suites &optional cross-compile
                   &aux (suites (cond
                                  ((null suites) "make-check")
                                  ((null (cdr suites)) (car suites))
@@ -99,6 +99,11 @@
                       (merge-pathnames
                        "tests/doit.lsp" *ecl-sources*))
             "-eval" "(in-package cl-test)"
+            ,@(when cross-compile
+                `("-eval"
+                  ,(format nil "(cl-test-cross-compile:setup ~s '(progn (load ~s) (in-package #:cl-test)))"
+                           (namestring (truename "SYS:target-info.lsp"))
+                           (namestring (truename (merge-pathnames "tests/doit.lsp" *ecl-sources*))))))
             "-eval" ,(format nil "(2am-ecl:run '~a)" suites)
             "-eval" "(ext:exit)")
           :input nil
@@ -113,7 +118,13 @@
 ;;;
 ;;; RUNNING ANSI-TEST
 ;;;
-(defun run-ansi-test (&optional (suite (ext:getenv "ANSI_TEST_SUITE")))
+(defun run-ansi-test (&optional
+                        (suite (ext:getenv "ANSI_TEST_SUITE"))
+                        cross-compile
+                        (expected-failures
+                         (or (ext:getenv "EXPECTED_FAILURES")
+                             (merge-pathnames #P"tests/ansi-test-expected-failures.sexp"
+                                              *ecl-sources*))))
   (ext:setenv "TEST_IMAGE" *test-image*)
   (zerop
    (nth-value
@@ -129,16 +140,19 @@
        ,@(cond (suite
                 `("-eval" ,(format nil "(setf *default-pathname-defaults* ~s)"
                                    (truename #P"ansi-test/"))
-                          "-load" "gclload1.lsp"
+                  "-load" "gclload1.lsp"
-                          "-load" ,(namestring (make-pathname
+                  "-load" ,(namestring (make-pathname
-                                                :directory (list :relative suite)
+                                        :directory (list :relative suite)
-                                                :name "load"
+                                        :name "load"
-                                                :type "lsp"))))
+                                        :type "lsp"))))
                (t
                 `("-load" "ansi-test/init.lsp")))
-       "-eval" ,(format nil "(rt:do-tests :exit t :expected-failures ~s)"
+       ,@(when cross-compile
-                        (merge-pathnames #P"tests/ansi-test-expected-failures.sexp"
+           `("-load" ,(namestring (truename (merge-pathnames "tests/cross-compile.lisp" *ecl-sources*)))
-                                         *ecl-sources*)))
+             "-eval" ,(format nil "(cl-test-cross-compile:setup ~s '(progn (in-package #:cl-user) (load ~s)))"
+                              (namestring (truename "SYS:target-info.lsp"))
+                              (namestring (truename "ansi-test/init.lsp")))))
+       "-eval" ,(format nil "(rt:do-tests :exit t :expected-failures ~s)" expected-failures))
      :input nil
      :output t
      :error :output))))

src/tests/cross-compile.lisp

@@ -0,0 +1,399 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CL-TEST-CROSS-COMPILE -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 2025, Marius Gerbershagen
+;;;;
+;;;;    See file 'LICENSE' for the copyright details.
+
+;;; Cross compilation testing framework
+;;;
+;;; We replace COMPILE-FILE and COMPILE in the ECL running on the
+;;; target system by stubs which delegate the compilation to a
+;;; remote ECL cross-compiling for the target.
+;;;
+;;; For now, the "remote" ECL is just running on the same computer
+;;; (for instance an x86 version of ECL cross compiling to x86_64).
+;;; The code below contains some preparations for true remote
+;;; compilation by setting set the environment variable ECL_TO_RUN to
+;;; start the remote ECL on a ssh connection (or similar) but this
+;;; functionality is incomplete.
+;;; 
+;;; There are several limitations to the testing framework:
+;;; 
+;;; 1. Function, macro or variable definitions, proclamations and
+;;;    other global state is not fully synchronized between the target
+;;;    and remote ECL. To get around this issue, we simply load the
+;;;    testsuite in the remote ECL before running it (which takes care
+;;;    of most of these issues) and replace other functions like
+;;;    PROCLAIM or SI::*MAKE-SPECIAL with stubs that perform their
+;;;    function in both the target and remote ECL.
+;;;
+;;; 2. The COMPILE function is implemented by writing the input out to
+;;;    a file, cross-compiling that file on the remote and then
+;;;    loading the result on the target. In general, the input cannot
+;;;    be written out unmodified to the file because literal objects
+;;;    need not be copied during compilation. To deal with this, we
+;;;    use the bytecodes code walker to collect literal objects in a
+;;;    vector, replacing references to them by load time values.
+;;;    Uninterned symbols are treated specially since they can appear
+;;;    both as literal objects and as variable or function names,
+;;;    making the approach of using load time values difficult. We
+;;;    therefore temporarily intern those symbols during compilation.
+;;;
+;;; This approach is enough to get the testsuite running but will
+;;; break in more compilated scenarios. When encountering a test
+;;; failure, one should always check if this is due to a limitation of
+;;; the testing framework or an actual error.
+
+(defpackage #:cl-test-cross-compile
+  (:use #:cl)
+  (:export #:setup))
+
+(in-package #:cl-test-cross-compile)
+
+;;; Remote commands
+
+(defvar *remote*)
+
+(let ((last-output ""))
+  (defun read-from-remote (remote read-operation)
+    (handler-case (with-standard-io-syntax (funcall read-operation (ext:external-process-output remote)))
+      (error (e)
+        (if (eq (ext:external-process-status remote) :running)
+            :unreadable
+            (error "Remote ECL exited: ~a" last-output)))))
+
+  (defun skip-forward-to-first-prompt (remote)
+    (loop do (setf last-output
+                   (let ((c (read-from-remote remote #'read-char)))
+                     (unread-char c (ext:external-process-output remote))
+                     (if (eq c #\>)
+                         c
+                         (read-from-remote remote #'read-line))))
+          until (eq last-output #\>))))
+
+(defun skip-forward-to-prompt (remote)
+  (loop for x = (read-from-remote remote #'read)
+        until (eq x :input-prompt)))
+
+(defun send-command (remote command &optional ignore-result)
+  (skip-forward-to-prompt remote)
+  (with-standard-io-syntax
+    (write `(let ((*standard-output* (make-string-output-stream))
+                  warnings error result output)
+              (handler-bind ((style-warning
+                               ;; To keep things simple, just catch
+                               ;; style-warnings and do the printing on
+                               ;; the remote host to avoid having to
+                               ;; deal with potentially unreadable
+                               ;; format arguments or complex warnings
+                               ;; which are difficult to translate to
+                               ;; the host.
+                               #'(lambda (w)
+                                   (push (list 'c::compiler-style-warning
+                                               :format-control (format nil "~a" w))
+                                         warnings))))
+                (handler-case
+                    (setf result (multiple-value-list ,command)
+                          output (get-output-stream-string *standard-output*))
+                  (serious-condition (cl-user::e)
+                    (setf error (format nil "~a" cl-user::e)))))
+              (list error warnings result output))
+           :stream (ext:external-process-input remote)
+           :circle t))
+  (terpri (ext:external-process-input remote))
+  (let ((all-results (read-from-remote remote #'read))
+        error warnings result output)
+    (when (eq all-results :unreadable)
+      (if ignore-result
+          (return-from send-command (values))
+          (error "Remote command ~s failed. Can't read back output." command)))
+    (unless (and (listp all-results) (= (length all-results) 4))
+      (format t "Unexpected output from remote: ~s " all-results)
+      (loop do (write-string (read-from-remote remote #'read-line))
+               (terpri)))
+    (setf error (first all-results)
+          warnings (second all-results)
+          result (third all-results)
+          output (fourth all-results))
+    (when error
+      (error "Remote command ~s failed. Got error: ~a" command error))
+    (mapc #'(lambda (w) (apply #'warn w)) warnings)
+    (format t "~a" output) ; echo remote output
+    (values-list result)))
+
+(defun copy-file-from-remote (remote file)
+  (let ((bytes
+         (send-command remote
+                       `(with-open-file (s ,file
+                                           :direction :input
+                                           :element-type 'ext::byte8)
+                          (let ((bytes (make-array (file-length s)
+                                                   :element-type 'ext::byte8)))
+                            (read-sequence bytes s)
+                            bytes)))))
+    (with-open-file (s file
+                       :direction :output
+                       :if-does-not-exist :create
+                       :if-exists :supersede
+                       :element-type 'ext::byte8)
+      (write-sequence bytes s))))
+
+(defun copy-file-to-remote (remote file)
+  (let ((bytes
+          (with-open-file (s file
+                             :direction :input
+                             :element-type 'ext::byte8)
+            (let ((bytes (make-array (file-length s)
+                                     :element-type 'ext::byte8)))
+              (read-sequence bytes s)
+              bytes))))
+    (send-command remote
+                  `(with-open-file (s ,file
+                                      :direction :output
+                                      :if-does-not-exist :create
+                                      :if-exists :supersede
+                                      :element-type 'ext::byte8)
+                     (write-sequence ,bytes s)))))
+
+;;; Handling literal objects and uninterned symbols for COMPILE
+
+(defvar *literal-objects* (make-array 8 :adjustable t :fill-pointer t))
+
+(defun literal-object-p (form)
+  (not (or (symbolp form) (numberp form))))
+
+(defun collect-literal-objects (form env)
+  (when (or (and (atom form) (literal-object-p form))
+            (and (consp form) (eq (first form) 'quote)))
+    (vector-push-extend form *literal-objects*))
+  (let ((head (and (consp form) (car form))))
+    (case head
+      ;; The interpreter doesn't know about ffi special forms, so we
+      ;; have to handle those separately
+      ((ffi:clines ffi:defcbody ffi:defentry) nil)
+      ((ffi:c-inline ffi:c-progn)
+       (mapcar #'(lambda (x) (collect-literal-objects x env)) (second form))
+       nil)
+      (otherwise form))))
+
+(defun replace-literal-objects (form)
+  (when (and (consp form) (eq (first form) 'si:quasiquote))
+    (return-from replace-literal-objects
+      (replace-literal-objects (macroexpand-1 form))))
+  (loop for obj across *literal-objects*
+        for index from 0
+        if (or (eq obj form)
+               (and (consp form) (eq (first form) 'quote)
+                    (consp obj) (eq (first obj) 'quote)
+                    (eq (second form) (second obj))))
+          do (return-from replace-literal-objects
+               `(load-time-value ,(if (and (consp obj) (eq (first obj) 'quote))
+                                      `(second (elt cl-test-cross-compile::*literal-objects* ,index))
+                                      `(elt cl-test-cross-compile::*literal-objects* ,index)))))
+  (if (consp form)
+      (cons (replace-literal-objects (car form)) (replace-literal-objects (cdr form)))
+      form))
+
+(defun adjoin-macros (form lexenv temp-interned-sym)
+  (loop for record in (cdr lexenv)
+        do (when (and (eq (second record) 'si:macro)
+                      (typep (third record) 'function))
+             (multiple-value-bind (macro-form macro-lexenv)
+                 (function-lambda-expression (third record))
+               (multiple-value-bind (prepared-macro-form new-temp-interned-sym)
+                   (prepare-form macro-form macro-lexenv)
+                 (setf form `(macrolet ((,(car record) (&whole whole &environment env)
+                                          (funcall ,prepared-macro-form whole env)))
+                               ,form)
+                       temp-interned-sym (append temp-interned-sym new-temp-interned-sym))))))
+  (loop for record in (car lexenv)
+        do (when (and (eq (second record) 'si:symbol-macro)
+                      (typep (third record) 'function))
+             (multiple-value-bind (prepared-macro-form new-temp-interned-sym)
+                 (prepare-form (funcall (third record) (car record) nil)
+                               (nth-value (function-lambda-expression (third record)) 1))
+               (setf form `(symbol-macrolet ((,(car record) ,prepared-macro-form))
+                             ,form)
+                     temp-interned-sym (append temp-interned-sym new-temp-interned-sym)))))
+  (values form temp-interned-sym))
+
+(defun intern-symbols (form)
+  ;; Import all uninterned symbols into temporary packages to allow
+  ;; them to be sent to the remote. Each symbol gets its own package
+  ;; to avoid name conflicts.
+  (cond ((and (symbolp form) (null (symbol-package form)))
+         (import form (make-package (symbol-name (gensym)) :use nil))
+         (list form))
+        ((consp form)
+         (nconc (intern-symbols (car form))
+                (intern-symbols (cdr form))))
+        (t
+         nil)))
+
+(defun remote-intern-symbols (remote symbols)
+  (send-command remote
+                `(progn
+                   (mapc #'(lambda (n)
+                             (make-package n :use nil))
+                         ',(mapcar (lambda (s)
+                                     (package-name (symbol-package s)))
+                                   symbols))
+                   (values))))
+
+(defun intern-symbols-host-and-remote (remote form)
+  (remote-intern-symbols remote (intern-symbols form)))
+
+(defun prepare-form (form lexenv)
+  ;; Adjoin lexical environment
+  (let ((c::*cmp-env* (copy-tree c::*cmp-env-root*))
+        (temporarily-interned-symbols nil))
+    (setf form (c::set-closure-env form lexenv))
+    (multiple-value-setq (form temporarily-interned-symbols)
+      (adjoin-macros form c::*cmp-env* temporarily-interned-symbols))
+    (setf temporarily-interned-symbols
+          (append temporarily-interned-symbols (intern-symbols form)))
+    (let ((si::*code-walker* #'collect-literal-objects))
+      (si::eval-with-env form c::*cmp-env* nil t :compile-toplevel))
+    (setf form (replace-literal-objects form))
+    (values form temporarily-interned-symbols)))
+
+(defun filter-readable-objects (obj)
+  (with-standard-io-syntax
+    (let ((printed-representation
+            (handler-case
+                (write-to-string obj :circle t)
+              (print-not-readable () (return-from filter-readable-objects nil)))))
+      ;; If the string contains #$, we are probably dealing with a
+      ;; random state object which is not portable across
+      ;; architectures with different word sizes.
+      (and (not (search "#$" printed-representation)) obj))))
+
+;;; Cross compilation setup
+
+(defun setup (target-info startup-code)
+  (multiple-value-bind (ignored ignored remote)
+      (ext:run-program (ext:getenv "ECL_TO_RUN")
+                       '("--norc")
+                       :wait nil
+                       :environ (remove-if #'(lambda (x)
+                                               (string= (subseq x 0 6) "ECLDIR"))
+                                           (ext:environ)))
+    (declare (ignore ignored))
+    (let ((host-*make-special (fdefinition 'si::*make-special))
+          (host-do-deftype (fdefinition 'si::do-deftype))
+          (host-proclaim (fdefinition 'proclaim)))
+      (labels ((mirror-*make-special (sym)
+                 (funcall host-*make-special sym)
+                 (intern-symbols-host-and-remote remote sym)
+                 (send-command remote `(si::*make-special ',sym)))
+               (mirror-do-deftype (name form function)
+                 (funcall host-do-deftype name form function)
+                 (intern-symbols-host-and-remote remote form)
+                 (send-command remote form))
+               (mirror-proclaim (&rest args)
+                 (apply host-proclaim args)
+                 (intern-symbols-host-and-remote remote args)
+                 (send-command remote `(apply 'proclaim ',args)))
+               (remote-compile-file (file &rest args)
+                 (setf file (truename file))
+                 (copy-file-to-remote remote file)
+                 (let ((load-flag (getf args :load))
+                       (output-file (getf args :output-file)))
+                   (remf args :load)
+                   (remf args :output-file)
+                   (multiple-value-bind (compiled-file warnings error)
+                       (send-command remote
+                                     `(compile-file ,file ,@args :target *target*))
+                     (unless error
+                       (copy-file-from-remote remote compiled-file)
+                       (when output-file
+                         (setf compiled-file
+                               (nth-value 2 (rename-file compiled-file output-file
+                                                         :if-exists :supersede))))
+                       (when load-flag
+                         (load compiled-file)))
+                     (values compiled-file warnings error))))
+               (remote-compile (name &optional (def nil supplied-p))
+                 (let (form temporarily-interned-symbols
+                            (lexenv nil)
+                            (fname (or name 'C::GAZONK))
+                            (file "x.lisp"))
+                   (cond ((and supplied-p def)
+                          (when (functionp def)
+                            (unless (function-lambda-expression def)
+                              (return-from remote-compile def))
+                            (multiple-value-setq (def lexenv)
+                              (function-lambda-expression def))
+                            (when (eq lexenv t)
+                              (warn "COMPILE can not compile C closures")
+                              (return-from remote-compile (values def t nil)))))
+                         ((not (fboundp name))
+                          (error "Symbol ~s is unbound." name))
+                         ((typep (setf def (fdefinition name)) 'standard-generic-function)
+                          (warn "COMPILE can not compile generic functions yet")
+                          (return-from remote-compile (values def t nil)))
+                         ((null (setq def (function-lambda-expression def)))
+                          (warn "We have lost the original function definition for ~s. Compilation to C failed"
+                                name)
+                          (return-from remote-compile (values def t nil))))
+                   ;; Prepare form
+                   (setf (fill-pointer *literal-objects*) 0)
+                   (multiple-value-setq (form temporarily-interned-symbols)
+                     (prepare-form `(setf (fdefinition ',fname) #',def)
+                                   lexenv))
+                   (remote-intern-symbols remote temporarily-interned-symbols)
+                   (send-command remote `(progn
+                                           (setq *literal-objects* ,(map 'vector #'filter-readable-objects *literal-objects*))
+                                           (values)))
+                   ;; Write to file
+                   (with-open-file (s file
+                                      :direction :output
+                                      :if-does-not-exist :create
+                                      :if-exists :supersede
+                                      :external-format :utf-8)
+                     (with-standard-io-syntax
+                       (print '(in-package #:cl-user) s)
+                       (print form s)))
+                   ;; Compile file remotely
+                   (multiple-value-bind (compiled-file warnings error)
+                       (remote-compile-file file)
+                     ;; Load compiled fasl
+                     (unless error
+                       (load compiled-file)
+                       (setf name (or name (fdefinition fname))))
+                     ;; Clean up uninterned symbols
+                     (send-command remote `(progn
+                                             (mapc #'(lambda (s)
+                                                       (let ((p (symbol-package s)))
+                                                         (unintern s p)
+                                                         (delete-package p)))
+                                                   ',temporarily-interned-symbols)
+                                             (values)))
+                     (mapc #'(lambda (s)
+                               (let ((p (symbol-package s)))
+                                 (unintern s p)
+                                 (delete-package p)))
+                           temporarily-interned-symbols)
+                     ;; Return values
+                     (values name warnings error)))))
+        (skip-forward-to-first-prompt remote)
+        (prin1 `(setf si::*tpl-prompt-hook* " :input-prompt ") (ext:external-process-input remote))
+        (terpri (ext:external-process-input remote))
+        (skip-forward-to-prompt remote)
+        (prin1 `(progn (cl:defpackage "CL-TEST-CROSS-COMPILE" (:use "CL")) (values))
+               (ext:external-process-input remote))
+        (terpri (ext:external-process-input remote))
+        (send-command remote `(in-package #:cl-test-cross-compile) t)
+        (send-command remote `(require :cmp) t)
+        (send-command remote `(defvar *target* ',(c::read-target-info target-info)) t)
+        (send-command remote startup-code t)
+        (send-command remote `(defvar *literal-objects*) t)
+        (let ((si::*ignore-package-locks* t))
+          (setf (fdefinition 'si::*make-special) #'mirror-*make-special
+                (fdefinition 'si::do-deftype) #'mirror-do-deftype
+                (fdefinition 'proclaim) #'mirror-proclaim
+                (fdefinition 'compile-file) #'remote-compile-file
+                (fdefinition 'compile) #'remote-compile))
+        (setf *remote* remote)))))

src/tests/ecl-tests.asd

@@ -8,6 +8,7 @@
   :components ((:file "1am")            ; for stress tests
                (:file "2am")            ; continuous integration
                (:file "ecl-tests")
+               (:file "cross-compile")
                (:file "universe")
                (:module normal-tests
                         :default-component-class asdf:cl-source-file.lsp
@@ -24,7 +25,7 @@
                          (:file "metaobject-protocol" :if-feature :clos)
                          (:file "ieee-fp" :if-feature :ieee-floating-point)
                          (:file "package-extensions")
-			 (:file "hash-tables")
+			                (:file "hash-tables")
                          (:file "external-formats" :if-feature :unicode)
                          (:file "unicode" :if-feature :unicode)
                          (:file "complex")
@@ -34,7 +35,7 @@
                         :default-component-class asdf:cl-source-file.lsp
                         :components
                         ((:file "multiprocessing" :if-feature :threads)
-			 (:file "thread-sync-interrupt" :if-feature :threads)))))
+			                (:file "thread-sync-interrupt" :if-feature :threads)))))
 
 (asdf:defsystem #:ecl-tests/stress
   :serial t

src/tests/normal-tests/compiler.lsp

@@ -1937,10 +1937,10 @@
 ;;; MULTIPLE-VALUE-SETQ would wrongly assign NIL to special variables
 ;;; due to not saving env->nvalues before calling SET
 (ext:with-clean-symbols (*a* *b* foo)
-  (defvar *a* :wrong-a)
-  (defvar *b* :wrong-b)
-  (defun foo () (values :right-a :right-b))
   (test cmp.0081.m-v-setq-special
+    (defvar *a* :wrong-a)
+    (defvar *b* :wrong-b)
+    (defun foo () (values :right-a :right-b))
     (is (funcall (compile
                   nil
                   '(lambda ()
@@ -2142,20 +2142,19 @@
 ;;;     inline the new definition (e.g. because it is a closure).
 ;;;
 (test cmp.0092.inline-redefinition
-  (setf (compiler-macro-function 'foo) nil)
   (finishes (with-compiler ("inline-redefinition-1.lsp" :load t)
-              '(declaim (inline foo))
+              '(declaim (inline foo.0092))
-              '(defun foo () 1)
+              '(defun foo.0092 () 1)
-              '(defun bar () (foo))))
+              '(defun bar.0092 () (foo.0092))))
-  (is (eql (bar) 1))
+  (is (eql (bar.0092) 1))
   (finishes (with-compiler ("inline-redefinition-2.lsp" :load t)
               '(let ((a 2))
                 (defun ensure-compiler-cannot-optimize-away-the-let-statement (x)
                   (setf a x))
-                (defun foo ()
+                (defun foo.0092 ()
                   a))
-              '(defun bar () (foo))))
+              '(defun bar.0092 () (foo.0092))))
-  (is (eql (bar) 2)))
+  (is (eql (bar.0092) 2)))
 
 ;;; Date 2023-06-18
 ;;; Description
@@ -2591,3 +2590,15 @@
                                       (go :package))
                                   :symbol
                                     (return 42)))))))))
+
+;;; Date 2025-11-15
+;;; Description
+;;;
+;;;     Target dependent constants were folded incorrectly during
+;;;     cross compilation
+;;;
+(deftest cmp.0111.cross-compilation-constant-fold ()
+  (= (funcall (compile nil
+                       '(lambda ()
+                         (- most-positive-fixnum 3))))
+     (- most-positive-fixnum 3)))

src/util/test-cross-compilation.sh

@@ -6,16 +6,74 @@
 # to install additional packages for that (for example on debian, the
 # gcc-multilib package is needed).
 #
+# Additional configure options for the host and target system may be
+# given in the environment variables HOST_CONFIGURE_OPTS and
+# TARGET_CONFIGURE_OPTS. This allows for instance to test cross
+# compilation with mismatching features in both systems.
+#
 # Four versions of ECL will be compiled:
 # - ecl-x86[_64]-native: direct (i.e. same host and target) x86[_64] build
 # - ecl-x86[_64]-native: cross build for x86[_64] target
 #
 # The results of running the test suite will be put in the files
-# test-results-x86[_64]-[native/cross]. It is recommended to also run
+# test-results/[make-check/ansi-test]-x86[_64]-[native/cross-core/cross-user].
-# the ansi-tests for the output binaries.
+# The difference between cross-core and cross-user is that for the
+# former, only the ECL core is cross compiled while the tests are run
+# natively while for the latter both ECL core and the tests are cross
+# compiled.
 #
 set -e
-rm -rf build/; CFLAGS="-g -O2" ./configure --prefix=`pwd`/ecl-x86_64-native && make -j${JOBS} && rm -rf ecl-x86_64-native && make install && make check > test-results-x86_64-native
+
-rm -rf build/; ABI=32 CFLAGS="-g -O2 -m32" LDFLAGS="-m32" ./configure --prefix=`pwd`/ecl-x86-native && make -j${JOBS} && rm -rf ecl-x86-native && make install && make check > test-results-x86-native
+mkdir -p test-results
-rm -rf build/; CFLAGS="-g -O2" ECL_TO_RUN=`pwd`/ecl-x86-native/bin/ecl ./configure --prefix=`pwd`/ecl-x86_64-cross --build=x86_64-pc-linux-gnu --host=x86-pc-linux-gnu --with-cross-config=`pwd`/src/util/x86_64-linux-gnu.cross_config && make -j${JOBS} && rm -rf ecl-x86_64-cross && make install && make check > test-results-x86_64-cross
+rm -rf build/
-rm -rf build/; ABI=32 CFLAGS="-g -O2 -m32" LDFLAGS="-m32" ECL_TO_RUN=`pwd`/ecl-x86_64-native/bin/ecl ./configure --prefix=`pwd`/ecl-x86-cross --build=x86-pc-linux-gnu --host=x86_64-pc-linux-gnu --with-cross-config=`pwd`/src/util/x86-linux-gnu.cross_config && make -j${JOBS} && rm -rf ecl-x86-cross && make install && make check > test-results-x86-cross
+CFLAGS="-g -O2" ./configure --prefix=`pwd`/ecl-x86_64-native ${HOST_CONFIGURE_OPTS}
+make -j4
+rm -rf ecl-x86_64-native
+make install
+set +e
+make check > test-results/make-check-x86_64-native
+make ansi-test > test-results/ansi-test-x86_64-native
+
+set -e
+rm -rf build/
+ABI=32 CFLAGS="-g -O2 -m32" LDFLAGS="-m32" ./configure --prefix=`pwd`/ecl-x86-native ${HOST_CONFIGURE_OPTS}
+make -j4
+rm -rf ecl-x86-native
+make install
+set +e
+make check > test-results/make-check-x86-native
+make ansi-test > test-results/ansi-test-x86-native
+
+set -e
+rm -rf build/
+CFLAGS="-g -O2" ECL_TO_RUN=`pwd`/ecl-x86-native/bin/ecl ./configure --prefix=`pwd`/ecl-x86_64-cross --build=x86-pc-linux-gnu --host=x86_64-pc-linux-gnu --with-cross-config=`pwd`/src/util/x86_64-linux-gnu.cross_config ${TARGET_CONFIGURE_OPTS}
+make -j4
+rm -rf ecl-x86_64-cross
+make install
+set +e
+make check > test-results/make-check-x86_64-cross-core
+ECL_TO_RUN=`pwd`/ecl-x86-native/bin/ecl make cross-check > test-results/make-check-x86_64-cross-user
+make ansi-test > test-results/ansi-test-x86_64-cross-core
+cp src/tests/ansi-test-expected-failures.sexp build/tests/ansi-test/expected-failures/ecl.sexp
+# Bugs
+echo "EPSILONS.8 EPSILONS.12" >> build/tests/ansi-test/expected-failures/ecl.sexp
+# Test framework issues
+echo "EVAL-WHEN.1 DEFINE-COMPILER-MACRO.3 DEFINE-COMPILER-MACRO.8 COMPILE-FILE.3 COMPILE-FILE.15 COMPILE-FILE.19 MISC.629 MISC.638" >> build/tests/ansi-test/expected-failures/ecl.sexp
+ECL_TO_RUN=`pwd`/ecl-x86-native/bin/ecl EXPECTED_FAILURES="ansi-test/expected-failures/ecl.sexp" make cross-ansi-test > test-results/ansi-test-x86_64-cross-user
+
+set -e
+rm -rf build/
+CFLAGS="-g -O2 -m32" LDFLAGS="-m32" ECL_TO_RUN=`pwd`/ecl-x86_64-native/bin/ecl ./configure --prefix=`pwd`/ecl-x86-cross --build=x86_64-pc-linux-gnu --host=x86-pc-linux-gnu --with-cross-config=`pwd`/src/util/x86-linux-gnu.cross_config ${TARGET_CONFIGURE_OPTS}
+make -j4
+rm -rf ecl-x86-cross
+make install
+set +e
+make check > test-results/make-check-x86-cross-core
+ECL_TO_RUN=`pwd`/ecl-x86_64-native/bin/ecl make cross-check > test-results/make-check-x86-cross-user
+make ansi-test > test-results/ansi-test-x86-cross-core
+cp src/tests/ansi-test-expected-failures.sexp build/tests/ansi-test/expected-failures/ecl.sexp
+# Bugs
+echo "EPSILONS.1 EPSILONS.2 EPSILONS.8 EPSILONS.12" >> build/tests/ansi-test/expected-failures/ecl.sexp
+# Test framework issues
+echo "EVAL-WHEN.1 DEFINE-COMPILER-MACRO.3 DEFINE-COMPILER-MACRO.8 COMPILE-FILE.3 COMPILE-FILE.15 COMPILE-FILE.19 MISC.629 MISC.638" >> build/tests/ansi-test/expected-failures/ecl.sexp
+ECL_TO_RUN=`pwd`/ecl-x86_64-native/bin/ecl EXPECTED_FAILURES="ansi-test/expected-failures/ecl.sexp" make cross-ansi-test > test-results/ansi-test-x86-cross-user