mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cross-compilation' into 'develop'

Browse source 
Cross-compilation of user code

See merge request embeddable-common-lisp/ecl!358
This commit is contained in:
Daniel Kochmański 2025-11-22 20:39:50 +00:00
commit 7933468deb
44 changed files with 2537 additions and 1244 deletions
Download patch file Download diff file Expand all files Collapse all files

6
Makefile.in
View file

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

7
contrib/bytecmp/bytecmp.lsp
View file

@ -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 ()

11
src/Makefile.in
View file

@ -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.

6
src/aclocal.m4 vendored
View file

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

2
src/bare.lsp.in
View file

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

42
src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp
View file

@ -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
#+dlopen :shared-library
#-dlopen :static-library)
(probe-file (merge-pathnames (compile-file-pathname
"ecl" :type (if (member :dlopen *features*)
: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
(setf ld-flags (list* "-shared" ld-flags))
(when (member :mingw32 *features*)
(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
(setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags))
(when (member :mingw32 *features*)
(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
(:console +lisp-program-main+)
(:windows +lisp-program-winmain+))
#-:win32 +lisp-program-main+
(ecase system
(:console +lisp-program-main+)
(:windows +lisp-program-winmain+))
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
(error "Dynamically loadable libraries not supported in this system.")
#+dlopen
(apply #'builder :shared-library args))
(if (member :dlopen *features*)
(apply #'builder :shared-library args)
(error "Dynamically loadable libraries not supported in this system.")))

2
src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp
View file

@ -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*))))

6
src/cmp/cmpbackend-cxx/cmpc-mach.lsp
View file

@ -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")
(:cdfloat si::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")
(:csfloat (complex single-float) "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat")
(:cdfloat (complex double-float) "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat")
(: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")

8
src/cmp/cmpbackend-cxx/cmpc-util.lsp
View file

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

50
src/cmp/cmpbackend-cxx/cmppass2-data.lsp
View file

@ -59,19 +59,18 @@
(defun data-c-dump (filename)
(labels ((produce-strings ()
;; Only Windows has a size limit in the strings it creates.
#-windows
(let ((s (data-dump-array)))
(when (plusp (length s))
(list s)))
#+windows
(loop with string = (data-dump-array)
with max-string-size = 65530
with l = (length string)
for i from 0 below l by max-string-size
for this-l = (min (- l i) max-string-size)
collect (make-array this-l :displaced-to string
:element-type (array-element-type string)
:displaced-index-offset i)))
(if (member :windows *features*)
(loop with string = (data-dump-array)
with max-string-size = 65530
with l = (length string)
for i from 0 below l by max-string-size
for this-l = (min (- l i) max-string-size)
collect (make-array this-l :displaced-to string
:element-type (array-element-type string)
:displaced-index-offset i))
(let ((s (data-dump-array)))
(when (plusp (length s))
(list s)))))
(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
(si:complex-single-float #'static-csfloat-builder)
#+complex-float
(si:complex-double-float #'static-cdfloat-builder)
#+complex-float
(si:complex-long-float #'static-clfloat-builder)
(complex (and (static-constant-expression (realpart object))
(static-constant-expression (imagpart object))
#'static-complex-builder))
(complex
(when (and (static-constant-expression (realpart object))
(static-constant-expression (imagpart object)))
(if *complex-float*
(typecase (realpart object)
(single-float #'static-csfloat-builder)
(double-float #'static-cdfloat-builder)
(long-float #'static-clfloat-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)

2
src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
View file

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

37
src/cmp/cmpbackend-cxx/cmppass2-top.lsp
View file

@ -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
nil
#+c-compatible-variadic-dispatch
(and (fun-needs-narg fun)
(and *c-compatible-variadic-dispatch*
(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
(wt-return (fun-required-lcls fun))
#+c-compatible-variadic-dispatch
(let ((maxargs (min (fun-maxarg fun) (1+ si:c-arguments-limit))))
(when (plusp maxargs)
(wt-nl "cl_object x[" maxargs "];")
(wt-nl "va_list args; va_start(args,narg);")
(loop for i below maxargs
do (wt-nl "x[" i "] = ") (wt-coerce-loc :object 'VA-ARG) (wt ";"))
(wt-nl "va_end(args);"))
(let ((args (loop for i below maxargs
collect (concatenate 'string "x[" (write-to-string i) "]"))))
(wt-return args)))))
(if (not *c-compatible-variadic-dispatch*)
(wt-return (fun-required-lcls fun))
(let ((maxargs (min (fun-maxarg fun) (1+ si:c-arguments-limit))))
(when (plusp maxargs)
(wt-nl "cl_object x[" maxargs "];")
(wt-nl "va_list args; va_start(args,narg);")
(loop for i below maxargs
do (wt-nl "x[" i "] = ") (wt-coerce-loc :object 'VA-ARG) (wt ";"))
(wt-nl "va_end(args);"))
(let ((args (loop for i below maxargs
collect (concatenate 'string "x[" (write-to-string i) "]"))))
(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 (or (fun-variadic-entrypoint fun) (fun-c-compatible-variadic-signature fun))
(when (and *c-compatible-variadic-dispatch*
(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))

6
src/cmp/cmpbackend-cxx/cmppass2-var.lsp
View file

@ -32,9 +32,9 @@
(:float . "_ecl_float_loc")
(:double . "_ecl_double_loc")
(:long-double . "_ecl_long_double_loc")
#+complex-float (:csfloat . "_ecl_csfloat_loc")
#+complex-float (:cdfloat . "_ecl_cdfloat_loc")
#+complex-float (:clfloat . "_ecl_clfloat_loc")
(:csfloat . "_ecl_csfloat_loc")
(:cdfloat . "_ecl_cdfloat_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")

98
src/cmp/cmpdefs.lsp
View file

@ -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@"
"This variable controls how the C compiler is invoked by ECL.
(defconfig *cc* "@ECL_CC@"
"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@"
"This variable controls the linker which is used by ECL.")
(defconfig *ld* "@ECL_CC@"
"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"
#+msvc "@CFLAGS_OPTIMIZE@")
(defconfig *cc-optimize* #-msvc "-O2"
#+msvc "@CFLAGS_OPTIMIZE@")
(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@[~S~]~{ '~A'~} ~A"
#+msvc "~A -Fe~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")
(defvar *cc-format* (cond ((member :msvc *features*)
"~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")
((member :nacl *features*) ;; pnacl-clang doesn't support -w
"~A -I. \"-I~A\" ~A ~:[~*~;~A~] -c \"~A\" -o \"~A\"~{ '~A'~}")
(t
"~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")))
(defconfig *cc-format* (cond ((member :msvc *features*)
"~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}")
((member :nacl *features*) ;; pnacl-clang doesn't support -w
"~A -I. \"-I~A\" ~A ~:[~*~;~A~] -c \"~A\" -o \"~A\"~{ '~A'~}")
(t
"~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@"
#+msvc "ecl.lib @CLIBS@")
#+dlopen
(defvar *ld-shared-flags* "@SHARED_LDFLAGS@ @LDFLAGS@")
#+dlopen
(defvar *ld-bundle-flags* "@BUNDLE_LDFLAGS@ @LDFLAGS@")
(defvar *ld-program-flags* "@PROGRAM_LDFLAGS@ @LDFLAGS@")
(defconfig *ld-libs* #-msvc "-lecl @FASL_LIBS@ @LIBS@"
#+msvc "ecl.lib @CLIBS@")
(defconfig *ld-shared-flags* #+dlopen "@SHARED_LDFLAGS@ @LDFLAGS@")
(defconfig *ld-bundle-flags* #+dlopen "@BUNDLE_LDFLAGS@ @LDFLAGS@")
(defconfig *ld-program-flags* "@PROGRAM_LDFLAGS@ @LDFLAGS@")
(defvar +shared-library-prefix+ "@SHAREDPREFIX@")
(defvar +shared-library-extension+ "@SHAREDEXT@")
(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
(defvar +static-library-prefix+ "@LIBPREFIX@")
(defvar +static-library-extension+ "@LIBEXT@")
(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
(defvar +object-file-extension+ "@OBJEXT@")
(defvar +executable-file-format+ "~a@EXEEXT@")
(defconfig +shared-library-prefix+ "@SHAREDPREFIX@")
(defconfig +shared-library-extension+ "@SHAREDEXT@")
(defconfig +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
(defconfig +static-library-prefix+ "@LIBPREFIX@")
(defconfig +static-library-extension+ "@LIBEXT@")
(defconfig +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
(defconfig +object-file-extension+ "@OBJEXT@")
(defconfig +executable-file-format+ "~a@EXEEXT@")
(defvar *ecl-include-directory* "@includedir\@/")
(defvar *ecl-library-directory* "@libdir\@/")
(defvar *ecl-data-directory* "@ecldir\@/")
(defconfig *ecl-include-directory* "@includedir\@/")
(defconfig *ecl-library-directory* "@libdir\@/")
(defconfig *ecl-data-directory* "@ecldir\@/")
(defvar *ld-rpath*
(let ((x "@ECL_LDRPATH@"))
(and (plusp (length x))
(format nil x *ecl-library-directory*))))
(defconfig *ld-rpath*
(let ((x "@ECL_LDRPATH@"))
(and (plusp (length x))
(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@")

26
src/cmp/cmpenv-api.lsp
View file

@ -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*))
(when (or (constant-variable-p name) (special-variable-p name))
(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*) force)
(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)))

2
src/cmp/cmpenv-declare.lsp
View file

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

14
src/cmp/cmpenv-fun.lsp
View file

@ -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)
(si:put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
(rem-property fname 'PROCLAIMED-ARG-TYPES destination)
(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)
(si:put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(rem-property fname 'PROCLAIMED-RETURN-TYPE destination)
(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)))

7
src/cmp/cmpfun.lsp
View file

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

13
src/cmp/cmpglobals.lsp
View file

@ -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*
(cons nil (list (list '#:no-macro 'si:macro (constantly nil))))
(defconfig *cmp-env-root*
(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))

79
src/cmp/cmpmain.lsp
View file

@ -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
(unless system-p
(when target
(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)
(declare (ignore options))
`(progn ,@body))
(defun compile-with-target-info (closure target-info)
(check-type target-info (or list pathname-designator))
(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)

2
src/cmp/cmpopt-constant.lsp
View file

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

30
src/cmp/cmpopt.lsp
View file

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

5
src/cmp/cmppackage.lsp
View file

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

2
src/cmp/cmppass1-call.lsp
View file

@ -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

7
src/cmp/cmppass1-ffi.lsp
View file

@ -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")
#+complex-float (:cdfloat . "ECL_FFI_CDFLOAT")
#+complex-float (:clfloat . "ECL_FFI_CLFLOAT")
(:csfloat . "ECL_FFI_CSFLOAT")
(:cdfloat . "ECL_FFI_CDFLOAT")
(:clfloat . "ECL_FFI_CLFLOAT")
(:void . "ECL_FFI_VOID")))
(defun foreign-elt-type-code (type)

2
src/cmp/cmppass1-special.lsp
View file

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

4
src/cmp/cmppass1-top.lsp
View file

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

2
src/cmp/cmptype.lsp
View file

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

43
src/cmp/cmputil.lsp
View file

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

2
src/cmp/load.lsp.in
View file

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

84
src/cmp/proclamations.lsp
View file

@ -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
name (list arg-types return-type))
(proclaim-function name (list arg-types return-type) *static-proclamations*)
(loop for p in properties
do (case p
(:no-sp-change
(si:put-sysprop name 'no-sp-change t))
((:predicate :pure)
(si:put-sysprop name 'pure t)
(si:put-sysprop name 'no-side-effects t))
((:no-side-effects :reader)
(si:put-sysprop name 'no-side-effects t))
(otherwise
(error "Unknown property ~S in function proclamation for ~S"
p name)))))
do (case p
(:no-sp-change
(put-property name 'no-sp-change t *static-proclamations*))
((:predicate :pure)
(put-property name 'pure t *static-proclamations*)
(put-property name 'no-side-effects t *static-proclamations*))
((:no-side-effects :reader)
(put-property name 'no-side-effects t *static-proclamations*))
(otherwise
(error "Unknown property ~S in function proclamation for ~S"
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
(loop for i in '#.(mapcar #'rest +proclamations+)
do (apply #'parse-function-proclamation i))
(defun collect-proclamations ()
(let ((*static-proclamations* (make-hash-table :test 'equal :size 1024)))
(declare (special *static-proclamations*))
(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))

28
src/compile.lsp.in
View file

@ -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"
#-(or windows cygwin mingw32) "build:@ECL_MIN@")
(if (intersection '(:windows :cygwin :mingw32) *host-features*)
"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@/**/*.*")))

2233
src/configure vendored
View file

File diff suppressed because it is too large Load diff

207
src/doc/manual/extensions/building.txi
View file

@ -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

52
src/doc/manual/standards/sys-constr.txi
View file

@ -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

7
src/lsp/autoload.lsp
View file

@ -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.

21
src/lsp/loop.lsp
View file

@ -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)
(> limit-value most-negative-fixnum))
(typep (1+ limit-value) 'fixnum *loop-macro-environment*)
(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)

72
src/lsp/predlib.lsp
View file

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

13
src/tests/Makefile.in
View file

@ -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

34
src/tests/config.lsp.in
View file

@ -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" ,(namestring (make-pathname
:directory (list :relative suite)
:name "load"
:type "lsp"))))
"-load" "gclload1.lsp"
"-load" ,(namestring (make-pathname
:directory (list :relative suite)
:name "load"
:type "lsp"))))
(t
`("-load" "ansi-test/init.lsp")))
"-eval" ,(format nil "(rt:do-tests :exit t :expected-failures ~s)"
(merge-pathnames #P"tests/ansi-test-expected-failures.sexp"
*ecl-sources*)))
,@(when cross-compile
`("-load" ,(namestring (truename (merge-pathnames "tests/cross-compile.lisp" *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))))

399
src/tests/cross-compile.lisp Normal file
View file

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

5
src/tests/ecl-tests.asd
View file

@ -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

33
src/tests/normal-tests/compiler.lsp
View file

@ -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))
'(defun foo () 1)
'(defun bar () (foo))))
(is (eql (bar) 1))
'(declaim (inline foo.0092))
'(defun foo.0092 () 1)
'(defun bar.0092 () (foo.0092))))
(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))))
(is (eql (bar) 2)))
'(defun bar.0092 () (foo.0092))))
(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)))

70
src/util/test-cross-compilation.sh
View file

@ -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
# the ansi-tests for the output binaries.
# test-results/[make-check/ansi-test]-x86[_64]-[native/cross-core/cross-user].
# 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
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/; 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
mkdir -p test-results
rm -rf build/
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