Merge branch 'cmp-cleanups' into 'develop'

cmp: various cleanups

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

.gitignore

@@ -4,6 +4,7 @@
 \#*
 
 /build
+/local
 cov-int
 
 *.data

msvc/Makefile

@@ -231,7 +231,7 @@ c\cut$(EXE): $(top_srcdir)\util\cut.c
 	$(MAKE) cut$(EXE)
 	cd ..
 
-$(TARGETS): $(UCDDAT) ecl_min$(EXE) compile.lsp sysfun.lsp BUILD-STAMP
+$(TARGETS): $(UCDDAT) ecl_min$(EXE) compile.lsp BUILD-STAMP
 	set ECLDIR=./
 	ecl_min compile
 BUILD-STAMP: Makefile
@@ -377,9 +377,6 @@ eclgmp.lib:
 	$(CP) gmp.h ..\ecl\gmp.h
 	cd ..
 
-sysfun.lsp:
-	$(CP) $(srcdir)\cmp\sysfun.lsp .\
-
 install:
 	IF NOT EXIST "$(prefix)" $(MKDIR) "$(prefix)"
 	IF NOT EXIST "$(bindir)" $(MKDIR) "$(bindir)"
@@ -454,7 +451,7 @@ clean: clean_ecl clean_lisp
 clean_ecl:
 	-for %i in (eclgc.lib eclgmp.lib lsp\config.lsp compile.lsp bare.lsp \
 	            lsp\load.lsp clos\load.lsp cmp\load.lsp cmp\cmpdefs.lsp \
-		    ecl.lib ecl.dll ecl_min$(EXE) eclmin.lib help.doc sysfun.lsp \
+		    ecl.lib ecl.dll ecl_min$(EXE) eclmin.lib help.doc \
 		    BUILD-STAMP $(TARGETS) *.exp *.ilk *.manifest *.pdb *.c *.obj \
 		    ecl-config.bat ecl-static.lib *.tmp *.implib *.lib ecl.ico \
 		    ecl-cc.bat ecl.rc ecl.res) \

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

@@ -0,0 +1,760 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
+;;;;  Copyright (c) 1990, Giuseppe Attardi
+;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll
+;;;;  Copyright (c) 2023, Daniel Kochmański
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;; CMPBACKEND-CXX -- backend for compiling to C99/C++ and then invoking the
+;;;; external compiler.
+
+(in-package "COMPILER")
+
+
+;;; External tool wrappers
+(defun safe-mkstemp (template)
+  ;; We do several things here. One is to check for success in MKSTEMP,
+  ;; the other one is to ensure that the output of this function _always_
+  ;; carries a file type -- this solves a problem with filesystems where
+  ;; mkstemp may introduce one or more dots in the name causing several
+  ;; functions below to ignore parts of the name. Note that this forces
+  ;; us to have two files per temp: one with and one without extension.
+  (let ((base (ext:mkstemp template)))
+    (unless base
+      (error "Unable to create temporary file~%~
+        ~AXXXXXX
+Make sure you have enough free space in disk, check permissions or set~%~
+the environment variable TMPDIR to a different value." template))
+    (let ((output (make-pathname :name
+                                 (concatenate 'string (pathname-name base)
+                                              (or (pathname-type base) ""))
+                                 :type "tmp"
+                                 :defaults base)))
+      (if (and (not (probe-file output))
+               (si:copy-file base output))
+          (setf base (list (truename output) (truename base)))
+          (progn (delete-file base)
+                 (setf base nil))))
+    base))
+
+#+msvc
+(defun delete-msvc-generated-files (output-pathname)
+  (loop for i in '("implib" "exp" "ilk" )
+        for full = (make-pathname :type i :defaults output-pathname)
+        for truename = (probe-file full)
+        when truename
+        do (cmp-delete-file truename)))
+
+#+msvc
+(defun embed-manifest-file (o-file &optional (type :dll))
+  (let* ((real-file (probe-file o-file)))
+    (when real-file
+      (let* ((manifest-namestring (concatenate 'string (namestring o-file)
+                                               ".manifest"))
+             (resource-code (ecase type
+                              ((:dll :shared-library :fasl :fas) 2)
+                              ((:program) 1)))
+             (resource-option (format nil "-outputresource:~A;~D"
+                                      (namestring real-file)
+                                      resource-code))
+             (manifest (probe-file manifest-namestring)))
+        (when manifest
+          (safe-run-program "mt"
+                            (list "-nologo"
+                                  "-manifest"
+                                  manifest-namestring
+                                  resource-option))
+          (delete-file manifest))))))
+
+(defun cmp-delete-file (file)
+  (cond ((null *delete-files*))
+        ((ext:getenv "ECL_PRESERVE_FILES"))
+        ((null (probe-file file)))
+        (*debug-compiler*
+         (cmpprogress "~%Postponing deletion of ~A" file)
+         (push file *files-to-be-deleted*))
+        (t
+         (delete-file file))))
+
+(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
+      si::*exit-hooks*)
+
+#-mingw32
+(defmacro fix-for-mingw (directory-namestring)
+  directory-namestring)
+
+#+mingw32
+(defun fix-for-mingw (directory-namestring)
+  (let ((x (string-right-trim '(#\\ #\/) directory-namestring)))
+    (if (zerop (length x)) "/" x)))
+
+(defun get-deprecated-user-ld-flags ()
+  (let ((flags (split-program-options *user-ld-flags*)))
+    (when flags
+      (cmpwarn "The variable ~s is deprecated, please use ~s and ~s instead."
+              '*user-ld-flags* '*user-linker-flags* '*user-linker-libs*))
+    flags))
+
+#+msvc
+(defun linker-cc (o-pathname object-files &key
+                  (type :program)
+                  (ld-flags (split-program-options *ld-flags*))
+                  (ld-libs (split-program-options *ld-libs*)))
+  (safe-run-program
+   *ld*
+   `(,(concatenate 'string "-Fe" (brief-namestring o-pathname))
+     ,@(split-program-options *ld-rpath*)
+     ,@(split-program-options *user-linker-flags*)
+     ,@object-files
+     ,@ld-flags
+     ,@(split-program-options *user-linker-libs*)
+     ,@(get-deprecated-user-ld-flags)
+     ,@ld-libs
+     ,(if (eq type :program)
+          (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib")
+          "")
+     ,(concatenate 'string "/LIBPATH:"
+                   (ecl-library-directory))))
+  (embed-manifest-file o-pathname type)
+  (delete-msvc-generated-files o-pathname))
+
+#-msvc
+(defun linker-cc (o-pathname object-files &key
+                  (type :program)
+                  (ld-flags (split-program-options *ld-flags*))
+                  (ld-libs (split-program-options *ld-libs*)))
+  (declare (ignore type))
+  (safe-run-program
+   *ld*
+   `("-o" ,(brief-namestring o-pathname)
+     ,(concatenate 'string "-L" (fix-for-mingw (ecl-library-directory)))
+     ,@(split-program-options *user-linker-flags*)
+     ,@ld-flags
+     ,@object-files
+     ,@(and *ld-rpath* (list *ld-rpath*))
+     ,@(split-program-options *user-linker-libs*)
+     ,@(get-deprecated-user-ld-flags)
+     ,@ld-libs)))
+
+(defun linker-ar (output-name o-name ld-libs)
+  #-msvc
+  (static-lib-ar (namestring output-name)
+                 (list* (brief-namestring o-name) ld-libs))
+  #+msvc
+  (unwind-protect
+       (progn
+         (with-open-file (f "static_lib.tmp" :direction :output
+                            :if-does-not-exist :create :if-exists :supersede)
+           (format f "/OUT:~A ~A ~{~&\"~A\"~}"
+                   output-name o-name ld-libs))
+         (safe-run-program "link" '("-lib" "-nologo" "@static_lib.tmp")))
+    (when (probe-file "static_lib.tmp")
+      (cmp-delete-file "static_lib.tmp"))))
+
+(defun static-lib-ar (lib object-files)
+  (let ((lib (brief-namestring lib)))
+    (when (probe-file lib)
+      (delete-file lib))
+    (safe-run-program *ar* (list* "cr" lib (mapcar #'brief-namestring object-files)))
+    (safe-run-program *ranlib* (list lib))))
+
+(defun compiler-cc (c-pathname o-pathname)
+  (safe-run-program
+   *cc*
+   `("-I."
+     ,@(precompiled-header-flags)
+     ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory)))
+     ,@(split-program-options *cc-flags*)
+     ,@(and (>= (cmp-env-optimization 'speed) 2)
+            (split-program-options *cc-optimize*))
+     "-c"
+     ,(brief-namestring c-pathname)
+     #-msvc
+     ,@(list "-o" (brief-namestring o-pathname))
+     #+msvc
+     ,(concatenate 'string "-Fo" (brief-namestring o-pathname))
+     ,@(split-program-options *user-cc-flags*))))
+;;; Since the SUN4 assembler loops with big files, you might want to use this:
+;;;   (format nil "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A"
+;;;          *cc* (>= *speed* 2)
+;;;          *include-directory*
+;;;          (namestring c-pathname)
+;;;          (namestring o-pathname)
+;;;          (namestring s-pathname))
+
+
+(defun need-to-dump-precompiled-header ()
+  (let* ((config *precompiled-header-cc-config*)
+         (need-to-dump (or (null config)
+                           (not (eq (svref config 0) *cc*))
+                           (not (eq (svref config 1) (ecl-include-directory)))
+                           (not (eq (svref config 2) *cc-flags*))
+                           (not (eq (svref config 3) *cc-optimize*))
+                           (not (eq (svref config 4) *user-cc-flags*)))))
+    (when need-to-dump
+      (setf *precompiled-header-cc-config*
+            (vector *cc* (ecl-include-directory) *cc-flags*
+                    *cc-optimize* *user-cc-flags*)))
+    need-to-dump))
+
+(defun precompiled-header-flags ()
+  (when *use-precompiled-headers*
+    (when (need-to-dump-precompiled-header)
+      (handler-case
+          (dump-precompiled-header)
+        (error (err)
+          (setf *use-precompiled-headers* nil
+                *precompiled-header-flags* nil
+                *precompiled-header-cc-config* nil)
+          (cmpnote "Disabling precompiled header files due to error:~%  ~A" err))))
+    *precompiled-header-flags*))
+
+#+msvc
+(defun dump-precompiled-header ()
+  ;; The way precompiled headers work on msvc is not compatible with
+  ;; what we want to use them for. The msvc compiler creates a
+  ;; precompiled header file out of ordinary source files by
+  ;; processing them up to a certain point at which all needed headers
+  ;; are included. This creates both a precompiled header and a object
+  ;; file. The object file created by this compilation must be
+  ;; included in all binaries which are linked together from other
+  ;; source files compiled using the precompiled header. Thus, we
+  ;; would need to include the first object file created in a session
+  ;; in all further object files if we wanted to support that.
+  (error "Precompiled headers are not supported for msvc."))
+
+#-msvc
+(defun dump-precompiled-header ()
+  (let* ((input-file (make-pathname
+                      :directory (append (pathname-directory (ecl-include-directory))
+                                         '("ecl"))
+                      :defaults (ecl-include-directory)
+                      :name "ecl-cmp"
+                      :type "h"))
+         (output-dir (merge-pathnames
+                      (format nil "ecl-include~4,'0x/" (random #xffff))
+                      (translate-logical-pathname "TMP:")))
+         (output-file (compile-file-pathname
+                       (make-pathname :name "ecl-cmp" :defaults output-dir)
+                       :type :precompiled-header)))
+        (ensure-directories-exist output-dir)
+        (push output-dir *files-to-be-deleted*)
+        (safe-run-program
+         *cc*
+         `("-x" "c-header"
+                ,(fix-for-mingw (namestring input-file))
+                ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory)))
+                ,@(split-program-options *cc-flags*)
+                ,@(split-program-options *cc-optimize*)
+                "-o"
+                ,(fix-for-mingw (namestring output-file))
+                ,@(split-program-options *user-cc-flags*)))
+        (push output-file *files-to-be-deleted*)
+        (setf *precompiled-header-flags*
+              (list (concatenate 'string "-I" (namestring output-dir))
+                    "-include"
+                    (concatenate 'string (namestring output-dir) "ecl-cmp.h")))))
+
+
+;;; Collecting necessary information
+
+(defun ecl-include-directory ()
+  "Finds the directory in which the header files were installed."
+  (cond ((and *ecl-include-directory*
+              (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*)))
+         *ecl-include-directory*)
+        ((probe-file "SYS:ecl;config.h")
+         (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:"))))
+        ((error "Unable to find include directory"))))
+
+(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)
+                                           *ecl-library-directory*)))
+         *ecl-library-directory*)
+        ((probe-file "SYS:BUILD-STAMP")
+         (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:"))))
+        ((error "Unable to find library directory"))))
+
+(defun guess-kind (pathname)
+  "Given a file name, guess whether it is an object file, a library, a program
+or a loadable module."
+  (let ((record (assoc (pathname-type pathname)
+                       '((#.+object-file-extension+ :object)
+                         ("o" :object)
+                         ("obj" :object)
+                         ("c" :c)
+                         (#.+static-library-extension+ :static-library)
+                         ("lib" :static-library)
+                         ("a" :static-library)
+                         (#.+shared-library-extension+ :shared-library)
+                         ("dylib" :shared-library)
+                         ("dll" :shared-library)
+                         ("so" :shared-library)
+                         ("fas" :fasl))
+                       :test #'string-equal)))
+    (if record
+        (second record)
+        (progn
+          (warn "File ~s is of no known file type. Assuming it is an object file."
+                pathname)
+          :object))))
+
+(defun guess-ld-libs (pathname &key (kind (guess-kind pathname)))
+  "Given a file name, return the compiler command line argument to link this file in."
+  (case kind
+    ((:object :c)
+     (brief-namestring pathname))
+    ((:fasl :fas)
+     nil)
+    ((:static-library :lib)
+     (brief-namestring pathname))
+    ((:shared-library :dll)
+     (brief-namestring pathname))
+    ((:program)
+     nil)
+    (otherwise
+     (error "C::BUILDER cannot accept files of kind ~s" kind))))
+
+(defun system-ld-flag (library)
+  "Given a symbol, try to find a library that matches it, either by looking in the
+filesystem or in the database of ASDF modules."
+  (let ((asdf #+asdf (find-package "ASDF"))
+        system)
+    (labels ((asdfsym (x) (find-symbol (string x) asdf))
+             (asdfcall (fun &rest rest) (apply (asdfsym fun) rest))
+             (system-output (system type)
+               (let ((build (make-instance (asdfsym :build-op) :type type)))
+                 (first (asdfcall :output-files build system))))
+             (existing-system-output (system type)
+               (let ((o (system-output system type)))
+                 (and o (setf o (probe-file o)) (namestring o))))
+             (find-archive (system)
+                 (or (existing-system-output system :library)
+                     (existing-system-output system :shared-library)))
+             (fallback ()
+                 (translate-logical-pathname
+                  (merge-pathnames
+                   "SYS:"
+                   (compile-file-pathname (string-downcase library)
+                                          :type :library)))))
+      (or
+       #-ecl-min
+       (and asdf
+            (setf system (asdfcall :find-system library nil))
+            (find-archive system))
+       (fallback)))))
+
+
+;;; 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*)))
+    #+msvc
+    (setf ld-flags
+          (let ((implib (brief-namestring
+                         (compile-file-pathname o-pathname :type :lib))))
+            ;; MSVC linker options are added at the end, after the
+            ;; /link flag, because they are not processed by the
+            ;; compiler, but by the linker
+            (append ld-flags
+                    (list (concatenate 'string "/LIBPATH:"
+                                       (ecl-library-directory))
+                          (concatenate 'string "/IMPLIB:" implib)))))
+    #+mingw32
+    (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*))
+        (ld-libs (split-program-options *ld-libs*)))
+    #+msvc
+    (setf ld-flags
+          (let ((implib (brief-namestring
+                         (compile-file-pathname o-pathname :type :import-library))))
+            ;; MSVC linker options are added at the end, after the
+            ;; /link flag, because they are not processed by the
+            ;; compiler, but by the linker
+            (append ld-flags
+                    (list
+                     ;; Not needed because we use ECL_DLLEXPORT
+                     ;; (concatenate 'string "/EXPORT:" init-name)
+                     (concatenate 'string "/LIBPATH:"
+                                  (ecl-library-directory))
+                     (concatenate 'string "/IMPLIB:" implib)))))
+    #+mingw32
+    (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)))
+
+(defconstant +lisp-program-header+ "
+#include <ecl/ecl.h>
+
+#ifdef __cplusplus
+#define ECL_CPP_TAG \"C\"
+#else
+#define ECL_CPP_TAG
+#endif
+
+~:{     extern ECL_CPP_TAG void ~A(cl_object);~%~}
+
+")
+
+;;
+;; This format string contains the structure of the code that initializes
+;; a program, a library, a module, etc. Basically, it processes a codeblock
+;; just like in a normal compiled file, but then adds all the codeblocks of
+;; its corresponding modules.
+;;
+(defconstant +lisp-program-init+ "
+#ifdef __cplusplus
+extern \"C\"
+#endif
+
+ECL_DLLEXPORT
+void ~A(cl_object cblock)
+{
+        /*
+         * This function is first invoked with a pointer to a Cblock
+         * structure, so that the function initializes it, and then
+         * it is invoked with OBJNULL, to force initialization.
+         */
+        static cl_object Cblock = OBJNULL;
+        if (cblock != OBJNULL) {
+                Cblock = cblock;
+#ifndef ECL_DYNAMIC_VV
+                cblock->cblock.data = NULL;
+#endif
+                cblock->cblock.data_size = 0;
+                return;
+        }
+        Cblock->cblock.data_text = (const cl_object *)\"~A\";
+        ~A
+{
+        /*
+         * At this point Cblock contains the cblock of the parent.
+         * Notice how the modules are linked to the parent forming a
+         * circular chain. This disables the garbage collection of
+         * the library until _ALL_ functions in all modules are unlinked.
+         */
+        cl_object current = OBJNULL, next = Cblock;
+~:{
+        current = ecl_make_codeblock();
+        current->cblock.next = next;
+        next = current;
+        ecl_init_module(current, ~A);
+~}
+        Cblock->cblock.next = current;
+}
+        ~A
+}
+")
+
+(defconstant +lisp-init-wrapper+ "
+#ifdef __cplusplus
+extern \"C\"
+#endif
+
+ECL_DLLEXPORT
+void ~A(cl_object cblock)
+{
+        /* This is a wrapper around the randomized init function name. */
+        ~A(cblock);
+}
+")
+
+(defconstant +lisp-program-main+ "
+extern int
+main(int argc, char **argv)
+{
+        cl_boot(argc, argv);
+        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
+        ~A
+        ecl_init_module(OBJNULL, ~A);
+        ~A
+        } ECL_CATCH_ALL_END;
+        si_exit(0);
+}
+")
+
+(defconstant +lisp-library-main+ "
+extern int
+~A(int argc, char **argv)
+{
+        cl_boot(argc, argv);
+        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
+        ~A
+        ecl_init_module(OBJNULL, ~A);
+        ~A
+        } ECL_CATCH_ALL_END;
+        return 0;
+}
+")
+
+#+:win32
+(defconstant +lisp-program-winmain+ "
+#include <windows.h>
+int
+WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow)
+{
+        char **argv;
+        int argc;
+        ecl_get_commandline_args(&argc, &argv);
+        cl_boot(argc, argv);
+        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
+        ~A
+        ecl_init_module(OBJNULL, ~A);
+        ~A
+        } ECL_CATCH_ALL_END;
+        si_exit(0);
+        for (int i = 0; i < argc; i++) {
+          LocalFree(argv[i]);
+        }
+        LocalFree(argv);
+}
+")
+
+
+;;; Code generation
+
+(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
+  (with-cxx-env ()
+    (setq *compiler-phase* 't2)
+    (with-open-file (*compiler-output1* c-pathname :direction :output
+                                                   :if-does-not-exist :create
+                                                   :if-exists :supersede)
+      (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
+      #-ecl-min
+      (multiple-value-bind (second minute hour day month year)
+          (get-decoded-time)
+        (declare (ignore second))
+        (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
+        (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
+      (wt-comment-nl "Source: ~A" source)
+      (with-open-file (*compiler-output2* h-pathname :direction :output
+                                                     :if-does-not-exist :create
+                                                     :if-exists :supersede)
+        (wt-nl1 "#include " *cmpinclude*)
+        (ctop-write init-name h-pathname data-pathname)
+        (terpri *compiler-output1*)
+        (terpri *compiler-output2*)))
+    (data-c-dump data-pathname)))
+
+(defun compiler-pass/assemble-cxx (input-file output-file
+                                   &key
+                                     (c-file nil)
+                                     (h-file nil)
+                                     (data-file nil)
+                                     (system-p nil)
+                                   &allow-other-keys)
+  (let* ((cpath (compile-file-pathname output-file :output-file c-file :type :c))
+         (hpath (compile-file-pathname output-file :output-file h-file :type :h))
+         (dpath (compile-file-pathname output-file :output-file data-file :type :data))
+         (opath (compile-file-pathname output-file :type :object))
+         (to-delete (nconc (unless c-file (list cpath))
+                           (unless h-file (list hpath))
+                           (unless data-file (list dpath))
+                           (unless system-p (list opath))))
+         (init-name (compute-init-name output-file :kind (if system-p :object :fasl))))
+    (compiler-pass/generate-cxx cpath hpath dpath init-name input-file)
+    (if system-p
+        (compiler-cc cpath opath)
+        (progn
+          (compiler-cc cpath opath)
+          (bundle-cc (brief-namestring output-file)
+                     init-name
+                     (list (brief-namestring opath)))))
+    (mapc 'cmp-delete-file to-delete)))
+
+
+;;; The builder.
+
+(defun builder (target output-name
+                &key
+                  lisp-files ld-flags ld-libs
+                  (init-name nil)
+                  (main-name nil)
+                  (prologue-code "")
+                  (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T)))
+                  #+:win32 (system :console)
+                  &aux
+                    (*suppress-compiler-messages* (or *suppress-compiler-messages*
+                                                      (not *compile-verbose*)))
+                    (target (normalize-build-target-name target))
+                    (output-name (if (or (symbolp output-name) (stringp output-name))
+                                     (compile-file-pathname output-name :type target)
+                                     output-name))
+                    ;; wrap-name is the init function name defined by a programmer
+                    (wrap-name init-name))
+  ;; init-name should always be unique
+  (setf init-name (compute-init-name output-name :kind target))
+  (cond ((null wrap-name) nil)
+        ((equal init-name wrap-name)    ; fixup for ASDF
+         (cmpwarn "Parameter `init-name' is the same as the result of an internal function `compute-init-name'. Ignoring.")
+         (setf wrap-name nil))
+        ((null (member target '(:static-library :shared-library)))
+         (cmpwarn "Supplying `init-name' is valid only for libraries. Ignoring.")))
+  (unless main-name
+    (setf main-name (compute-init-name output-name :kind target :prefix "main_")))
+
+
+  ;;
+  ;; The epilogue-code can be either a string made of C code, or a
+  ;; lisp form.  In the latter case we add some additional C code to
+  ;; clean up, and the lisp form is stored in a text representation,
+  ;; to avoid using the compiler.
+  ;;
+  (cond ((null epilogue-code)
+         (setf epilogue-code ""))
+        ((stringp epilogue-code)
+         nil)
+        (t
+         (with-standard-io-syntax
+           (setq epilogue-code
+                 (with-output-to-string (stream)
+                   (princ "{ const char *lisp_code = " stream)
+                   (wt-filtered-data (write-to-string epilogue-code) stream)
+                   (princ ";
+cl_object output;
+si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
+output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
+}" stream)
+                   )))))
+  (cond ((null prologue-code)
+         (setf prologue-code ""))
+        ((stringp prologue-code)
+         )
+        (t
+         (with-standard-io-syntax
+           (setq prologue-code
+                 (with-output-to-string (stream)
+                   (princ "{ const char *lisp_code = " stream)
+                   (wt-filtered-data (write-to-string prologue-code) stream)
+                   (princ ";
+cl_object output;
+si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
+output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
+}" stream)
+                   )))))
+  ;;
+  ;; When a module is built out of several object files, we have to
+  ;; create an additional object file that initializes those ones.
+  ;; This routine is responsible for creating this file.
+  ;;
+  ;; To avoid name clashes, this object file will have a temporary
+  ;; file name (tmp-name).
+  ;;
+  (let* ((tmp-names (safe-mkstemp #P"TMP:ECLINIT"))
+         (tmp-name (first tmp-names))
+         (c-name (brief-namestring
+                  (compile-file-pathname tmp-name :type :c)))
+         (o-name (brief-namestring
+                  (compile-file-pathname tmp-name :type :object)))
+         submodules
+         c-file)
+    (dolist (item (reverse lisp-files))
+      (let* ((path (etypecase item
+                     (symbol (system-ld-flag item))
+                     (pathname item)
+                     (string (parse-namestring item))))
+             (kind (guess-kind path)))
+
+        ;; Shared and static libraries may be linked in a program or
+        ;; fasl, but if we try to create a `static-library' from two
+        ;; static libraries we will end with broken binary because
+        ;; `ar' works fine only with object files. See #274.
+        (unless (member kind `(,@(unless (eql target :static-library)
+                                   '(:shared-library :static-library))
+                               :object :c))
+          (error "C::BUILDER does not accept a file ~s of kind ~s for target ~s" item kind target))
+        (let ((init-fn (guess-init-name path kind))
+              (guessed-libs (guess-ld-libs path)))
+          ;; We should give a warning that we cannot link this module in
+          (when guessed-libs
+            (push guessed-libs ld-libs))
+          (when init-fn
+            (push (list init-fn path) submodules)))))
+    (setq c-file (open c-name :direction :output :external-format :default))
+    (format c-file +lisp-program-header+ submodules)
+
+    (let ((init-tag (init-name-tag init-name :kind target)))
+      (ecase target
+        (:program
+         (format c-file +lisp-program-init+ init-name init-tag "" submodules "")
+         ;; 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+
+                 prologue-code init-name epilogue-code)
+         (close c-file)
+         (compiler-cc c-name o-name)
+         (linker-cc output-name (append ld-flags (list (namestring o-name))
+                                        ld-libs)))
+        (:static-library
+         (format c-file +lisp-program-init+
+                 init-name init-tag prologue-code submodules epilogue-code)
+         (when wrap-name
+           (format c-file +lisp-init-wrapper+ wrap-name init-name))
+         (format c-file +lisp-library-main+
+                 main-name prologue-code init-name epilogue-code)
+         (close c-file)
+         (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)
+         (when wrap-name
+           (format c-file +lisp-init-wrapper+ wrap-name init-name))
+         (format c-file +lisp-library-main+
+                 main-name prologue-code init-name epilogue-code)
+         (close c-file)
+         (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)
+         ;; we don't need wrapper in the fasl, we scan for init function name
+                                        ;(format c-file +lisp-init-wrapper+ wrap-name init-name)
+         (close c-file)
+         (compiler-cc c-name o-name)
+         (bundle-cc output-name init-name (append ld-flags (list o-name)
+                                                  ld-libs))))
+      (mapc 'cmp-delete-file tmp-names)
+      (cmp-delete-file c-name)
+      (cmp-delete-file o-name)
+      output-name)))
+
+(defun build-fasl (&rest args)
+  (apply #'builder :fasl args))
+
+(defun build-program (&rest args)
+  (apply #'builder :program args))
+
+(defun build-static-library (&rest args)
+  (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))

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

@@ -0,0 +1,203 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved.
+;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;;
+;;;; Database for Lisp functions accessible from C.
+;;;;
+
+(in-package "COMPILER")
+
+;;;
+;;; FUNCTIONS WHICH CAN BE CALLED FROM C
+;;;
+;;; The following two lists contain all functions in the core library which do
+;;; not belong to the C part of the library, but which should have an exported C
+;;; name that users (and compiled code) can refer to. This means, for instance, that
+;;; MAKE-ARRAY will be compiled to a function called cl_make_array, etc.
+;;;
+;;; Note that if the created C function should take only fixed
+;;; arguments, a proclamation for the function type must exist so that
+;;; the compiler can produce the correct function signature!
+;;;
+
+#+ecl-min
+(defvar *in-all-symbols-functions*
+  ;; These functions are visible from external.h and their function
+  ;; objects are created in init_all_symbols from the data in
+  ;; symbols_list.h
+  `(;; arraylib.lsp
+    cl:make-array cl:vector cl:array-dimensions cl:array-in-bounds-p cl:array-row-major-index
+    cl:bit cl:sbit cl:bit-and cl:bit-ior cl:bit-xor cl:bit-eqv cl:bit-nand cl:bit-nor cl:bit-andc1
+    cl:bit-andc2 cl:bit-orc1 cl:bit-orc2 cl:bit-not
+    cl:vector-pop cl:adjust-array
+    ;; assert.lsp
+    si:do-check-type si:ecase-error si:etypecase-error
+    si:wrong-type-argument si:ccase-error si:ctypecase-error
+    ;; config.lsp
+    cl:short-site-name cl:long-site-name cl:machine-type cl:machine-instance cl:machine-version
+    cl:software-type cl:software-version cl:lisp-implementation-type cl:lisp-implementation-version
+    si:lisp-implementation-vcs-id
+    ;; assignment.lsp
+    si:setf-definition
+    ;; conditions.lsp
+    si:safe-eval cl:abort cl:continue cl:muffle-warning cl:store-value cl:use-value
+    si:bind-simple-restarts si:bind-simple-handlers
+    si:assert-failure cl:compute-restarts cl:find-restart cl:invoke-restart
+    cl:invoke-restart-interactively cl:make-condition
+    ;; describe.lsp
+    cl:describe cl:inspect
+    ;; iolib.lsp
+    cl:read-from-string cl:write-to-string cl:prin1-to-string cl:princ-to-string
+    cl:y-or-n-p cl:yes-or-no-p si:string-to-object cl:dribble
+    ext:make-encoding ext:load-encoding
+    ;; listlib.lsp
+    cl:union cl:nunion cl:intersection cl:nintersection cl:set-difference cl:nset-difference
+    cl:set-exclusive-or cl:nset-exclusive-or cl:subsetp cl:rassoc-if cl:rassoc-if-not
+    cl:assoc-if cl:assoc-if-not cl:member-if cl:member-if-not cl:subst-if cl:subst-if-not
+    cl:nsubst-if cl:nsubst-if-not
+    ;; mislib.lsp
+    cl:logical-pathname-translations cl:load-logical-pathname-translations cl:decode-universal-time
+    cl:encode-universal-time cl:get-decoded-time
+    cl:ensure-directories-exist si:simple-program-error si:signal-simple-error
+    ;; module.lsp
+    cl:provide cl:require
+    ;; numlib.lsp
+    cl:isqrt cl:phase cl:signum cl:cis
+    cl:asin cl:acos cl:asinh cl:acosh cl:atanh cl:ffloor cl:fceiling cl:ftruncate cl:fround
+    cl:logtest cl:byte cl:byte-size cl:byte-position cl:ldb cl:ldb-test cl:mask-field cl:dpb
+    cl:deposit-field
+    ;; packlib.lsp
+    cl:find-all-symbols cl:apropos cl:apropos-list
+    ;; pprint.lsp
+    cl:pprint-fill cl:copy-pprint-dispatch cl:pprint-dispatch
+    cl:pprint-linear cl:pprint-newline cl:pprint-tab cl:pprint-tabular
+    cl:set-pprint-dispatch cl:pprint-indent
+    ;; predlib.lsp
+    cl:upgraded-array-element-type cl:upgraded-complex-part-type cl:typep cl:subtypep cl:coerce
+    si:do-deftype si:ratiop si:single-float-p si:short-float-p si:double-float-p
+    si:long-float-p
+    ;; process.lsp
+    ext:run-program
+    ext:terminate-process
+    ;; seq.lsp
+    cl:make-sequence cl:concatenate cl:map cl:some cl:every cl:notany cl:notevery cl:map-into cl:complement
+    ;; seqlib.lsp
+    cl:reduce cl:fill cl:replace
+    cl:remove cl:remove-if cl:remove-if-not cl:delete cl:delete-if cl:delete-if-not
+    cl:count cl:count-if cl:count-if-not cl:substitute cl:substitute-if cl:substitute-if-not
+    cl:nsubstitute cl:nsubstitute-if cl:nsubstitute-if-not cl:find cl:find-if cl:find-if-not
+    cl:position cl:position-if cl:position-if-not cl:remove-duplicates
+    cl:delete-duplicates cl:mismatch cl:search cl:sort cl:stable-sort cl:merge cl:constantly
+    si:sequence-count
+    ;; setf.lsp
+    si:do-defsetf si:do-define-setf-method
+    ;; trace.lsp
+    si:traced-old-definition
+
+    ,@(when (member :clos *features*)
+        '(;; combin.lsp
+          cl:invalid-method-error
+          cl:method-combination-error
+          clos:compute-effective-method-function
+          clos:std-compute-effective-method
+          ;; defclass.lsp
+          clos::ensure-class
+          clos:load-defclass
+          ;; kernel.lsp
+          clos:std-compute-applicable-methods
+          ;; method.lsp
+          clos:extract-lambda-list
+          clos:extract-specializer-names
+          ;; predlib.lsp
+          si:subclassp si:of-class-p
+          ;; slotvalue.lsp
+          cl:slot-makunbound
+          ;; std-slot-value.lsp
+          cl:slot-boundp
+          cl:slot-exists-p
+          cl:slot-value
+          clos:slot-value-set
+          clos:standard-instance-access ;; alias clos:funcallable-standard-instance-access
+          clos:standard-instance-set))
+
+    ;; cdr-5
+    ext:array-index-p
+    ext:negative-fixnum-p ext:non-negative-fixnum-p
+    ext:non-positive-fixnum-p ext:positive-fixnum-p
+    ext:negative-integer-p ext:non-negative-integer-p
+    ext:non-positive-integer-p ext:positive-integer-p
+    ext:negative-rational-p ext:non-negative-rational-p
+    ext:non-positive-rational-p ext:positive-rational-p
+    ext:negative-ratio-p ext:non-negative-ratio-p
+    ext:non-positive-ratio-p ext:positive-ratio-p
+    ext:negative-real-p ext:non-negative-real-p
+    ext:non-positive-real-p ext:positive-real-p
+    ext:negative-float-p ext:non-negative-float-p
+    ext:non-positive-float-p ext:positive-float-p
+    ext:negative-short-float-p ext:non-negative-short-float-p
+    ext:non-positive-short-float-p ext:positive-short-float-p
+    ext:negative-single-float-p ext:non-negative-single-float-p
+    ext:non-positive-single-float-p ext:positive-single-float-p
+    ext:negative-double-float-p ext:non-negative-double-float-p
+    ext:non-positive-double-float-p ext:positive-double-float-p
+    ext:negative-long-float-p ext:non-negative-long-float-p
+    ext:non-positive-long-float-p ext:positive-long-float-p))
+
+(proclaim
+  ;; These functions are not visible in external.h and have no entry in
+  ;; symbols_list.h
+  `(si::c-export-fname
+    ,@(when (member :ecl-min *features*)
+        *in-all-symbols-functions*)
+    ;; defmacro.lsp
+    si::find-documentation si::find-declarations
+    si::search-keyword si::check-keyword
+    si::dm-too-many-arguments si::dm-too-few-arguments
+    si::remove-documentation
+    ;; defstruct.lsp
+    si::structure-type-error si::define-structure
+    ;; helpfile.lsp
+    si::get-documentation si::set-documentation
+    si::expand-set-documentation
+    ;; packlib.lsp
+    si::packages-iterator
+    ;; pprint.lsp
+    si::pprint-logical-block-helper si::pprint-pop-helper
+    ;; seq.lsp
+    si::make-seq-iterator si::seq-iterator-ref
+    si::seq-iterator-set si::seq-iterator-next
+    si::coerce-to-list si::coerce-to-vector
+    ,@(when (member :formatter *features*)
+        '(si::format-princ si::format-prin1 si::format-print-named-character
+          si::format-print-integer
+          si::format-print-cardinal si::format-print-ordinal si::format-print-old-roman
+          si::format-print-roman si::format-fixed si::format-exponential
+          si::format-general si::format-dollars
+          si::format-relative-tab si::format-absolute-tab
+          si::format-justification))
+    ,@(when (member :clos *features*)
+        '(;; generic.lsp
+          clos::associate-methods-to-gfun
+          ;; kernel.lsp
+          clos::install-method
+          ;; std-slot-value.lsp
+          clos::find-slot-definition
+          ;; clos::generic-function-lambda-list
+          ;; clos::generic-function-argument-precedence-order
+          ;; clos::generic-function-method-combination
+          ;; clos::generic-function-method-class
+          ;; clos::generic-function-methods
+          ;; clos::method-generic-function
+          ;; clos::method-lambda-list
+          ;; clos::method-specializers
+          ;; clos::method-qualifiers
+          ;; clos::method-function
+          ;; clos::method-plist
+          ))))

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

@@ -0,0 +1,819 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved.
+;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;;
+;;;; Database for system functions.
+;;;;
+
+(in-package "COMPILER")
+
+;;;
+;;; DATABASE OF INLINE EXPANSIONS
+;;;
+;;;     (DEF-INLINE function-name kind ([arg-type]*) return-rep-type
+;;;             expansion-string)
+;;;
+;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family,
+;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the
+;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the
+;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE,
+;;; depending on whether the inline expression should be applied always, in safe
+;;; or in unsafe compilation mode, respectively.
+;;;
+
+(defun inline-information (name safety)
+  (gethash (list name safety) *inline-information*))
+
+(defun (setf inline-information) (value name safety)
+  (setf (gethash (list name safety) *inline-information*) value))
+
+(defun %def-inline (name safety arg-types return-rep-type expansion
+                    &key (one-liner t) (exact-return-type nil) (inline-or-warn nil)
+                      (multiple-values t)
+                    &aux arg-rep-types)
+  (setf safety
+        (case safety
+          (:unsafe :inline-unsafe)
+          (:safe :inline-safe)
+          (:always :inline-always)
+          (t (error "In DEF-INLINE, wrong value of SAFETY"))))
+  ;; Ensure we can inline this form. We only inline when the features are
+  ;; there (checked above) and when the C types are part of this machine
+  ;; (checked here).
+  (loop for type in (list* return-rep-type arg-types)
+        unless (or (eq type 'fixnum-float)
+                   (and (consp type) (eq (car type) 'values))
+                   (lisp-type-p type)
+                   (machine-c-type-p type))
+          do (warn "Dropping inline form for ~A because of missing type ~A" name type)
+             (return-from %def-inline))
+  (setf arg-rep-types
+        (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x)))
+                arg-types))
+  (when (eq return-rep-type t)
+    (setf return-rep-type :object))
+  (when inline-or-warn
+    (setf (inline-information name 'should-be-inlined) t))
+  (let* ((return-type (if (and (consp return-rep-type)
+                               (eq (first return-rep-type) 'values))
+                          t
+                          (rep-type->lisp-type return-rep-type)))
+         (inline-info
+           (make-inline-info :name name
+                             :arg-rep-types arg-rep-types
+                             :return-rep-type return-rep-type
+                             :return-type return-type
+                             :arg-types arg-types
+                             :exact-return-type exact-return-type
+                             :multiple-values multiple-values
+                             ;; :side-effects (not (si:get-sysprop name 'no-side-effects))
+                             :one-liner one-liner
+                             :expansion expansion)))
+    #+(or)
+    (loop for i in (inline-information name safety)
+          when (and (equalp (inline-info-arg-types i) arg-types)
+                    (not (equalp return-type (inline-info-return-type i))))
+            do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>"
+                       name i inline-info))
+    (push inline-info (gethash (list name safety) *inline-information*))))
+
+(defmacro def-inline (&rest args)
+  `(apply #'%def-inline ',args))
+
+(defun make-inline-information (*machine*)
+  (let ((*inline-information* (make-hash-table :size 768 :test 'equal)))
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;;
+    ;; ALL FUNCTION DECLARATIONS AND INLINE FORMS
+    ;;
+    (def-inline cl:aref :unsafe (t t t) t "@0;ecl_aref_unsafe(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))")
+    (def-inline cl:aref :unsafe ((array t) t t) t "@0;(#0)->array.self.t[ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2)]")
+    (def-inline cl:aref :unsafe ((array bit) t t) :fixnum "@0;ecl_aref_bv(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))")
+    (def-inline cl:aref :unsafe ((array t) fixnum fixnum) t "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]")
+    (def-inline cl:aref :unsafe ((array bit) fixnum fixnum) :fixnum "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)")
+    (def-inline cl:aref :unsafe ((array base-char) fixnum fixnum) :unsigned-char "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]")
+    (def-inline cl:aref :unsafe ((array double-float) fixnum fixnum) :double "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]")
+    (def-inline cl:aref :unsafe ((array single-float) fixnum fixnum) :float "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]")
+    (def-inline cl:aref :unsafe ((array long-float) fixnum fixnum) :long-double "@0;(#0)->array.self.lf[#1*(#0)->array.dims[1]+#2]")
+    (when (member :complex-float *features*)
+      (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum fixnum) :csfloat "@0;(#0)->array.self.csf[#1*(#0)->array.dims[1]+#2]")
+      (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum fixnum) :cdfloat "@0;(#0)->array.self.cdf[#1*(#0)->array.dims[1]+#2]")
+      (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum fixnum) :clfloat "@0;(#0)->array.self.clf[#1*(#0)->array.dims[1]+#2]"))
+
+    (def-inline cl:aref :unsafe ((array fixnum) fixnum fixnum) :fixnum "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]")
+
+    (def-inline cl:aref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))")
+    (def-inline cl:aref :always (t fixnum) t "ecl_aref1(#0,#1)")
+    (def-inline cl:aref :unsafe (t t) t "ecl_aref1(#0,ecl_fixnum(#1))")
+    (def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))")
+    (def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)")
+    (when (member :unicode *features*)
+      (def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]"))
+    (def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]")
+    (def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]")
+    (def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]")
+    (def-inline cl:aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]")
+    (when (member :complex-float *features*)
+      (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]")
+      (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]")
+      (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]"))
+    (def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]")
+
+    (def-inline cl:row-major-aref :always (t t) t "ecl_aref(#0,ecl_to_size(#1))")
+    (def-inline cl:row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)")
+    (def-inline cl:row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))")
+    (def-inline cl:row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)")
+    (def-inline cl:row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))")
+    (def-inline cl:row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)")
+    (when (member :unicode *features*)
+      (def-inline cl:row-major-aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]"))
+    (def-inline cl:row-major-aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:byte8) fixnum) :uint8-t "(#0)->vector.self.b8[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:integer8) fixnum) :int8-t "(#0)->vector.self.i8[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:byte16) fixnum) :uint16-t "(#0)->vector.self.b16[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:integer16) fixnum) :int16-t "(#0)->vector.self.i16[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:byte32) fixnum) :uint32-t "(#0)->vector.self.b32[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:integer32) fixnum) :int32-t "(#0)->vector.self.i32[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:byte64) fixnum) :uint64-t "(#0)->vector.self.b64[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array ext:integer64) fixnum) :int64-t "(#0)->vector.self.i64[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]")
+    (def-inline cl:row-major-aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]")
+    (when (member :complex-float *features*)
+      (def-inline cl:row-major-aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]")
+      (def-inline cl:row-major-aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]")
+      (def-inline cl:row-major-aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]"))
+    (def-inline cl:row-major-aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]")
+
+    (def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,ecl_to_size(#1),#2)")
+    (def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)")
+    (def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,ecl_fixnum(#1),#2)")
+    (def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)")
+    (def-inline si:row-major-aset :unsafe ((array t) fixnum t) t "(#0)->vector.self.t[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum "ecl_aset_bv(#0,#1,ecl_fixnum(#2))")
+    (def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum "ecl_aset_bv(#0,#1,#2)")
+    (def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2")
+    (when (member :unicode *features*)
+      (def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar "(#0)->string.self[#1]= #2"))
+    (def-inline si:row-major-aset :unsafe ((array ext:byte8) fixnum ext:byte8) :uint8-t "(#0)->vector.self.b8[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:integer8) fixnum ext:integer8) :int8-t "(#0)->vector.self.i8[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:byte16) fixnum ext:byte16) :uint16-t "(#0)->vector.self.b16[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:integer16) fixnum ext:integer16) :int16-t "(#0)->vector.self.i16[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:byte32) fixnum ext:byte32) :uint32-t "(#0)->vector.self.b32[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:integer32) fixnum ext:integer32) :int32-t "(#0)->vector.self.i32[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:byte64) fixnum ext:byte64) :uint64-t "(#0)->vector.self.b64[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array ext:integer64) fixnum ext:integer64) :int64-t "(#0)->vector.self.i64[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array long-float) fixnum long-float) :long-double "(#0)->array.self.lf[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double "(#0)->array.self.df[#1]= #2")
+    (def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float "(#0)->array.self.sf[#1]= #2")
+    (when (member :complex-float *features*)
+      (def-inline si:row-major-aset :unsafe ((array si:complex-single-float) fixnum si:complex-single-float) :csfloat "(#0)->array.self.csf[#1]= #2")
+      (def-inline si:row-major-aset :unsafe ((array si:complex-double-float) fixnum si:complex-double-float) :cdfloat "(#0)->array.self.cdf[#1]= #2")
+      (def-inline si:row-major-aset :unsafe ((array si:complex-long-float) fixnum si:complex-long-float) :clfloat "(#0)->array.self.clf[#1]= #2"))
+    (def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum "(#0)->array.self.fix[#1]= #2")
+
+    (def-inline si:copy-subarray :always (array ext:array-index array ext:array-index ext:array-index) array "@0;(ecl_copy_subarray(#0,#1,#2,#3,#4),#0)")
+
+    (def-inline cl:array-rank :unsafe (array) :fixnum "@0;(((#0)->d.t == t_array)?(#0)->array.rank:1)")
+    (def-inline cl:array-rank :always (array) :fixnum "ecl_array_rank(#0)")
+
+    (def-inline cl:array-dimension :always (t t) fixnum "ecl_array_dimension(#0,ecl_to_size(#1))")
+    (def-inline cl:array-dimension :always (t fixnum) fixnum "ecl_array_dimension(#0,#1)")
+
+    (def-inline cl:array-total-size :unsafe (t) :fixnum "((#0)->array.dim)")
+
+    (def-inline cl:adjustable-array-p :always (t) :bool "@0;(ECL_ARRAYP(#0)? (void)0: FEtype_error_array(#0),ECL_ADJUSTABLE_ARRAY_P(#0))")
+    (def-inline cl:adjustable-array-p :unsafe (array) :bool "ECL_ADJUSTABLE_ARRAY_P(#0)")
+
+    (def-inline cl:svref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))")
+    (def-inline cl:svref :always (t fixnum) t "ecl_aref1(#0,#1)")
+    (def-inline cl:svref :unsafe (t t) t "(#0)->vector.self.t[ecl_fixnum(#1)]")
+    (def-inline cl:svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]")
+
+    (def-inline si:svset :always (t t t) t "ecl_aset1(#0,ecl_to_size(#1),#2)")
+    (def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)")
+    (def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[ecl_fixnum(#1)]=(#2))")
+    (def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2")
+
+    (def-inline cl:array-has-fill-pointer-p :always (t) :bool "@0;(ECL_ARRAYP(#0)?(void)0:FEtype_error_array(#0),ECL_ARRAY_HAS_FILL_POINTER_P(#0))")
+    (def-inline cl:array-has-fill-pointer-p :unsafe (array) :bool "ECL_ARRAY_HAS_FILL_POINTER_P(#0)")
+
+    (def-inline cl:fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)")
+    (def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum "((#0)->vector.fillp)=(#1)")
+
+    ;; file character.d
+
+    (def-inline cl:standard-char-p :always (character) :bool "ecl_standard_char_p(#0)")
+    (def-inline cl:graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)")
+    (def-inline cl:alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)")
+    (def-inline cl:upper-case-p :always (character) :bool "ecl_upper_case_p(#0)")
+    (def-inline cl:lower-case-p :always (character) :bool "ecl_lower_case_p(#0)")
+    (def-inline cl:both-case-p :always (character) :bool "ecl_both_case_p(#0)")
+    (def-inline cl:alphanumericp :always (character) :bool "ecl_alphanumericp(#0)")
+
+    (def-inline cl:char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)")
+    (def-inline cl:char= :always (character character) :bool "(#0)==(#1)")
+
+    (def-inline cl:char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)")
+    (def-inline cl:char/= :always (character character) :bool "(#0)!=(#1)")
+
+    (def-inline cl:char< :always (character character) :bool "(#0)<(#1)")
+    (def-inline cl:char> :always (character character) :bool "(#0)>(#1)")
+    (def-inline cl:char<= :always (character character) :bool "(#0)<=(#1)")
+    (def-inline cl:char>= :always (character character) :bool "(#0)>=(#1)")
+
+    (def-inline cl:char-code :always (character) :fixnum "#0")
+    (def-inline cl:code-char :always (fixnum) :wchar "#0")
+
+    (def-inline cl:char-upcase :always (base-char) :unsigned-char "ecl_char_upcase(#0)")
+    (def-inline cl:char-upcase :always (character) :wchar "ecl_char_upcase(#0)")
+
+    (def-inline cl:char-downcase :always (base-char) :unsigned-char "ecl_char_downcase(#0)")
+    (def-inline cl:char-downcase :always (character) :wchar "ecl_char_downcase(#0)")
+
+    (def-inline cl:char-int :always (character) :fixnum "#0")
+
+    ;; file ffi.d
+
+    (def-inline si:foreign-data-p :always (t) :bool "@0;ECL_FOREIGN_DATA_P(#0)")
+
+    ;; file file.d
+
+    (def-inline cl:input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)")
+    (def-inline cl:output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)")
+
+    ;; file hash.d
+
+    (def-inline cl:gethash :always (t t t) t "ecl_gethash_safe(#0,#1,#2)" :multiple-values nil)
+    (def-inline cl:gethash :always (t t) t "ecl_gethash_safe(#0,#1,ECL_NIL)" :multiple-values nil)
+    (def-inline cl:hash-table-count :unsafe (hash-table) ext:array-index "ecl_hash_table_count(#0)")
+
+    ;; file list.d
+
+    (def-inline cl:car :unsafe (cons) t "ECL_CONS_CAR(#0)")
+    (def-inline cl:car :unsafe (t) t "_ecl_car(#0)")
+
+    (def-inline si:cons-car :always (t) t "_ecl_car(#0)")
+    (def-inline si:cons-car :unsafe (t) t "ECL_CONS_CAR(#0)")
+
+    (def-inline cl:cdr :unsafe (cons) t "ECL_CONS_CDR(#0)")
+    (def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)")
+
+    (def-inline si:cons-cdr :always (t) t "_ecl_cdr(#0)")
+    (def-inline si:cons-cdr :unsafe (t) t "ECL_CONS_CDR(#0)")
+
+    ;; BEGIN-GENERATED (gen-cons-sysfun)
+
+    (def-inline cl:car :always (t) t "ecl_car(#0)")
+    (def-inline cl:car :unsafe (t) t "_ecl_car(#0)")
+    (def-inline cl:cdr :always (t) t "ecl_cdr(#0)")
+    (def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)")
+    (def-inline cl:caar :always (t) t "ecl_caar(#0)")
+    (def-inline cl:caar :unsafe (t) t "_ecl_caar(#0)")
+    (def-inline cl:cdar :always (t) t "ecl_cdar(#0)")
+    (def-inline cl:cdar :unsafe (t) t "_ecl_cdar(#0)")
+    (def-inline cl:cadr :always (t) t "ecl_cadr(#0)")
+    (def-inline cl:cadr :unsafe (t) t "_ecl_cadr(#0)")
+    (def-inline cl:cddr :always (t) t "ecl_cddr(#0)")
+    (def-inline cl:cddr :unsafe (t) t "_ecl_cddr(#0)")
+    (def-inline cl:caaar :always (t) t "ecl_caaar(#0)")
+    (def-inline cl:caaar :unsafe (t) t "_ecl_caaar(#0)")
+    (def-inline cl:cdaar :always (t) t "ecl_cdaar(#0)")
+    (def-inline cl:cdaar :unsafe (t) t "_ecl_cdaar(#0)")
+    (def-inline cl:cadar :always (t) t "ecl_cadar(#0)")
+    (def-inline cl:cadar :unsafe (t) t "_ecl_cadar(#0)")
+    (def-inline cl:cddar :always (t) t "ecl_cddar(#0)")
+    (def-inline cl:cddar :unsafe (t) t "_ecl_cddar(#0)")
+    (def-inline cl:caadr :always (t) t "ecl_caadr(#0)")
+    (def-inline cl:caadr :unsafe (t) t "_ecl_caadr(#0)")
+    (def-inline cl:cdadr :always (t) t "ecl_cdadr(#0)")
+    (def-inline cl:cdadr :unsafe (t) t "_ecl_cdadr(#0)")
+    (def-inline cl:caddr :always (t) t "ecl_caddr(#0)")
+    (def-inline cl:caddr :unsafe (t) t "_ecl_caddr(#0)")
+    (def-inline cl:cdddr :always (t) t "ecl_cdddr(#0)")
+    (def-inline cl:cdddr :unsafe (t) t "_ecl_cdddr(#0)")
+    (def-inline cl:caaaar :always (t) t "ecl_caaaar(#0)")
+    (def-inline cl:caaaar :unsafe (t) t "_ecl_caaaar(#0)")
+    (def-inline cl:cdaaar :always (t) t "ecl_cdaaar(#0)")
+    (def-inline cl:cdaaar :unsafe (t) t "_ecl_cdaaar(#0)")
+    (def-inline cl:cadaar :always (t) t "ecl_cadaar(#0)")
+    (def-inline cl:cadaar :unsafe (t) t "_ecl_cadaar(#0)")
+    (def-inline cl:cddaar :always (t) t "ecl_cddaar(#0)")
+    (def-inline cl:cddaar :unsafe (t) t "_ecl_cddaar(#0)")
+    (def-inline cl:caadar :always (t) t "ecl_caadar(#0)")
+    (def-inline cl:caadar :unsafe (t) t "_ecl_caadar(#0)")
+    (def-inline cl:cdadar :always (t) t "ecl_cdadar(#0)")
+    (def-inline cl:cdadar :unsafe (t) t "_ecl_cdadar(#0)")
+    (def-inline cl:caddar :always (t) t "ecl_caddar(#0)")
+    (def-inline cl:caddar :unsafe (t) t "_ecl_caddar(#0)")
+    (def-inline cl:cdddar :always (t) t "ecl_cdddar(#0)")
+    (def-inline cl:cdddar :unsafe (t) t "_ecl_cdddar(#0)")
+    (def-inline cl:caaadr :always (t) t "ecl_caaadr(#0)")
+    (def-inline cl:caaadr :unsafe (t) t "_ecl_caaadr(#0)")
+    (def-inline cl:cdaadr :always (t) t "ecl_cdaadr(#0)")
+    (def-inline cl:cdaadr :unsafe (t) t "_ecl_cdaadr(#0)")
+    (def-inline cl:cadadr :always (t) t "ecl_cadadr(#0)")
+    (def-inline cl:cadadr :unsafe (t) t "_ecl_cadadr(#0)")
+    (def-inline cl:cddadr :always (t) t "ecl_cddadr(#0)")
+    (def-inline cl:cddadr :unsafe (t) t "_ecl_cddadr(#0)")
+    (def-inline cl:caaddr :always (t) t "ecl_caaddr(#0)")
+    (def-inline cl:caaddr :unsafe (t) t "_ecl_caaddr(#0)")
+    (def-inline cl:cdaddr :always (t) t "ecl_cdaddr(#0)")
+    (def-inline cl:cdaddr :unsafe (t) t "_ecl_cdaddr(#0)")
+    (def-inline cl:cadddr :always (t) t "ecl_cadddr(#0)")
+    (def-inline cl:cadddr :unsafe (t) t "_ecl_cadddr(#0)")
+    (def-inline cl:cddddr :always (t) t "ecl_cddddr(#0)")
+    (def-inline cl:cddddr :unsafe (t) t "_ecl_cddddr(#0)")
+    ;; END-GENERATED
+
+    (def-inline cl:cons :always (t t) t "CONS(#0,#1)")
+
+    (def-inline cl:endp :safe (t) :bool "ecl_endp(#0)")
+    (def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL")
+
+    (def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)")
+    (def-inline cl:nth :always (fixnum t) t "ecl_nth(#0,#1)")
+    (def-inline cl:nth :unsafe (t t) t "ecl_nth(ecl_fixnum(#0),#1)")
+    (def-inline cl:nth :unsafe (fixnum t) t "ecl_nth(#0,#1)")
+
+    (def-inline cl:nthcdr :always (t t) t "ecl_nthcdr(ecl_to_size(#0),#1)")
+    (def-inline cl:nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)")
+    (def-inline cl:nthcdr :unsafe (t t) t "ecl_nthcdr(ecl_fixnum(#0),#1)")
+    (def-inline cl:nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)")
+
+    (def-inline cl:last :always (t) t "ecl_last(#0,1)")
+
+    (def-inline cl:list :always nil t "ECL_NIL")
+    (def-inline cl:list :always (t) t "ecl_list1(#0)")
+
+    (def-inline cl:list* :always (t) t "#0")
+    (def-inline cl:list* :always (t t) t "CONS(#0,#1)")
+
+    (def-inline cl:append :always (t t) t "ecl_append(#0,#1)")
+    (def-inline cl:nconc :always (t t) t "ecl_nconc(#0,#1)")
+    (def-inline cl:butlast :always (t) t "ecl_butlast(#0,1)")
+    (def-inline cl:nbutlast :always (t) t "ecl_nbutlast(#0,1)")
+
+    ;; file num_arith.d
+
+    (def-inline cl:1+ :always (t) t "ecl_one_plus(#0)")
+    (def-inline cl:1+ :always (fixnum) t "ecl_make_integer((#0)+1)")
+    (def-inline cl:1+ :always (long-float) :long-double "(long double)(#0)+1")
+    (def-inline cl:1+ :always (double-float) :double "(double)(#0)+1")
+    (def-inline cl:1+ :always (single-float) :float "(float)(#0)+1")
+    (when (member :complex-float *features*)
+      (def-inline cl:1+ :always (si:complex-single-float) :csfloat "(_Complex float)(#0)+1")
+      (def-inline cl:1+ :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)+1")
+      (def-inline cl:1+ :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)+1"))
+    (def-inline cl:1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t)
+
+    (def-inline cl:1- :always (t) t "ecl_one_minus(#0)")
+    (def-inline cl:1- :always (fixnum) t "ecl_make_integer((#0)-1)")
+    (def-inline cl:1- :always (long-float) :long-double "(long double)(#0)-1")
+    (def-inline cl:1- :always (double-float) :double "(double)(#0)-1")
+    (def-inline cl:1- :always (single-float) :float "(float)(#0)-1")
+    (when (member :complex-float *features*)
+      (def-inline cl:1- :always (si:complex-single-float) :csfloat "(_Complex float)(#0)-1")
+      (def-inline cl:1- :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)-1")
+      (def-inline cl:1- :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)-1"))
+    (def-inline cl:1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t)
+
+    ;; file num_co.d
+
+    (def-inline cl:float :always (t single-float) :float "ecl_to_float(#0)")
+    (def-inline cl:float :always (t double-float) :double "ecl_to_double(#0)")
+    (def-inline cl:float :always (t long-float) :long-double "ecl_to_long_double(#0)")
+    (def-inline cl:float :always (fixnum-float) :long-double "((long double)(#0))" :exact-return-type t)
+    (def-inline cl:float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t)
+    (def-inline cl:float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t)
+
+    (def-inline cl:numerator :unsafe (integer) integer "(#0)")
+    (def-inline cl:numerator :unsafe (ratio) integer "(#0)->ratio.num")
+
+    (def-inline cl:denominator :unsafe (integer) integer "ecl_make_fixnum(1)")
+    (def-inline cl:denominator :unsafe (ratio) integer "(#0)->ratio.den")
+
+    (def-inline cl:floor :always (t) (values &rest t) "ecl_floor1(#0)")
+    (def-inline cl:floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)")
+    #+(or) ; does not work well, no multiple values
+    (def-inline cl:floor :always (fixnum fixnum) :fixnum "@01;(#0>=0&&#1>0?(#0)/(#1):ecl_ifloor(#0,#1))")
+
+    (def-inline cl:ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)")
+    (def-inline cl:ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)")
+
+    (def-inline cl:truncate :always (t) (values &rest t) "ecl_truncate1(#0)")
+    (def-inline cl:truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)")
+    #+(or) ; does not work well, no multiple values
+    (def-inline cl:truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)")
+
+    (def-inline cl:round :always (t) (values &rest t) "ecl_round1(#0)")
+    (def-inline cl:round :always (t t) (values &rest t) "ecl_round2(#0,#1)")
+
+    (def-inline cl:mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])")
+    (def-inline cl:mod :always (fixnum fixnum) :fixnum "@01;(#0>=0&&#1>0?(#0)%(#1):ecl_imod(#0,#1))")
+
+    (def-inline cl:rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])")
+    (def-inline cl:rem :always (fixnum fixnum) :fixnum "(#0)%(#1)")
+
+    (def-inline cl:= :always (t t) :bool "ecl_number_equalp(#0,#1)")
+    (def-inline cl:= :always (fixnum-float fixnum-float) :bool "(#0)==(#1)")
+
+    (def-inline cl:/= :always (t t) :bool "!ecl_number_equalp(#0,#1)")
+    (def-inline cl:/= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)")
+
+    (def-inline cl:< :always (t t) :bool "ecl_lower(#0,#1)")
+    (def-inline cl:< :always (fixnum-float fixnum-float) :bool "(#0)<(#1)")
+    (def-inline cl:< :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<(#1) && (#1)<(#2))")
+
+    (def-inline cl:> :always (t t) :bool "ecl_greater(#0,#1)")
+    (def-inline cl:> :always (fixnum-float fixnum-float) :bool "(#0)>(#1)")
+    (def-inline cl:> :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>(#1) && (#1)>(#2))")
+
+    (def-inline cl:<= :always (t t) :bool "ecl_lowereq(#0,#1)")
+    (def-inline cl:<= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)")
+    (def-inline cl:<= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<=(#1) && (#1)<=(#2))")
+
+    (def-inline cl:>= :always (t t) :bool "ecl_greatereq(#0,#1)")
+    (def-inline cl:>= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)")
+    (def-inline cl:>= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>=(#1) && (#1)>=(#2))")
+
+    (def-inline cl:max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1")
+    (def-inline cl:min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1")
+    (if (member :ieee-floating-point *features*)
+        (progn
+          (def-inline cl:max :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_greatereq(#0,#1))?#0:#1)")
+          (def-inline cl:min :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_lowereq(#0,#1))?#0:#1)"))
+        (progn
+          (def-inline cl:max :always (t t) t "@01;(ecl_greatereq(#0,#1)?#0:#1)")
+          (def-inline cl:min :always (t t) t "@01;(ecl_lowereq(#0,#1)?#0:#1)")))
+
+    ;; file num_log.d
+
+    (def-inline cl:logand :always nil t "ecl_make_fixnum(-1)")
+    (def-inline cl:logand :always nil :fixnum "-1")
+    (def-inline cl:logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))")
+    (def-inline cl:logand :always (fixnum fixnum) :fixnum "((#0) & (#1))")
+
+    (def-inline cl:logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))")
+    (def-inline cl:logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))")
+
+    (def-inline cl:logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))")
+    (def-inline cl:logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))")
+
+    (def-inline cl:logeqv :always nil t "ecl_make_fixnum(-1)")
+    (def-inline cl:logeqv :always nil :fixnum "-1")
+    (def-inline cl:logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))")
+    (def-inline cl:logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))")
+
+    (def-inline cl:logior :always nil t "ecl_make_fixnum(0)")
+    (def-inline cl:logior :always nil :fixnum "0")
+    (def-inline cl:logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))")
+    (def-inline cl:logior :always (fixnum fixnum) :fixnum "((#0) | (#1))")
+
+    (def-inline cl:lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))")
+    (def-inline cl:lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))")
+
+    (def-inline cl:lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))")
+    (def-inline cl:lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))")
+
+    (def-inline cl:lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),ecl_make_fixnum(-1))")
+    (def-inline cl:lognot :always (fixnum) :fixnum "(~(#0))")
+
+    (def-inline cl:logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))")
+    (def-inline cl:logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))")
+
+    (def-inline cl:logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))")
+    (def-inline cl:logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))")
+
+    (def-inline cl:logxor :always nil t "ecl_make_fixnum(0)")
+    (def-inline cl:logxor :always nil :fixnum "0")
+    (def-inline cl:logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))")
+    (def-inline cl:logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))")
+
+    (def-inline cl:boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))")
+
+    (def-inline cl:logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1")
+
+    (def-inline cl:integer-length :always (t) :cl-index "ecl_integer_length(#0)")
+
+    (def-inline cl:zerop :always (t) :bool "ecl_zerop(#0)")
+    (def-inline cl:zerop :always (fixnum-float) :bool "(#0)==0")
+
+    (def-inline cl:plusp :always (t) :bool "ecl_plusp(#0)")
+    (def-inline cl:plusp :always (fixnum-float) :bool "(#0)>0")
+
+    (def-inline cl:minusp :always (t) :bool "ecl_minusp(#0)")
+    (def-inline cl:minusp :always (fixnum-float) :bool "(#0)<0")
+
+    (def-inline cl:oddp :always (t) :bool "ecl_oddp(#0)")
+    (def-inline cl:oddp :always (fixnum fixnum) :bool "(#0) & 1")
+
+    (def-inline cl:evenp :always (t) :bool "ecl_evenp(#0)")
+    (def-inline cl:evenp :always (fixnum fixnum) :bool "~(#0) & 1")
+
+    (def-inline cl:abs :always (t t) t "ecl_abs(#0,#1)")
+    (def-inline cl:exp :always (t) t "ecl_exp(#0)")
+
+    (def-inline cl:expt :always (t t) t "ecl_expt(#0,#1)")
+    (def-inline cl:expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))")
+    (def-inline cl:expt :always ((integer 0 0) t) :fixnum "0")
+    (def-inline cl:expt :always ((integer 1 1) t) :fixnum "1")
+    (def-inline cl:expt :always ((long-float 0.0l0 *) long-float) :long-double "powl((long double)#0,(long double)#1)")
+    (def-inline cl:expt :always ((double-float 0.0d0 *) double-float) :double "pow((double)#0,(double)#1)")
+    (def-inline cl:expt :always ((single-float 0.0f0 *) single-float) :float "powf((float)#0,(float)#1)")
+    (when (member :complex-float *features*)
+      (def-inline cl:expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)")
+      (def-inline cl:expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)")
+      (def-inline cl:expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)"))
+
+    (def-inline cl:log :always (fixnum-float) :long-double "logl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t)
+    (def-inline cl:log :always (fixnum-float) :float "logf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:log :always (si:complex-single-float) :csfloat "clogf(#0)")
+      (def-inline cl:log :always (si:complex-double-float) :cdfloat "clog(#0)")
+      (def-inline cl:log :always (si:complex-long-float) :clfloat "clogl(#0)"))
+
+    (def-inline cl:sqrt :always (number) number "ecl_sqrt(#0)")
+    (def-inline cl:sqrt :always ((long-float 0.0l0 *)) :long-double "sqrtl((long double)(#0))")
+    (def-inline cl:sqrt :always ((double-float 0.0d0 *)) :double "sqrt((double)(#0))")
+    (def-inline cl:sqrt :always ((single-float 0.0f0 *)) :float "sqrtf((float)(#0))")
+    (when (member :complex-float *features*)
+      (def-inline cl:sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)")
+      (def-inline cl:sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)")
+      (def-inline cl:sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)"))
+
+    (def-inline cl:sin :always (number) number "ecl_sin(#0)")
+    (def-inline cl:sin :always (fixnum-float) :long-double "sinl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t)
+    (def-inline cl:sin :always (fixnum-float) :float "sinf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:sin :always (si:complex-single-float) :csfloat "csinf(#0)")
+      (def-inline cl:sin :always (si:complex-double-float) :cdfloat "csin(#0)")
+      (def-inline cl:sin :always (si:complex-long-float) :clfloat "csinl(#0)"))
+
+    (def-inline cl:cos :always (t) number "ecl_cos(#0)")
+    (def-inline cl:cos :always (fixnum-float) :long-double "cosl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t)
+    (def-inline cl:cos :always (fixnum-float) :float "cosf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:cos :always (si:complex-single-float) :csfloat "ccosf(#0)")
+      (def-inline cl:cos :always (si:complex-double-float) :cdfloat "ccos(#0)")
+      (def-inline cl:cos :always (si:complex-long-float) :clfloat "ccosl(#0)"))
+
+    (def-inline cl:tan :always (t) number "ecl_tan(#0)")
+    (def-inline cl:tan :always (fixnum-float) :long-double "tanl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t)
+    (def-inline cl:tan :always (fixnum-float) :float "tanf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:tan :always (si:complex-single-float) :csfloat "ctanf(#0)")
+      (def-inline cl:tan :always (si:complex-double-float) :cdfloat "ctan(#0)")
+      (def-inline cl:tan :always (si:complex-long-float) :clfloat "ctanl(#0)"))
+
+    (def-inline cl:sinh :always (t) number "ecl_sinh(#0)")
+    (def-inline cl:sinh :always (fixnum-float) :long-double "sinhl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:sinh :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t)
+    (def-inline cl:sinh :always (fixnum-float) :float "sinhf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:sinh :always (si:complex-single-float) :csfloat "csinhf(#0)")
+      (def-inline cl:sinh :always (si:complex-double-float) :cdfloat "csinh(#0)")
+      (def-inline cl:sinh :always (si:complex-long-float) :clfloat "csinhl(#0)"))
+
+    (def-inline cl:cosh :always (t) number "ecl_cosh(#0)")
+    (def-inline cl:cosh :always (fixnum-float) :long-double "coshl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:cosh :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t)
+    (def-inline cl:cosh :always (fixnum-float) :float "coshf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:cosh :always (si:complex-single-float) :csfloat "ccoshf(#0)")
+      (def-inline cl:cosh :always (si:complex-double-float) :cdfloat "ccosh(#0)")
+      (def-inline cl:cosh :always (si:complex-long-float) :clfloat "ccoshl(#0)"))
+
+    (def-inline cl:tanh :always (t) number "ecl_tanh(#0)")
+    (def-inline cl:tanh :always (fixnum-float) :long-double "tanhl((long double)(#0))" :exact-return-type t)
+    (def-inline cl:tanh :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t)
+    (def-inline cl:tanh :always (fixnum-float) :float "tanhf((float)(#0))" :exact-return-type t)
+    (when (member :complex-float *features*)
+      (def-inline cl:tanh :always (si:complex-single-float) :csfloat "ctanhf(#0)")
+      (def-inline cl:tanh :always (si:complex-double-float) :cdfloat "ctanh(#0)")
+      (def-inline cl:tanh :always (si:complex-long-float) :clfloat "ctanhl(#0)"))
+
+    ;; file package.d
+
+    ;; file pathname.d
+
+    (def-inline cl:null :always (t) :bool "#0==ECL_NIL")
+    (def-inline cl:symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)")
+    (def-inline cl:atom :always (t) :bool "@0;ECL_ATOM(#0)")
+    (def-inline cl:consp :always (t) :bool "@0;ECL_CONSP(#0)")
+    (def-inline cl:listp :always (t) :bool "@0;ECL_LISTP(#0)")
+    (def-inline cl:numberp :always (t) :bool "ecl_numberp(#0)")
+    (def-inline cl:integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)")
+    (def-inline cl:floatp :always (t) :bool "floatp(#0)")
+    (def-inline cl:characterp :always (t) :bool "ECL_CHARACTERP(#0)")
+    (def-inline si:base-char-p :always (character) :bool "ECL_BASE_CHAR_P(#0)")
+    (def-inline cl:stringp :always (t) :bool "@0;ECL_STRINGP(#0)")
+    (def-inline si:base-string-p :always (t) :bool "@0;ECL_BASE_STRING_P(#0)")
+    (def-inline cl:bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)")
+    (def-inline cl:vectorp :always (t) :bool "@0;ECL_VECTORP(#0)")
+    (def-inline cl:arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)")
+
+    (def-inline cl:eq :always (t t) :bool "(#0)==(#1)")
+    (def-inline cl:eq :always (fixnum fixnum) :bool "(#0)==(#1)")
+
+    (def-inline cl:eql :always (t t) :bool "ecl_eql(#0,#1)")
+    (def-inline cl:eql :always (character t) :bool "(ECL_CODE_CHAR(#0)==(#1))")
+    (def-inline cl:eql :always (t character) :bool "((#0)==ECL_CODE_CHAR(#1))")
+    (def-inline cl:eql :always (character character) :bool "(#0)==(#1)")
+    (def-inline cl:eql :always ((not (or complex bignum ratio float)) t) :bool "(#0)==(#1)")
+    (def-inline cl:eql :always (t (not (or complex bignum ratio float))) :bool "(#0)==(#1)")
+    (def-inline cl:eql :always (fixnum fixnum) :bool "(#0)==(#1)")
+
+    (def-inline cl:equal :always (t t) :bool "ecl_equal(#0,#1)")
+    (def-inline cl:equal :always (fixnum fixnum) :bool "(#0)==(#1)")
+
+    (def-inline cl:equalp :always (t t) :bool "ecl_equalp(#0,#1)")
+    (def-inline cl:equalp :always (fixnum fixnum) :bool "(#0)==(#1)")
+
+    (def-inline cl:not :always (t) :bool "(#0)==ECL_NIL")
+
+    ;; file print.d, read.d
+
+    (def-inline cl:clear-output :always (stream) NULL "(ecl_clear_output(#0),ECL_NIL)")
+    (def-inline cl:finish-output :always (stream) NULL "(ecl_finish_output(#0),ECL_NIL)")
+    (def-inline cl:finish-output :always (stream) NULL "(ecl_force_output(#0),ECL_NIL)")
+    (def-inline cl:write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),ECL_NIL),(#0))")
+    (def-inline cl:clear-input :always (stream) NULL "(ecl_clear_input(#0),ECL_NIL)")
+    (def-inline cl:copy-readtable :always (null null) t "standard_readtable")
+
+    (def-inline cl:boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)")
+    (def-inline cl:boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL")
+
+    ;; file unixsys.d
+
+    ;; file sequence.d
+
+    (def-inline cl:elt :always (t t) t "ecl_elt(#0,ecl_to_size(#1))")
+    (def-inline cl:elt :always (t fixnum) t "ecl_elt(#0,#1)")
+    (def-inline cl:elt :unsafe (t t) t "ecl_elt(#0,ecl_fixnum(#1))")
+    (def-inline cl:elt :unsafe (t fixnum) t "ecl_elt(#0,#1)")
+    (def-inline cl:elt :unsafe (vector t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))")
+    (def-inline cl:elt :unsafe (vector fixnum) t "ecl_aref_unsafe(#0,#1)")
+    (def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))")
+    (def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)")
+    (when (member :unicode *features*)
+      (def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]"))
+    (def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]")
+    (def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]")
+    (def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]")
+    (def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]")
+
+    (def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)")
+    (def-inline si:elt-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)")
+    (def-inline si:elt-set :unsafe (t t t) t "ecl_elt_set(#0,ecl_fixnum(#1),#2)")
+    (def-inline si:elt-set :unsafe (vector t t) t "ecl_aset_unsafe(#0,ecl_to_size(#1),#2)")
+    (def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset_unsafe(#0,#1,#2)")
+
+    (def-inline cl:length :always (t) :fixnum "ecl_length(#0)")
+    (def-inline cl:length :unsafe (vector) :fixnum "(#0)->vector.fillp")
+
+    (def-inline cl:copy-seq :always (t) t "ecl_copy_seq(#0)")
+
+    ;; file character.d
+
+    (def-inline cl:char :always (t fixnum) t "ecl_aref1(#0,#1)")
+    (def-inline cl:char :always (t fixnum) :wchar "ecl_char(#0,#1)")
+    (if (member :unicode *features*)
+        (def-inline cl:char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]")
+        (progn
+          (def-inline cl:char :unsafe (t t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])")
+          (def-inline cl:char :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]")))
+    (def-inline cl:char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]")
+
+    (def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)")
+    (def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)")
+    (def-inline si:char-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)")
+
+    (unless (member :unicode *features*)
+      (def-inline si:char-set :unsafe (t t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))")
+      (def-inline si:char-set :unsafe (t fixnum character) :unsigned-char "(#0)->base_string.self[#1]= #2"))
+    (def-inline si:char-set :unsafe (base-string t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))")
+    (def-inline si:char-set :unsafe (base-string fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2")
+    (def-inline si:char-set :unsafe (ext:extended-string t t) t "@2;((#0)->string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))")
+    (def-inline si:char-set :unsafe (ext:extended-string fixnum character) :unsigned-char "(#0)->string.self[#1]= #2")
+
+    (def-inline cl:schar :always (t t) t "ecl_elt(#0,ecl_to_size(#1))")
+    (def-inline cl:schar :always (t fixnum) t "ecl_elt(#0,#1)")
+    (def-inline cl:schar :always (t fixnum) :wchar "ecl_char(#0,#1)")
+    (def-inline cl:schar :unsafe (base-string t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])")
+    (def-inline cl:schar :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]")
+    (if (member :unicode *features*)
+        (def-inline cl:schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]")
+        (def-inline cl:schar :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]"))
+    (def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)")
+    (def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)")
+    (def-inline si:schar-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)")
+    (if (member :unicode *features*)
+        (progn
+          (def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :wchar "@2;((#0)->string.self[#1]= ecl_char_code(#2),(#2))")
+          (def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar "(#0)->string.self[#1]= #2"))
+        (progn
+          (def-inline si:schar-set :unsafe (t t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))")
+          (def-inline si:schar-set :unsafe (t fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2")))
+    (def-inline si:schar-set :unsafe (base-string t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))")
+    (def-inline si:schar-set :unsafe (base-string fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2")
+
+    (def-inline cl:string= :always (string string) :bool "ecl_string_eq(#0,#1)")
+
+    ;; file structure.d
+
+    (def-inline si:structure-name :always (structure-object) symbol "ECL_STRUCT_NAME(#0)")
+    (def-inline si:structure-ref :always (t t fixnum) t "ecl_structure_ref(#0,#1,#2)")
+    (def-inline si:structure-set :always (t t fixnum t) t "ecl_structure_set(#0,#1,#2,#3)")
+
+    ;; file symbol.d
+
+    (def-inline cl:get :always (t t t) t "ecl_get(#0,#1,#2)")
+    (def-inline cl:get :always (t t) t "ecl_get(#0,#1,ECL_NIL)")
+
+    (def-inline cl:symbol-name :always (t) string "ecl_symbol_name(#0)")
+
+    ;; Additions used by the compiler.
+    ;; The following functions do not exist. They are always expanded into the
+    ;; given C code. References to these functions are generated in the C1 phase.
+
+    (def-inline shift>> :always (fixnum fixnum) :fixnum "((#0) >> (- (#1)))")
+    (def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))")
+
+    (def-inline si:short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)")
+    (def-inline si:single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)")
+    (def-inline si:double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)")
+    (def-inline si:long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)")
+
+    (when (member :complex-float *features*)
+      (def-inline si::complex-single-float-p :always (t) :bool "@0;ECL_COMPLEX_SINGLE_FLOAT_P(#0)")
+      (def-inline si::complex-double-float-p :always (t) :bool "@0;ECL_COMPLEX_DOUBLE_FLOAT_P(#0)")
+      (def-inline si::complex-long-float-p :always (t) :bool "@0;ECL_COMPLEX_LONG_FLOAT_P(#0)"))
+
+    (def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)")
+    (def-inline ext:fixnump :always (fixnum) :bool "1")
+
+    ;; Functions only available with threads
+    (when (member :threads *features*)
+      (def-inline mp:lock-count :unsafe (mp:lock) fixnum "((#0)->lock.counter)")
+      (def-inline mp:compare-and-swap-car :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CAR(#0),(#1),(#2))")
+      (def-inline mp:atomic-incf-car :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CAR(#0),(#1))")
+      (def-inline mp:atomic-incf-car :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CAR(#0),(#1))")
+
+      (def-inline mp:compare-and-swap-cdr :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CDR(#0),(#1),(#2))")
+      (def-inline mp:atomic-incf-cdr :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CDR(#0),(#1))")
+      (def-inline mp:atomic-incf-cdr :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CDR(#0),(#1))")
+
+      (def-inline mp:compare-and-swap-symbol-value :unsafe (symbol t t) t "ecl_compare_and_swap(ecl_bds_ref(ecl_process_env(),(#0)),(#1),(#2))")
+      (def-inline mp:atomic-incf-symbol-value :always (t fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))")
+      (def-inline mp:atomic-incf-symbol-value :unsafe (symbol t) t "ecl_atomic_incf(ecl_bds_ref(ecl_process_env(),(#0)),(#1))")
+      (def-inline mp:atomic-incf-symbol-value :unsafe (symbol fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))")
+
+      (def-inline mp:compare-and-swap-svref :unsafe (t t t t) t "ecl_compare_and_swap((#0)->vector.self.t + ecl_fixnum(#1),(#2),(#3))")
+      (def-inline mp:compare-and-swap-svref :unsafe (t fixnum t t) t "ecl_compare_and_swap((#0)->vector.self.t + (#1),(#2),(#3))")
+
+      ;; :threads are implicit
+      (when (member :clos *features*)
+        (def-inline mp:compare-and-swap-instance :always (t fixnum t t) t "ecl_compare_and_swap_instance((#0),(#1),(#2),(#3))")
+        (def-inline mp:compare-and-swap-instance :unsafe (standard-object fixnum t t) t "ecl_compare_and_swap((#0)->instance.slots+(#1),(#2),(#3))")
+        (def-inline mp:atomic-incf-instance :always (t fixnum t) t "ecl_atomic_incf_instance((#0),(#1),(#2))")
+        (def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum t) t "ecl_atomic_incf((#0)->instance.slots+(#1),(#2))")
+        (def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum fixnum) t "ecl_atomic_incf_by_fixnum((#0)->instance.slots+(#1),(#2))"))
+
+      (def-inline mp:compare-and-swap-structure :unsafe (structure-object t fixnum t t) t "ecl_compare_and_swap(&(ECL_STRUCT_SLOT((#0),(#2))),(#3),(#4))"))
+
+    ;; Functions only available with CLOS
+    (when (member :clos *features*)
+      (def-inline si:instance-ref :always (t fixnum) t "ecl_instance_ref((#0),(#1))")
+      (def-inline si:instance-ref :unsafe (standard-object fixnum) t "(#0)->instance.slots[#1]")
+      (def-inline si::instance-slotds :unsafe (standard-object) list "(#0)->instance.slotds")
+
+      (def-inline si:instance-set :unsafe (t fixnum t) t "ecl_instance_set((#0),(#1),(#2))")
+      (def-inline si:instance-set :unsafe (standard-object fixnum t) t "(#0)->instance.slots[#1]=(#2)")
+
+      (def-inline si:instance-class :always (standard-object) t "ECL_CLASS_OF(#0)")
+      (def-inline cl:class-of :unsafe (standard-object) t "ECL_CLASS_OF(#0)")
+
+      (def-inline si:instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)")
+      (def-inline si:unbound :always nil t "ECL_UNBOUND")
+
+      (def-inline si:sl-boundp :always (t) :bool "(#0)!=ECL_UNBOUND")
+
+      (def-inline clos:standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))")
+      (def-inline clos:standard-instance-access :unsafe (standard-object fixnum) t "(#0)->instance.slots[#1]")
+
+      (def-inline clos:funcallable-standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))")
+      (def-inline clos:funcallable-standard-instance-access :unsafe (clos:funcallable-standard-object fixnum) t "(#0)->instance.slots[#1]"))
+
+    *inline-information*))

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

@@ -5,18 +5,18 @@
 ;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 ;;;;  Copyright (c) 1990, Giuseppe Attardi.
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
-;;;;    See file '../Copyright' for full details.
+
 ;;;;
-;;;; CMPC-INLINER -- Open coding functions as C expressions
+;;;; Open coding functions as C expressions.
 ;;;;
 
 (in-package "COMPILER")
 
+(setf (machine-inline-information *default-machine*)
+      (make-inline-information *default-machine*))
+
 (defun inlined-arg-loc (arg)
   (second arg))
 
@@ -185,3 +185,112 @@
               (nreverse rts))
         inline-info))))
 
+(defun c-inline-safe-string (constant-string)
+  ;; Produce a text representation of a string that can be used
+  ;; in a C-INLINE form, without triggering the @ or # escape
+  ;; characters
+  (c-filtered-string
+   (concatenate 'string
+                (loop for c across constant-string
+                      when (member c '(#\# #\@))
+                        collect c
+                      collect c))))
+
+(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
+                           c-expression side-effects one-liner)
+  (let* (args-to-be-saved
+         coerced-arguments)
+    ;; If the expression begins with @[0-9a-z]*, this means we are
+    ;; saving some variables.
+    (when (and (> (length c-expression) 1)
+               (eq (char c-expression 0) #\@))
+      (do ((ndx 1 (1+ ndx)))
+          ((>= ndx (length c-expression)))
+        (let ((c (char c-expression ndx)))
+          (when (eq c #\;)
+            (setf c-expression (subseq c-expression (1+ ndx)))
+            (return))
+          (unless (alphanumericp c)
+            (setf args-to-be-saved nil)
+            (return))
+          (push (- (char-code c) (char-code #\0))
+                args-to-be-saved))))
+
+    (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved))
+    ;;(setf output-rep-type (lisp-type->rep-type output-rep-type))
+
+    ;; If the form does not output any data, and there are no side
+    ;; effects, try to omit it.
+    (when (null output-rep-type)
+      (if side-effects
+          (progn
+            (wt-nl)
+            (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil)
+            (when one-liner (wt ";")))
+          (cmpnote "Ignoring form ~S" c-expression))
+      (wt-nl "value0 = ECL_NIL;")
+      (wt-nl "cl_env_copy->nvalues = 0;")
+      (return-from produce-inline-loc 'RETURN))
+
+    ;; If the form is a one-liner, we can simply propagate this expression until the
+    ;; place where the value is used.
+    (when one-liner
+      (return-from produce-inline-loc
+        `(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
+                       ,(if (equalp output-rep-type '((VALUES &REST T)))
+                            'VALUES NIL))))
+
+    ;; If the output is a in the VALUES vector, just write down the form and output
+    ;; the location of the data.
+    (when (equalp output-rep-type '((VALUES &REST T)))
+      (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
+                       'VALUES)
+      (return-from produce-inline-loc 'VALUES))
+
+    ;; Otherwise we have to set up variables for holding the output.
+    (flet ((make-output-var (type)
+             (let ((var (make-lcl-var :rep-type type)))
+               (wt-nl (rep-type->c-name type) " " var ";")
+               var)))
+      (open-inline-block)
+      (let ((output-vars (mapcar #'make-output-var output-rep-type)))
+        (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars)
+        (cond ((= (length output-vars) 1)
+               (first output-vars))
+              (t
+               (loop for v in output-vars
+                     for i from 0
+                     do (let ((*destination* `(VALUE ,i))) (set-loc v)))
+               (wt "cl_env_copy->nvalues = " (length output-vars) ";")
+               'VALUES))))))
+
+(defun coerce-locs (inlined-args &optional types args-to-be-saved)
+  ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the
+  ;; inline code. ARGS-TO-BE-SAVED is a positional list created by
+  ;; C-INLINE, instructing that the value should be saved in a temporary
+  ;; variable. Finally, TYPES is a list of destination types, to which
+  ;; the former values are coerced. The destination types can be
+  ;;    - A lisp type (:OBJECT, :FINXUM, etc)
+  ;;    - A machine representation type (T, INTEGER, etc)
+  (loop with block-opened = nil
+        for (lisp-type loc) in inlined-args
+        for type in (or types '#1=(:object . #1#))
+        for i from 0
+        for rep-type = (lisp-type->rep-type type)
+        collect
+        (cond ((and args-to-be-saved
+                    (member i args-to-be-saved :test #'eql)
+                    (not (loc-movable-p loc)))
+               (let ((lcl (make-lcl-var :rep-type rep-type)))
+                 (wt-nl)
+                 (unless block-opened
+                   (setf block-opened t)
+                   (open-inline-block))
+                 (wt (rep-type->c-name rep-type) " " lcl "= ")
+                 (wt-coerce-loc rep-type loc)
+                 (wt ";")
+                 lcl))
+              ((equal rep-type (loc-representation-type loc))
+               loc)
+              (t
+               `(COERCE-LOC ,rep-type ,loc)))))

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

@@ -1,4 +1,5 @@
 
+;;;;
 ;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
 ;;;;  Copyright (c) 1990, Giuseppe Attardi
 ;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
@@ -61,6 +62,30 @@
        (when (subtypep type (rep-type-lisp-type record))
          (return-from lisp-type->rep-type (rep-type-name record)))))))
 
+(defun c-number-rep-type-p (rep-type)
+  (let ((r (rep-type-record-unsafe rep-type)))
+    (and r (rep-type-numberp r))))
+
+(defun c-integer-rep-type-p (rep-type)
+  (let ((r (rep-type-record-unsafe rep-type)))
+    (and r (rep-type-integerp r))))
+
+(defun c-integer-rep-type-bits (rep-type)
+  (let ((r (rep-type-record-unsafe rep-type)))
+    (and r (rep-type-bits r))))
+
+(defun c-number-type-p (type)
+  (c-number-rep-type-p (lisp-type->rep-type type)))
+
+(defun c-integer-type-p (type)
+  (c-integer-rep-type-p (lisp-type->rep-type type)))
+
+(defun c-integer-type-bits (type)
+  (c-number-rep-type-bits (lisp-type->rep-type type)))
+
+(defun rep-type->c-name (type)
+  (rep-type-c-name (rep-type-record type)))
+
 ;; These types can be used by ECL to unbox data They are sorted from
 ;; the most specific, to the least specific one.  All functions must
 ;; be declared in external.h (not internal.h) header file.

src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp

@@ -2,16 +2,12 @@
 ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
 
 ;;;;
-;;;; CMPCT --  Optimizer for several constant values
-
 ;;;;  Copyright (c) 2003, Juan Jose Garcia Ripoll.
 ;;;;
-;;;;    ECoLisp is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
-;;;;    See file '../Copyright' for full details.
+
+;;;;  Optimizer for several constant values
 
 (in-package "COMPILER")
 

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

@@ -2,17 +2,13 @@
 ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
 
 ;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
+;;;;  Copyright (c) 1990, Giuseppe Attardi
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
-;;;;    See file '../Copyright' for full details.
 
-;;;; CMPINLINE  Open coding optimizer.
+;;;; Open coding optimizer.
 
 (in-package "COMPILER")
 
@@ -50,11 +46,6 @@
     (set-loc loc)
     temp))
 
-(defmacro with-inlined-loc ((temp-loc loc) &rest body)
-  `(let ((,temp-loc (save-inline-loc ,loc)))
-     (setf ,temp-loc (list (var-type ,temp-loc) ,temp-loc))
-     ,@body))
-
 (defun emit-inlined-variable (form rest-forms)
   (let ((var (c1form-arg 0 form))
         (value-type (c1form-primary-type form)))
@@ -104,7 +95,7 @@
 
 (defun emit-inlined-structure-ref (form rest-forms)
   (let ((type (c1form-primary-type form)))
-    (if (args-cause-side-effect rest-forms)
+    (if (some #'c1form-side-effects rest-forms)
         (let* ((temp (make-inline-temp-var type :object))
                (*destination* temp))
           (c2expr* form)
@@ -119,7 +110,7 @@
 
 (defun emit-inlined-instance-ref (form rest-forms)
   (let ((type (c1form-primary-type form)))
-    (if (args-cause-side-effect rest-forms)
+    (if (some #'c1form-side-effects rest-forms)
         (let* ((temp (make-inline-temp-var type :object))
                (*destination* temp))
           (c2expr* form)
@@ -185,16 +176,3 @@
 (defun close-inline-blocks ()
   (loop for i of-type fixnum from 0 below *inline-blocks*
      do (wt-nl-close-brace)))
-
-(defun form-causes-side-effect (form)
-  (c1form-side-effects form))
-
-(defun args-cause-side-effect (forms)
-  (some #'c1form-side-effects forms))
-
-(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/cmpbackend-cxx/cmpc-opt-num.lsp

@@ -0,0 +1,152 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 2010, Juan Jose Garcia Ripoll
+;;;;  Copyright (c) 2023, Daniel Kochmański
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;; C/C++ specific optimizer for numerical expressions.
+
+(in-package "COMPILER")
+
+;;;
+;;; Bit fiddling. It is a bit tricky because C does not allow
+;;; shifts in << or >> which exceed the integer size. In those
+;;; cases the compiler may do whatever it wants (and gcc does!)
+;;;
+(define-c-inliner shift (return-type argument orig-shift)
+  (let* ((arg-type (inlined-arg-type argument))
+         (arg-c-type (lisp-type->rep-type arg-type))
+         (return-c-type (lisp-type->rep-type return-type))
+         (shift (loc-immediate-value (inlined-arg-loc orig-shift))))
+    (if (or (not (c-integer-rep-type-p arg-c-type))
+            (not (c-integer-rep-type-p return-c-type)))
+        (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object)
+                            "ecl_ash(#0,#1)" nil t)
+        (let* ((arg-bits (c-integer-rep-type-bits arg-c-type))
+               (return-bits (c-integer-rep-type-bits return-c-type))
+               (max-type (if (and (plusp shift)
+                                  (< arg-bits return-bits))
+                             return-c-type
+                             arg-c-type)))
+          (produce-inline-loc (list argument) (list max-type) (list return-type)
+                              (format nil
+                                      (if (minusp shift)
+                                          "((#0) >> (~D))"
+                                          "((#0) << (~D))")
+                                      (abs shift))
+                              nil t)))))
+
+;;;
+;;; Inliners for arithmetic operations.
+;;;
+
+(defun most-generic-number-rep-type (r1 r2)
+  (let* ((r1 (rep-type-record r1))
+         (r2 (rep-type-record r2)))
+    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
+                       r2
+                       r1))))
+
+(defun inline-binop (expected-type arg1 arg2 consing non-consing)
+  (let ((arg1-type (inlined-arg-type arg1))
+        (arg2-type (inlined-arg-type arg2)))
+    (if (and (policy-assume-right-type)
+             (c-number-type-p expected-type)
+             (c-number-type-p arg1-type)
+             (c-number-type-p arg2-type))
+        ;; The input arguments have to be coerced to a C
+        ;; type that fits the output, to avoid overflow which
+        ;; would happen if we used say, long c = (int)a * (int)b
+        ;; as the output would be an integer, not a long.
+        (let* ((arg1-rep (lisp-type->rep-type arg1-type))
+               (arg2-rep (lisp-type->rep-type arg2-type))
+               (out-rep (lisp-type->rep-type expected-type))
+               (max-rep (most-generic-number-rep-type
+                         (most-generic-number-rep-type
+                          arg1-rep arg2-rep) out-rep))
+               (max-name (rep-type->c-name max-rep)))
+          (produce-inline-loc
+           (list arg1 arg2)
+           (list arg1-rep arg2-rep)
+           (list max-rep)
+           (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)"
+                   (unless (eq arg1-rep max-rep) max-name)
+                   non-consing
+                   (unless (eq arg2-rep max-rep) max-name))
+           nil t))
+        (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
+                            consing nil t))))
+
+(defun inline-arith-unop (expected-type arg1 consing non-consing)
+  (let ((arg1-type (inlined-arg-type arg1)))
+    (if (and (policy-assume-right-type)
+             (c-number-type-p expected-type)
+             (c-number-type-p arg1-type))
+        (produce-inline-loc (list arg1)
+                            (list (lisp-type->rep-type arg1-type))
+                            (list (lisp-type->rep-type expected-type))
+                            non-consing nil t)
+        (produce-inline-loc (list arg1) '(:object :object) '(:object)
+                            consing nil t))))
+
+(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
+  (when (null arguments)
+    (return '(fixnum-value 0)))
+  (setf arg1 (pop arguments))
+  (when (null arguments)
+    (return (inlined-arg-loc arg1)))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
+     do (if arguments
+            (setf arg1 (save-inline-loc result))
+            (return result))))
+
+(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
+  (when (null arguments)
+    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
+     do (if arguments
+            (setf arg1 (save-inline-loc result))
+            (return result))))
+
+(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
+  (when (null arguments)
+    (return '(fixnum-value 1)))
+  (setf arg1 (pop arguments))
+  (when (null arguments)
+    (return (inlined-arg-loc arg1)))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
+     do (if arguments
+            (setf arg1 (save-inline-loc result))
+            (return result))))
+
+(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
+  (when (null arguments)
+    (return (inline-arith-unop return-type arg1
+                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
+     do (if arguments
+            (setf arg1 (save-inline-loc result))
+            (return result))))
+
+(define-c-inliner float (return-type arg &optional float)
+  (let ((arg-c-type (lisp-type->rep-type (inlined-arg-type arg)))
+        (flt-c-type (lisp-type->rep-type (inlined-arg-type float))))
+    (when (member flt-c-type '(:float :double :long-double))
+      (if (eq arg-c-type flt-c-type)
+          (inlined-arg-loc arg)
+          (produce-inline-loc (list arg)
+                              (list :object)
+                              (list flt-c-type)
+                              (ecase flt-c-type
+                                (:float       "ecl_to_float(#0)")
+                                (:double      "ecl_to_double(#0)")
+                                (:long-double "ecl_to_long_double(#0)"))
+                              nil t)))))

src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp

@@ -0,0 +1,56 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 2010, Juan Jose Garcia Ripoll
+;;;;  Copyright (c) 2023, Daniel Kochmański
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;; C/C++ specific optimizer for the printer.
+
+(in-package "COMPILER")
+
+;;; TODO move mundane inliners to the sysfun database.
+
+(define-c-inliner terpri (return-type &optional stream)
+  (produce-inline-loc (list stream)
+                      '(:object) '(:object)
+                      "ecl_terpri(#0)" t t))
+
+(define-c-inliner print (return-type value &optional stream)
+  (produce-inline-loc (list value stream)
+                      '(:object :object) '(:object)
+                      "ecl_print(#0,#1)" t t))
+
+(define-c-inliner prin1 (return-type value &optional stream)
+  (produce-inline-loc (list value stream)
+                      '(:object :object) '(:object)
+                      "ecl_prin1(#0,#1)" t t))
+
+#+ (or)
+(define-c-inliner princ (return-type expression &optional stream)
+  (produce-inline-loc (list expression stream)
+                      '(:object :object) '(:object)
+                      "ecl_princ(#0,#1)" t t))
+
+(define-c-inliner princ (return-type expression &optional stream)
+  (multiple-value-bind (foundp value)
+      (loc-immediate-value-p (inlined-arg-loc expression))
+    (cond
+      ((and foundp (characterp value))
+       (produce-inline-loc (list expression stream)
+                           '(:wchar :object) '(:wchar)
+                           "ecl_princ_char(#0,#1)" t t))
+      ((and foundp (typep value 'base-string) (< (length value) 80))
+       (produce-inline-loc (list stream)
+                           '(:object) '(:void)
+                           (concatenate 'string "ecl_princ_str("
+                                        (c-inline-safe-string value)
+                                        ",#0)")
+                           t t))
+      (t
+       (produce-inline-loc (list expression stream)
+                           '(:object :object) '(:object)
+                           "ecl_princ(#0,#1)" t t)))))

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

@@ -0,0 +1,140 @@
+
+;;; Global variables, flag definitions and utilities.
+
+(in-package "COMPILER")
+
+;;; *inline-blocks* holds the number of C blocks opened for declaring temps for
+;;; intermediate results of the evaluation of inlined function calls.
+
+(defvar *inline-blocks* 0)
+(defvar *opened-c-braces* 0)
+
+(defvar *emitted-local-funs* 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)
+;;; 4. lexi[j], for lexical variables in local functions
+;;; 5. CLVi, for lexical variables in closures
+
+(defvar *lcl* 0)                ; number of local variables
+
+(defvar *temp* 0)               ; number of temporary variables
+(defvar *max-temp* 0)           ; maximum *temp* reached
+
+(defvar *level* 0)              ; nesting level for local functions
+
+(defvar *lex* 0)                ; number of lexical variables in local functions
+(defvar *max-lex* 0)            ; maximum *lex* reached
+
+(defvar *env* 0)                ; number of variables in current form
+(defvar *max-env* 0)            ; maximum *env* in whole function
+(defvar *env-lvl* 0)            ; number of levels of environments
+(defvar *aux-closure* nil)      ; stack allocated closure needed for indirect calls
+(defvar *ihs-used-p* nil)       ; function must be registered in IHS?
+
+(defvar *next-cfun* 0)          ; holds the last cfun used.
+
+;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
+;;; If possible, *tail-recursion-info* holds
+;;;     ( c1-lambda-form  required-arg .... required-arg ),
+;;; where each required-arg is a var-object.
+(defvar *tail-recursion-info* nil)
+
+;;; --cmpexit.lsp--
+;;;
+;;; *last-label* holds the label# of the last used label.
+;;; *exit* holds an 'exit', which is
+;;      ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
+;;      RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT,
+;;      RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT).
+;;; *unwind-exit* holds a list consisting of:
+;;      ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
+;;      JUMP, BDS-BIND (each pushed for a single special binding), or a
+;;      LCL (which holds the bind stack pointer used to unbind).
+;;;
+(defvar *last-label* 0)
+(defvar *exit*)
+(defvar *unwind-exit*)
+
+;;; ----------------------------------------------------------------------
+;;; CONVENIENCE FUNCTIONS / MACROS
+;;;
+
+(defmacro with-cxx-env (() &body body)
+  `(let ((*inline-blocks* 0)
+         (*open-c-braces* 0)
+         (*temp* 0)
+         (*max-temp* 0)
+         (*next-cfun* 0)
+         (*last-label* 0))
+     ,@body))
+
+(defun-cached env-var-name (n) eql
+  (format nil "env~D" n))
+
+(defun-cached lex-env-var-name (n) eql
+  (format nil "lex~D" n))
+
+(defun next-lcl (&optional name)
+  (list 'LCL (incf *lcl*) T
+        (if (and name (symbol-package name))
+            (lisp-to-c-name name)
+            "")))
+
+(defun next-temp ()
+  (prog1 *temp*
+         (incf *temp*)
+         (setq *max-temp* (max *temp* *max-temp*))))
+
+(defun next-lex ()
+  (prog1 (cons *level* *lex*)
+         (incf *lex*)
+         (setq *max-lex* (max *lex* *max-lex*))))
+
+(defun next-env ()
+  (prog1 *env*
+    (incf *env*)
+    (setq *max-env* (max *env* *max-env*))))
+
+(defun env-grows (possibily)
+  ;; if additional closure variables are introduced and this is not
+  ;; last form, we must use a new env.
+  (and possibily
+       (plusp *env*)
+       (dolist (exit *unwind-exit*)
+         (case exit
+           (RETURN (return NIL))
+           (BDS-BIND)
+           (t (return T))))))
+
+(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
+  (let ((code (incf *next-cfun*)))
+    (format nil prefix code (lisp-to-c-name lisp-name))))
+
+(defun next-label ()
+  (cons (incf *last-label*) nil))
+
+(defun next-label* ()
+  (cons (incf *last-label*) t))
+
+(defun labelp (x)
+  (and (consp x) (integerp (si:cons-car x))))
+
+(defun maybe-next-label ()
+  (if (labelp *exit*)
+      *exit*
+      (next-label)))
+
+(defmacro with-exit-label ((label) &body body)
+  `(let* ((,label (next-label))
+          (*unwind-exit* (cons ,label *unwind-exit*)))
+     ,@body
+     (wt-label ,label)))
+
+(defmacro with-optional-exit-label ((label) &body body)
+  `(let* ((,label (maybe-next-label))
+          (*unwind-exit* (adjoin ,label *unwind-exit*)))
+     ,@body
+     (unless (eq ,label *exit*)
+       (wt-label ,label))))

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

@@ -23,8 +23,8 @@
             (princ form *compiler-output1*))
            (VAR (wt-var form))
            (t (wt-loc form))))
-        ;; ((ext:float-nan-p form)
-        ;;  (format *compiler-output1* "NAN"))
+        ((ext:float-nan-p form)
+         (format *compiler-output1* "NAN"))
         ((ext:float-infinity-p form)
          (if (minusp form)
              (format *compiler-output1* "-INFINITY")

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

@@ -72,7 +72,8 @@
 (defun tail-recursion-possible ()
   (dolist (ue *unwind-exit*
               (baboon :format-control "tail-recursion-possible: should never return."))
-    (cond ((eq ue 'TAIL-RECURSION-MARK) (return t))
+    (cond ((eq ue 'TAIL-RECURSION-MARK)
+           (return t))
           ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME))
            (return nil))
           ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV)))
@@ -155,33 +156,29 @@
   ;; either because it has been proclaimed so, or because it belongs
   ;; to the runtime.
   (multiple-value-bind (found fd minarg maxarg)
-      (si::mangle-name fname t)
+      (si:mangle-name fname t)
     (when found
       (return-from call-global-loc
-        (call-exported-function-loc fname args fd minarg maxarg t
-                                    return-type))))
+        (call-exported-function-loc fname args fd minarg maxarg t return-type))))
 
   (when (policy-use-direct-C-call)
-    (let ((fd (si:get-sysprop fname 'Lfun)))
-      (when fd
-        (multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname)
+    (ext:when-let ((fd (si:get-sysprop fname 'Lfun)))
+      (multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname)
+        (unless found
+          ;; Without knowing the number of arguments we cannot call the C
+          ;; function. When compiling ECL itself, we get this information
+          ;; through si::mangle-name from symbols_list.h for core functions
+          ;; defined in Lisp code.
           #+ecl-min
+          (let (ignored)
+            (multiple-value-setq (found ignored minarg maxarg)
+              (si:mangle-name fname)))
           (unless found
-            ;; Without knowing the number of arguments we cannot call
-            ;; the C function. When compiling ECL itself, we get this
-            ;; information through si::mangle-name from symbols_list.h
-            ;; for core functions defined in Lisp code.
-            (let (ignored)
-              (multiple-value-setq (found ignored minarg maxarg)
-                (si::mangle-name fname))))
-          (unless found
-            (cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed"
-                    fname fd))
-          (return-from call-global-loc
-            (call-exported-function-loc
-             fname args fd minarg maxarg
-             (si::mangle-name fname)
-             return-type))))))
+            (cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed."
+                    fname fd)))
+        (return-from call-global-loc
+          (call-exported-function-loc fname args fd minarg maxarg
+                                      (si:mangle-name fname) return-type)))))
 
   (call-unknown-global-loc fname nil args))
 
@@ -230,58 +227,4 @@
               function-p t)))
   `(CALL-INDIRECT ,loc ,(coerce-locs args) ,fname ,function-p))
 
-
-;;; wt routines
 
-(defun wt-call (fun args &optional fname env)
-  (if env
-      (progn
-        (setf *aux-closure* t)
-        (wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,")
-        (wt-call fun args)
-        (wt ")"))
-      (progn
-        (wt fun "(")
-        (let ((comma ""))
-          (dolist (arg args)
-            (wt comma arg)
-            (setf comma ", ")))
-        (wt ")")))
-  (when fname (wt-comment fname)))
-
-(defun wt-call-indirect (fun-loc args fname function-p)
-  (let ((narg (length args)))
-    (if function-p
-        (wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg)
-        (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg))
-    (dolist (arg args)
-      (wt ", " arg))
-    (wt ")")
-    (when fname (wt-comment fname))))
-
-(defun wt-call-normal (fun args type)
-  (declare (ignore type))
-  (unless (fun-cfun fun)
-    (baboon "Function without a C name: ~A" (fun-name fun)))
-  (let* ((minarg (fun-minarg fun))
-         (maxarg (fun-maxarg fun))
-         (fun-c-name (fun-cfun fun))
-         (fun-lisp-name (fun-name fun))
-         (narg (length args))
-         (env nil))
-    (case (fun-closure fun)
-      (CLOSURE
-       (when (plusp *max-env*)
-         (setf env (environment-accessor fun))))
-      (LEXICAL
-       (let ((lex-lvl (fun-level fun)))
-         (dotimes (n lex-lvl)
-           (let* ((j (- lex-lvl n 1))
-                  (x (lex-env-var-name j)))
-             (push x args))))))
-    (unless (<= minarg narg maxarg)
-      (cmperr "Wrong number of arguments for function ~S"
-              (or fun-lisp-name 'ANONYMOUS)))
-    (when (fun-needs-narg fun)
-      (push narg args))
-    (wt-call fun-c-name args nil env)))

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

@@ -45,18 +45,17 @@
         (wt-nl-close-brace))
       (c2expr body)))
 
-(defun c2return-from (c1form blk type val)
+(defun c2return-from (c1form blk nonlocal val)
   (declare (ignore c1form))
-  (case type
-    (CCB
-     (let ((*destination* 'VALUES)) (c2expr* val))
-     (wt-nl "cl_return_from(" (blk-var blk) "," (add-symbol (blk-name blk)) ");"))
-    ((CLB UNWIND-PROTECT)
-     (let ((*destination* 'VALUES)) (c2expr* val))
-     (wt-nl "cl_return_from(" (blk-var blk) ",ECL_NIL);"))
-    (T (let ((*destination* (blk-destination blk))
-             (*exit* (blk-exit blk)))
-         (c2expr val)))))
+  (if nonlocal
+      (progn
+        (let ((*destination* 'VALUES))
+          (c2expr* val))
+        (let ((name (add-symbol (blk-name blk))))
+          (wt-nl "cl_return_from(" (blk-var blk) "," name ");")))
+      (let ((*destination* (blk-destination blk))
+            (*exit* (blk-exit blk)))
+        (c2expr val))))
 
 
 (defun c2tagbody (c1form tag-loc body)

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

@@ -0,0 +1,121 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  CMPFFI --  Foreign functions interface.
+
+;;;;  Copyright (c) 2003, Juan Jose Garcia-Ripoll.
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+
+(in-package "COMPILER")
+
+;;; ----------------------------------------------------------------------
+;;; C/C++ DECLARATIONS AND HEADERS
+;;;
+;;; All lines from CLINES statements are grouped at the beginning of the header
+;;; Notice that it does not make sense to guarantee that c-lines statements
+;;; are produced in-between the function definitions, because two functions
+;;; might be collapsed into one, or we might not produce that function at all
+;;; and rather inline it.
+;;;
+
+;;; FIXME pass1 handler defined in the pass2 module.
+(defun c1clines (args)
+  (unless (every #'stringp args)
+    (cmperr "The argument to CLINES, ~s, is not a list of strings." args))
+  (setf *clines-string-list* (nconc *clines-string-list* (copy-list args)))
+  '(progn))
+
+(defun output-clines (output-stream)
+  (flet ((parse-one-string (s output-stream)
+           (with-input-from-string (stream s)
+             (loop for c = (read-char stream nil nil)
+                   while c
+                   do (if (eq c #\@)
+                          (let ((object (handler-case (read stream)
+                                          (serious-condition (c)
+                                            (cmperr "Unable to parse FFI:CLINES string~& ~S"
+                                                    s)))))
+                            (let ((*compiler-output1* output-stream))
+                              (wt (add-object object :permanent t))))
+                          (write-char c output-stream))))))
+    (loop for s in *clines-string-list*
+          do (terpri output-stream)
+          do (if (find #\@ s)
+                 (parse-one-string s output-stream)
+                 (write-string s output-stream)))
+    (terpri output-stream)
+    (setf *clines-string-list* nil)))
+
+;; ----------------------------------------------------------------------
+;; C/C++ INLINE CODE
+;;
+
+(defun c2c-progn (c1form variables statements)
+  (declare (ignore c1form))
+  (loop with *destination* = 'TRASH
+        for form in statements
+        do (cond ((stringp form)
+                  (wt-nl)
+                  (wt-c-inline-loc :void form variables
+                                   t    ; side effects
+                                   nil) ; no output variables
+                  )
+                 (t
+                  (c2expr* form)))
+        finally (unwind-exit nil)))
+
+(defun c2c-inline (c1form arguments &rest rest)
+  (declare (ignore c1form))
+  (let ((*inline-blocks* 0)
+        (*temp* *temp*))
+    (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
+    (close-inline-blocks)))
+
+(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code
+                       arg-types arg-type-constants call-type &aux (return-p t))
+  (declare (ignore lisp-name))
+  (when (eql return-type :void)
+    (setf return-p nil))
+  (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type)))
+        (fmod (case call-type
+                ((:cdecl :default) "")
+                (:stdcall "__stdcall ")
+                (t (cmperr "DEFCALLBACK does not support ~A as calling convention"
+                           call-type)))))
+    (wt-nl-h "static " return-type-name " " fmod c-name "(")
+    (wt-nl1  "static " return-type-name " " fmod c-name "(")
+    (loop with comma = ""
+          for n from 0
+          for type in arg-types
+          for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type))
+          do (wt-h comma arg-type-name " var" n)
+             (wt   comma arg-type-name " var" n)
+             (setf comma ","))
+    (wt ")")
+    (wt-h ");")
+    (wt-nl-open-brace)
+    (when return-p
+      (wt-nl return-type-name " output;"))
+    (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
+    (wt-nl "cl_object aux;")
+    (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
+    (loop for n from 0
+          and type in arg-types
+          and ct in arg-type-constants
+          do (wt-nl "ecl_stack_frame_push("
+                    "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")"
+                    ");"))
+    (wt-nl "aux = ecl_apply_from_stack_frame(frame,"
+           "ecl_fdefinition(" c-name-constant "));")
+    (wt-nl "ecl_stack_frame_close(frame);")
+    (when return-p
+      (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);")
+      (wt-nl "return output;"))
+    (wt-nl-close-brace)))

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

@@ -0,0 +1,465 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
+;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;; Set-loc and Wt-loc.
+
+(in-package "COMPILER")
+
+
+;;;
+;;; Mundane locs
+;;;
+
+(defun wt-loc (loc)
+  (cond ((consp loc)
+         (let ((fd (gethash (car loc) *wt-loc-dispatch-table*)))
+           (if fd
+               (apply fd (cdr loc))
+               (unknown-location 'wt-loc loc))))
+        ((symbolp loc)
+         (let ((txt (gethash loc *wt-loc-dispatch-table* :not-found)))
+           (when (eq txt :not-found)
+             (unknown-location 'wt-loc loc))
+           (wt txt)))
+        ((stringp loc)
+         (wt loc))
+        ((var-p loc)
+         (wt-var loc))
+        ((vv-p loc)
+         (wt-vv loc))
+        (t
+         (unknown-location 'wt-loc loc))))
+
+(defun wt-lcl (lcl)
+  (unless (numberp lcl)
+    (baboon :format-control "wt-lcl: ~s NaN"
+            :format-arguments (list lcl)))
+  (wt "v" lcl))
+
+(defun wt-lcl-loc (lcl &optional type name)
+  (declare (ignore type))
+  (unless (numberp lcl)
+    (baboon :format-control "wt-lcl-loc: ~s NaN"
+            :format-arguments (list lcl)))
+  (wt "v" lcl name))
+
+(defun wt-temp (temp)
+  (wt "T" temp))
+
+(defun wt-fixnum (value &optional vv)
+  (declare (ignore vv))
+  (princ value *compiler-output1*)
+  ;; Specify explicit type suffix as a workaround for MSVC. C99
+  ;; standard compliant compilers don't need type suffixes and choose
+  ;; the correct type themselves. Note that we cannot savely use
+  ;; anything smaller than a long long here, because we might perform
+  ;; some other computation on the integer constant which could
+  ;; overflow if we use a smaller integer type (overflows in long long
+  ;; computations are taken care of by the compiler before we get to
+  ;; this point).
+  #+msvc (princ (cond ((typep value (rep-type->lisp-type :long-long)) "LL")
+                      ((typep value (rep-type->lisp-type :unsigned-long-long)) "ULL")
+                      (t (baboon :format-control
+                                 "wt-fixnum: The number ~A doesn't fit any integer type."
+                                 value)))
+                *compiler-output1*))
+
+(defun wt-number (value &optional vv)
+  (declare (ignore vv))
+  (wt value))
+
+(defun wt-character (value &optional vv)
+  (declare (ignore vv))
+  ;; We do not use the '...' format because this creates objects of type
+  ;; 'char' which have sign problems
+  (wt value))
+
+(defun wt-value (i)
+  (wt "cl_env_copy->values[" i "]"))
+
+(defun wt-keyvars (i)
+  (wt "keyvars[" i "]"))
+
+(defun wt-the (type loc)
+  (declare (ignore type))
+  (wt-loc loc))
+
+
+;;;
+;;; CALL-LOC
+;;;
+
+(defun wt-call (fun args &optional fname env)
+  (if env
+      (progn
+        (setf *aux-closure* t)
+        (wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,")
+        (wt-call fun args)
+        (wt ")"))
+      (progn
+        (wt fun "(")
+        (let ((comma ""))
+          (dolist (arg args)
+            (wt comma arg)
+            (setf comma ", ")))
+        (wt ")")))
+  (when fname (wt-comment fname)))
+
+(defun wt-call-indirect (fun-loc args fname function-p)
+  (let ((narg (length args)))
+    (if function-p
+        (wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg)
+        (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg))
+    (dolist (arg args)
+      (wt ", " arg))
+    (wt ")")
+    (when fname (wt-comment fname))))
+
+(defun wt-call-normal (fun args type)
+  (declare (ignore type))
+  (unless (fun-cfun fun)
+    (baboon "Function without a C name: ~A" (fun-name fun)))
+  (let* ((minarg (fun-minarg fun))
+         (maxarg (fun-maxarg fun))
+         (fun-c-name (fun-cfun fun))
+         (fun-lisp-name (fun-name fun))
+         (narg (length args))
+         (env nil))
+    (case (fun-closure fun)
+      (CLOSURE
+       (when (plusp *max-env*)
+         (setf env (environment-accessor fun))))
+      (LEXICAL
+       (let ((lex-lvl (fun-level fun)))
+         (dotimes (n lex-lvl)
+           (let* ((j (- lex-lvl n 1))
+                  (x (lex-env-var-name j)))
+             (push x args))))))
+    (unless (<= minarg narg maxarg)
+      (cmperr "Wrong number of arguments for function ~S"
+              (or fun-lisp-name 'ANONYMOUS)))
+    (when (fun-needs-narg fun)
+      (push narg args))
+    (wt-call fun-c-name args nil env)))
+
+
+;;;
+;;; FDEFINITION, MAKE-CLOSURE
+;;; 
+(defun wt-fdefinition (fun-name)
+  (let* ((name (si::function-block-name fun-name))
+         (package (symbol-package name))
+         (safe (or (not (safe-compile))
+                   (and (or (eq package (find-package "CL"))
+                            (eq package (find-package "CLOS"))
+                            (eq package (find-package "SI")))
+                        (fboundp fun-name)
+                        (functionp (fdefinition fun-name))))))
+    (if (eq name fun-name)
+        ;; #'symbol
+        (let ((vv (add-symbol name)))
+          (if safe
+              (wt "(" vv "->symbol.gfdef)")
+              (wt "ecl_fdefinition(" vv ")")))
+        ;; #'(SETF symbol)
+        (if safe
+            #+(or)
+            (let ((set-loc (assoc name *setf-definitions*)))
+              (unless set-loc
+                (let* ((setf-vv (data-empty-loc))
+                       (name-vv (add-symbol name))
+                       (setf-form-vv (add-object fun-name)))
+                  (setf set-loc (list name setf-vv name-vv setf-form-vv))
+                  (push set-loc *setf-definitions*)))
+              (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")"))
+            (let ((set-loc (assoc name *setf-definitions*)))
+              (unless set-loc
+                (let* ((setf-vv (data-empty-loc))
+                       (name-vv (add-symbol name)))
+                  (setf set-loc (list name setf-vv name-vv))
+                  (push set-loc *setf-definitions*)))
+              (wt "ECL_CONS_CAR(" (second set-loc) ")"))
+            (let ((vv (add-symbol fun-name)))
+              (wt "ecl_fdefinition(" vv ")"))))))
+
+(defun environment-accessor (fun)
+  (let* ((env-var (env-var-name *env-lvl*))
+         (expected-env-size (fun-env fun)))
+    (if (< expected-env-size *env*)
+        (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var)
+        env-var)))
+
+(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
+  (declare (type fun fun))
+  (let* ((closure (fun-closure fun))
+         narg)
+    (cond ((eq closure 'CLOSURE)
+           (wt "ecl_make_cclosure_va((cl_objectfn)" cfun ","
+               (environment-accessor fun)
+               ",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")"))
+          ((eq closure 'LEXICAL)
+           (baboon :format-control "wt-make-closure: lexical closure detected."))
+          ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args
+           (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")"))
+          (t ; empty environment variable number of args
+           (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock,"
+               (min (fun-minarg fun) si:c-arguments-limit) ")")))))
+
+;;;
+;;; COERCE-LOC
+;;;
+
+(defun wt-to-object-conversion (loc-rep-type loc)
+  (when (and (consp loc) (member (first loc)
+                                 '(single-float-value
+                                   double-float-value
+                                   long-float-value
+                                   csfloat-value
+                                   cdfloat-value
+                                   clfloat-value)))
+    (wt (third loc)) ;; VV index
+    (return-from wt-to-object-conversion))
+  (let ((record (rep-type-record loc-rep-type)))
+    (unless record
+      (cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type))
+    (wt (rep-type-to-lisp record) "(" loc ")")))
+
+(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
+  (let* ((record (rep-type-record rep-type))
+         (coercer (and record (rep-type-from-lisp record))))
+    (unless coercer
+      (cmperr "Cannot coerce lisp object to C type ~A" rep-type))
+    (wt (if (or (policy-assume-no-errors)
+                (subtypep loc-type dest-type))
+            (rep-type-from-lisp-unsafe record)
+            coercer)
+        "(" loc ")")))
+
+(defun wt-coerce-loc (dest-rep-type loc)
+  (setq dest-rep-type (lisp-type->rep-type dest-rep-type))
+                                        ;(print dest-rep-type)
+                                        ;(print loc)
+  (let* ((dest-type (rep-type->lisp-type dest-rep-type))
+         (loc-type (loc-type loc))
+         (loc-rep-type (loc-representation-type loc)))
+    (labels ((coercion-error ()
+               (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~
+                        to C/C++ type (~S,~S)"
+                        loc-type loc-rep-type dest-type dest-rep-type))
+             (ensure-valid-object-type (a-lisp-type)
+               (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
+                 (coercion-error))))
+      (when (eq dest-rep-type loc-rep-type)
+        (wt loc)
+        (return-from wt-coerce-loc))
+      (case dest-rep-type
+        ((:char :unsigned-char :wchar)
+         (case loc-rep-type
+           ((:char :unsigned-char :wchar)
+            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
+           ((:object)
+            (ensure-valid-object-type dest-type)
+            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
+           (otherwise
+            (coercion-error))))
+        ((:float :double :long-double)
+         (cond
+           ((c-number-rep-type-p loc-rep-type)
+            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
+           ((eq loc-rep-type :object)
+            ;; We relax the check a bit, because it is valid in C to coerce
+            ;; between floats of different types.
+            (ensure-valid-object-type 'FLOAT)
+            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
+           (t
+            (coercion-error))))
+        ((:csfloat :cdfloat :clfloat)
+         (cond
+           ((c-number-rep-type-p loc-rep-type)
+            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
+           ((eq loc-rep-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)
+            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
+           (t
+            (coercion-error))))
+        ((:bool)
+         (cond
+           ((c-number-rep-type-p loc-rep-type)
+            (wt "1"))
+           ((eq loc-rep-type :object)
+            (wt "(" loc ")!=ECL_NIL"))
+           (t
+            (coercion-error))))
+        ((:object)
+         (case loc-rep-type
+           ((:int-sse-pack :float-sse-pack :double-sse-pack)
+            (when (>= (cmp-env-optimization 'speed) 1)
+              (cmpwarn-style "Boxing a value of type ~S - performance degraded."
+                             loc-rep-type))))
+         (wt-to-object-conversion loc-rep-type loc))
+        ((:pointer-void)
+         (case loc-rep-type
+           ((:object)
+            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
+           ((:cstring)
+            (wt "(char *)(" loc ")"))
+           (otherwise
+            (coercion-error))))
+        ((:cstring)
+         (coercion-error))
+        ((:char*)
+         (case loc-rep-type
+           ((:object)
+            (wt "ecl_base_string_pointer_safe(" loc ")"))
+           ((:pointer-void)
+            (wt "(char *)(" loc ")"))
+           (otherwise
+            (coercion-error))))
+        ((:int-sse-pack :float-sse-pack :double-sse-pack)
+         (case loc-rep-type
+           ((:object)
+            (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc))
+           ;; Implicitly cast between SSE subtypes
+           ((:int-sse-pack :float-sse-pack :double-sse-pack)
+            (wt (ecase dest-rep-type
+                  (:int-sse-pack (ecase loc-rep-type
+                                   (:float-sse-pack "_mm_castps_si128")
+                                   (:double-sse-pack "_mm_castpd_si128")))
+                  (:float-sse-pack (ecase loc-rep-type
+                                     (:int-sse-pack "_mm_castsi128_ps")
+                                     (:double-sse-pack "_mm_castpd_ps")))
+                  (:double-sse-pack (ecase loc-rep-type
+                                      (:int-sse-pack "_mm_castsi128_pd")
+                                      (:float-sse-pack "_mm_castps_pd"))))
+                "(" loc ")"))
+           (otherwise
+            (coercion-error))))
+        (t
+         ;; At this point we only have coercions to integers
+         (cond
+           ((not (c-integer-rep-type-p dest-rep-type))
+            (coercion-error))
+           ((c-number-rep-type-p loc-rep-type)
+            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
+           ((eq :object loc-rep-type)
+            (ensure-valid-object-type dest-type)
+            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
+           (t
+            (coercion-error))))))))
+
+
+;;;
+;;; INLINE-LOC
+;;;
+
+(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
+  (declare (ignore output-rep-type side-effects))
+  (with-input-from-string (s c-expression)
+    (when (and output-vars (not (eq output-vars 'VALUES)))
+      (wt-nl))
+    (do ((c (read-char s nil nil)
+            (read-char s nil nil)))
+        ((null c))
+      (case c
+        (#\@
+         (let ((object (read s)))
+           (cond ((and (consp object) (equal (first object) 'RETURN))
+                  (if (eq output-vars 'VALUES)
+                      (cmperr "User @(RETURN ...) in a C-INLINE form with no output values")
+                      (let ((ndx (or (second object) 0))
+                            (l (length output-vars)))
+                        (if (< ndx l)
+                            (wt (nth ndx output-vars))
+                            (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values"
+                                    ndx l)))))
+                 (t
+                  (when (and (consp object) (eq (first object) 'QUOTE))
+                    (setq object (second object)))
+                  (wt (add-object object :permanent t))))))
+        (#\#
+         (let* ((k (read-char s))
+                (next-char (peek-char nil s nil nil))
+                (index (digit-char-p k 36)))
+           (cond ((eq k #\#)
+                  (wt #\#))
+                 ((or (null index) (and next-char (alphanumericp next-char)))
+                  (wt #\# k))
+                 ((< index (length coerced-arguments))
+                  (wt (nth index coerced-arguments)))
+                 (t
+                  (cmperr "C-INLINE: Variable code exceeds number of arguments")))))
+        (otherwise
+         (write-char c *compiler-output1*))))))
+
+
+;;;
+;;; SET-LOC
+;;;
+
+(defun set-unknown-loc (loc)
+  (declare (ignore loc))
+  (unknown-location 'set-loc *destination*))
+
+(defun set-loc (loc &aux fd)
+  (let ((destination *destination*))
+    (cond ((eq destination loc))
+          ((symbolp destination)
+           (funcall (gethash destination *set-loc-dispatch-table*
+                             'set-unknown-loc)
+                    loc))
+          ((var-p destination)
+           (set-var loc destination))
+          ((vv-p destination)
+           (set-vv loc destination))
+          ((atom destination)
+           (unknown-location 'set-loc destination))
+          (t
+           (let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
+             (if fd
+                 (apply fd loc (rest destination))
+                 (progn
+                   (wt-nl)
+                   (wt-loc destination) (wt " = ")
+                   (wt-coerce-loc (loc-representation-type *destination*) loc)
+                   (wt ";"))))))))
+
+(defun set-the-loc (loc type orig-loc)
+  (declare (ignore type))
+  (let ((*destination* orig-loc))
+    (set-loc loc)))
+                 
+(defun set-values-loc (loc)
+  (cond ((eq loc 'VALUES))
+        ((uses-values loc)
+         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";"))
+        (t
+         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc)
+         (wt ";")
+         (wt-nl "cl_env_copy->nvalues = 1;"))))
+
+(defun set-value0-loc (loc)
+  (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
+
+(defun set-return-loc (loc)
+  (cond ((or (eq loc 'VALUES) (uses-values loc))
+         (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
+        ((eq loc 'VALUE0)
+         (wt-nl "cl_env_copy->nvalues = 1;"))
+        ((eq loc 'RETURN))
+        (t
+         (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")
+         (wt-nl "cl_env_copy->nvalues = 1;"))))
+
+(defun set-trash-loc (loc)
+  (when (loc-with-side-effects-p loc)
+    (wt-nl loc ";")
+    t))

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

@@ -0,0 +1,47 @@
+;;;;
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
+;;;;  Copyright (c) 1990, Giuseppe Attardi
+;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
+;;;;  Copyright (c) 2021, Daniel Kochmański
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+;;;;
+
+(in-package #:compiler)
+
+(defun c2compiler-let (c1form symbols values body)
+  (declare (ignore c1form))
+  (progv symbols values (c2expr body)))
+
+(defun c2function (c1form kind funob fun)
+  (declare (ignore c1form funob))
+  (case kind
+    (GLOBAL
+     (unwind-exit `(FDEFINITION ,fun)))
+    (CLOSURE
+     ;; XXX: we have some code after baboon – is CLOSURE legal or not?
+     (baboon :format-control "c2function: c1form is of unexpected kind.")
+     (new-local fun)
+     (unwind-exit `(MAKE-CCLOSURE ,fun)))))
+
+;;; Mechanism for sharing code.
+(defun new-local (fun)
+  ;; returns the previous function or NIL.
+  (declare (type fun fun))
+  (case (fun-closure fun)
+    (CLOSURE
+     (setf (fun-level fun) 0 (fun-env fun) *env*))
+    (LEXICAL
+     ;; Only increase the lexical level if there have been some
+     ;; new variables created. This way, the same lexical environment
+     ;; can be propagated through nested FLET/LABELS.
+     (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*)
+           (fun-env fun) 0))
+    (otherwise
+     (setf (fun-env fun) 0 (fun-level fun) 0)))
+  (push fun *local-funs*))

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

@@ -90,8 +90,11 @@
 
     (wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
 
-    (loop for form in (nconc *make-forms* *top-level-forms*)
-       do (emit-toplevel-form form c-output-file))
+    (dolist (form *make-forms*)
+      (emit-toplevel-form form c-output-file))
+    (dolist (form *top-level-forms*)
+      (emit-toplevel-form form c-output-file))
+
     (wt-nl-close-many-braces 0)
     (setq top-output-string (get-output-stream-string *compiler-output1*)))
 

src/cmp/cmpenv-proclaim.lsp

@@ -79,14 +79,14 @@
      (dolist (x (cdr decl))
        (cond ((symbolp x)
               (multiple-value-bind (found c-name)
-                  (si::mangle-name x t)
+                  (si:mangle-name x t)
                 (if found
-                    (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x)
+                    (error "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x)
                     (si:put-sysprop x 'Lfun c-name))))
              ((consp x)
               (destructuring-bind (c-name lisp-name) x
-                (if (si::mangle-name lisp-name)
-                    (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name)
+                (if (si:mangle-name lisp-name)
+                    (error "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name)
                     (si:put-sysprop lisp-name 'Lfun c-name))))
              (t
               (error "Syntax error in proclamation ~s" decl)))))

src/cmp/cmpform.lsp

@@ -251,4 +251,3 @@
 (defun c1form-constant-p (form)
   (when (eq (c1form-name form) 'LOCATION)
     (loc-immediate-value-p (c1form-arg 0 form))))
-

src/cmp/cmpfun.lsp

@@ -176,3 +176,10 @@ 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

@@ -20,24 +20,10 @@
 ;;; VARIABLES
 ;;;
 
-;;; --cmpinline.lsp--
-;;;
-;;; Empty info struct
-;;;
-;; (defvar *info* (make-info)) ;unused
-
-(defvar *inline-blocks* 0)
-(defvar *opened-c-braces* 0)
-;;; *inline-blocks* holds the number of C blocks opened for declaring
-;;; temporaries for intermediate results of the evaluation of inlined
-;;; function calls.
-
 (defvar *inline-max-depth* 3
   "Depth at which inlining of functions stops.")
 (defvar *inline-information* nil)
 
-(defvar *emitted-local-funs* nil)
-
 ;;; --cmputil.lsp--
 ;;;
 ;;; Variables and constants for error handling
@@ -100,55 +86,6 @@ running the compiler. It may be updated by running ")
 (defvar *debug* 0)
 (defvar *compilation-speed* 2)
 
-;;;
-;;; 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)
-;;; 4. lexi[j], for lexical variables in local functions
-;;; 5. CLVi, for lexical variables in closures
-
-(defvar *lcl* 0)                ; number of local variables
-
-(defvar *temp* 0)               ; number of temporary variables
-(defvar *max-temp* 0)           ; maximum *temp* reached
-
-(defvar *level* 0)              ; nesting level for local functions
-
-(defvar *lex* 0)                ; number of lexical variables in local functions
-(defvar *max-lex* 0)            ; maximum *lex* reached
-
-(defvar *env* 0)                ; number of variables in current form
-(defvar *max-env* 0)            ; maximum *env* in whole function
-(defvar *env-lvl* 0)            ; number of levels of environments
-(defvar *aux-closure* nil)      ; stack allocated closure needed for indirect calls
-(defvar *ihs-used-p* nil)       ; function must be registered in IHS?
-
-(defvar *next-cfun* 0)          ; holds the last cfun used.
-
-;;;
-;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
-;;; If possible, *tail-recursion-info* holds
-;;      ( c1-lambda-form  required-arg .... required-arg ),
-;;; where each required-arg is a var-object.
-;;;
-(defvar *tail-recursion-info* nil)
-
-;;; --cmpexit.lsp--
-;;;
-;;; *last-label* holds the label# of the last used label.
-;;; *exit* holds an 'exit', which is
-;;      ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
-;;      RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT,
-;;      RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT).
-;;; *unwind-exit* holds a list consisting of:
-;;      ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
-;;      JUMP, BDS-BIND (each pushed for a single special binding), or a
-;;      LCL (which holds the bind stack pointer used to unbind).
-;;;
-(defvar *last-label* 0)
-(defvar *exit*)
-(defvar *unwind-exit*)
-
 (defvar *current-function* nil)
 
 (defvar *cmp-env* nil
@@ -313,10 +250,6 @@ be deleted if they have been opened with LoadLibrary.")
     (*callbacks* nil)
     (*cmp-env-root* (copy-tree *cmp-env-root*))
     (*cmp-env* nil)
-    (*max-temp* 0)
-    (*temp* 0)
-    (*next-cfun* 0)
-    (*last-label* 0)
     (*load-objects* (make-hash-table :size 128 :test #'equal))
     (*setf-definitions* nil)
     (*make-forms* nil)
@@ -331,8 +264,6 @@ be deleted if they have been opened with LoadLibrary.")
     (*top-level-forms* nil)
     (*compile-time-too* nil)
     (*clines-string-list* '())
-    (*inline-blocks* 0)
-    (*open-c-braces* 0)
     (si::*defun-inline-hook* 'maybe-install-inline-function)
     (*machine* (or *machine* *default-machine*))
     (*optimizable-constants* (make-optimizable-constants *machine*))

src/cmp/cmpmain.lsp

@@ -20,36 +20,11 @@
 
 (in-package "COMPILER")
 
-(defun safe-mkstemp (template)
-  ;; We do several things here. One is to check for success in MKSTEMP,
-  ;; the other one is to ensure that the output of this function _always_
-  ;; carries a file type -- this solves a problem with filesystems where
-  ;; mkstemp may introduce one or more dots in the name causing several
-  ;; functions below to ignore parts of the name. Note that this forces
-  ;; us to have two files per temp: one with and one without extension.
-  (let* ((base (si::mkstemp template)))
-    (when base
-      (let ((output (make-pathname :name
-                                   (concatenate 'string (pathname-name base)
-                                                (or (pathname-type base) ""))
-                                   :type "tmp"
-                                   :defaults base)))
-        (if (and (not (probe-file output)) (si:copy-file base output))
-            (setf base (list (truename output) (truename base)))
-            (progn (delete-file base) (setf base nil)))))
-    (unless base
-      (error "Unable to create temporary file~%~
-        ~AXXXXXX
-Make sure you have enough free space in disk, check permissions or set~%~
-the environment variable TMPDIR to a different value." template))
-    base))
-
-(defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p)
-                              verbose print c-file h-file data-file
-                              system-p load external-format source-truename
-                              source-offset)
-  (declare (ignore verbose print c-file h-file data-file load
-                   external-format source-truename source-offset))
+(defun compile-file-pathname (name &key
+                                     (output-file T)
+                                     (type nil type-supplied-p)
+                                     (system-p nil)
+                              &allow-other-keys)
   (let* ((format '())
          (extension '()))
     (unless type-supplied-p
@@ -74,544 +49,6 @@ the environment variable TMPDIR to a different value." template))
           (t
            (make-pathname :type extension :defaults name)))))
 
-#+msvc
-(defun delete-msvc-generated-files (output-pathname)
-  (loop for i in '("implib" "exp" "ilk" )
-        for full = (make-pathname :type i :defaults output-pathname)
-        for truename = (probe-file full)
-        when truename
-        do (cmp-delete-file truename)))
-
-#+msvc
-(defun embed-manifest-file (o-file &optional (type :dll))
-  (let* ((real-file (probe-file o-file)))
-    (when real-file
-      (let* ((manifest-namestring (concatenate 'string (namestring o-file)
-                                               ".manifest"))
-             (resource-code (ecase type
-                              ((:dll :shared-library :fasl :fas) 2)
-                              ((:program) 1)))
-             (resource-option (format nil "-outputresource:~A;~D"
-                                      (namestring real-file)
-                                      resource-code))
-             (manifest (probe-file manifest-namestring)))
-        (when manifest
-          (safe-run-program "mt"
-                            (list "-nologo"
-                                  "-manifest"
-                                  manifest-namestring
-                                  resource-option))
-          (delete-file manifest))))))
-
-(defun cmp-delete-file (file)
-  (cond ((null *delete-files*))
-        ((ext:getenv "ECL_PRESERVE_FILES"))
-        ((null (probe-file file)))
-        (*debug-compiler*
-         (cmpprogress "~%Postponing deletion of ~A" file)
-         (push file *files-to-be-deleted*))
-        (t
-         (delete-file file))))
-
-(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
-      si::*exit-hooks*)
-
-#-mingw32
-(defmacro fix-for-mingw (directory-namestring)
-  directory-namestring)
-
-#+mingw32
-(defun fix-for-mingw (directory-namestring)
-  (let ((x (string-right-trim '(#\\ #\/) directory-namestring)))
-    (if (zerop (length x)) "/" x)))
-
-(defun get-deprecated-user-ld-flags ()
-  (let ((flags (split-program-options *user-ld-flags*)))
-    (when flags
-      (cmpwarn "The variable ~s is deprecated, please use ~s and ~s instead."
-              '*user-ld-flags* '*user-linker-flags* '*user-linker-libs*))
-    flags))
-
-#+msvc
-(defun linker-cc (o-pathname object-files &key
-                  (type :program)
-                  (ld-flags (split-program-options *ld-flags*))
-                  (ld-libs (split-program-options *ld-libs*)))
-  (safe-run-program
-   *ld*
-   `(,(concatenate 'string "-Fe" (brief-namestring o-pathname))
-     ,@(split-program-options *ld-rpath*)
-     ,@(split-program-options *user-linker-flags*)
-     ,@object-files
-     ,@ld-flags
-     ,@(split-program-options *user-linker-libs*)
-     ,@(get-deprecated-user-ld-flags)
-     ,@ld-libs
-     ,(if (eq type :program)
-          (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib")
-          "")
-     ,(concatenate 'string "/LIBPATH:"
-                   (ecl-library-directory))))
-  (embed-manifest-file o-pathname type)
-  (delete-msvc-generated-files o-pathname))
-
-#-msvc
-(defun linker-cc (o-pathname object-files &key
-                  (type :program)
-                  (ld-flags (split-program-options *ld-flags*))
-                  (ld-libs (split-program-options *ld-libs*)))
-  (declare (ignore type))
-  (safe-run-program
-   *ld*
-   `("-o" ,(brief-namestring o-pathname)
-     ,(concatenate 'string "-L" (fix-for-mingw (ecl-library-directory)))
-     ,@(split-program-options *user-linker-flags*)
-     ,@ld-flags
-     ,@object-files
-     ,@(and *ld-rpath* (list *ld-rpath*))
-     ,@(split-program-options *user-linker-libs*)
-     ,@(get-deprecated-user-ld-flags)
-     ,@ld-libs)))
-
-(defun linker-ar (output-name o-name ld-libs)
-  #-msvc
-  (static-lib-ar (namestring output-name)
-                 (list* (brief-namestring o-name) ld-libs))
-  #+msvc
-  (unwind-protect
-       (progn
-         (with-open-file (f "static_lib.tmp" :direction :output
-                            :if-does-not-exist :create :if-exists :supersede)
-           (format f "/OUT:~A ~A ~{~&\"~A\"~}"
-                   output-name o-name ld-libs))
-         (safe-run-program "link" '("-lib" "-nologo" "@static_lib.tmp")))
-    (when (probe-file "static_lib.tmp")
-      (cmp-delete-file "static_lib.tmp"))))
-
-(defun static-lib-ar (lib object-files)
-  (let ((lib (brief-namestring lib)))
-    (when (probe-file lib)
-      (delete-file lib))
-    (safe-run-program *ar* (list* "cr" lib (mapcar #'brief-namestring object-files)))
-    (safe-run-program *ranlib* (list lib))))
-
-#+dlopen
-(defun shared-cc (o-pathname object-files)
-  (let ((ld-flags (split-program-options *ld-shared-flags*))
-        (ld-libs (split-program-options *ld-libs*)))
-    #+msvc
-    (setf ld-flags
-          (let ((implib (brief-namestring
-                         (compile-file-pathname o-pathname :type :lib))))
-            ;; MSVC linker options are added at the end, after the
-            ;; /link flag, because they are not processed by the
-            ;; compiler, but by the linker
-            (append ld-flags
-                    (list (concatenate 'string "/LIBPATH:"
-                                       (ecl-library-directory))
-                          (concatenate 'string "/IMPLIB:" implib)))))
-    #+mingw32
-    (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*))
-        (ld-libs (split-program-options *ld-libs*)))
-    #+msvc
-    (setf ld-flags
-          (let ((implib (brief-namestring
-                         (compile-file-pathname o-pathname :type :import-library))))
-            ;; MSVC linker options are added at the end, after the
-            ;; /link flag, because they are not processed by the
-            ;; compiler, but by the linker
-            (append ld-flags
-                    (list
-                     ;; Not needed because we use ECL_DLLEXPORT
-                     ;; (concatenate 'string "/EXPORT:" init-name)
-                     (concatenate 'string "/LIBPATH:"
-                                  (ecl-library-directory))
-                     (concatenate 'string "/IMPLIB:" implib)))))
-    #+mingw32
-    (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)))
-
-(defconstant +lisp-program-header+ "
-#include <ecl/ecl.h>
-
-#ifdef __cplusplus
-#define ECL_CPP_TAG \"C\"
-#else
-#define ECL_CPP_TAG
-#endif
-
-~:{     extern ECL_CPP_TAG void ~A(cl_object);~%~}
-
-")
-
-;;
-;; This format string contains the structure of the code that initializes
-;; a program, a library, a module, etc. Basically, it processes a codeblock
-;; just like in a normal compiled file, but then adds all the codeblocks of
-;; its corresponding modules.
-;;
-(defconstant +lisp-program-init+ "
-#ifdef __cplusplus
-extern \"C\"
-#endif
-
-ECL_DLLEXPORT
-void ~A(cl_object cblock)
-{
-        /*
-         * This function is first invoked with a pointer to a Cblock
-         * structure, so that the function initializes it, and then
-         * it is invoked with OBJNULL, to force initialization.
-         */
-        static cl_object Cblock = OBJNULL;
-        if (cblock != OBJNULL) {
-                Cblock = cblock;
-#ifndef ECL_DYNAMIC_VV
-                cblock->cblock.data = NULL;
-#endif
-                cblock->cblock.data_size = 0;
-                return;
-        }
-        Cblock->cblock.data_text = (const cl_object *)\"~A\";
-        ~A
-{
-        /*
-         * At this point Cblock contains the cblock of the parent.
-         * Notice how the modules are linked to the parent forming a
-         * circular chain. This disables the garbage collection of
-         * the library until _ALL_ functions in all modules are unlinked.
-         */
-        cl_object current = OBJNULL, next = Cblock;
-~:{
-        current = ecl_make_codeblock();
-        current->cblock.next = next;
-        next = current;
-        ecl_init_module(current, ~A);
-~}
-        Cblock->cblock.next = current;
-}
-        ~A
-}
-")
-
-(defconstant +lisp-init-wrapper+ "
-#ifdef __cplusplus
-extern \"C\"
-#endif
-
-ECL_DLLEXPORT
-void ~A(cl_object cblock)
-{
-        /* This is a wrapper around the randomized init function name. */
-        ~A(cblock);
-}
-")
-
-(defconstant +lisp-program-main+ "
-extern int
-main(int argc, char **argv)
-{
-        cl_boot(argc, argv);
-        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
-        ~A
-        ecl_init_module(OBJNULL, ~A);
-        ~A
-        } ECL_CATCH_ALL_END;
-        si_exit(0);
-}
-")
-
-(defconstant +lisp-library-main+ "
-extern int
-~A(int argc, char **argv)
-{
-        cl_boot(argc, argv);
-        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
-        ~A
-        ecl_init_module(OBJNULL, ~A);
-        ~A
-        } ECL_CATCH_ALL_END;
-        return 0;
-}
-")
-
-#+:win32
-(defconstant +lisp-program-winmain+ "
-#include <windows.h>
-int
-WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow)
-{
-        char **argv;
-        int argc;
-        ecl_get_commandline_args(&argc, &argv);
-        cl_boot(argc, argv);
-        ECL_CATCH_ALL_BEGIN(ecl_process_env()) {
-        ~A
-        ecl_init_module(OBJNULL, ~A);
-        ~A
-        } ECL_CATCH_ALL_END;
-        si_exit(0);
-        for (int i = 0; i < argc; i++) {
-          LocalFree(argv[i]);
-        }
-        LocalFree(argv);
-}
-")
-
-(defun guess-kind (pathname)
-  "Given a file name, guess whether it is an object file, a library, a program
-or a loadable module."
-  (let ((record (assoc (pathname-type pathname)
-                       '((#.+object-file-extension+ :object)
-                         ("o" :object)
-                         ("obj" :object)
-                         ("c" :c)
-                         (#.+static-library-extension+ :static-library)
-                         ("lib" :static-library)
-                         ("a" :static-library)
-                         (#.+shared-library-extension+ :shared-library)
-                         ("dylib" :shared-library)
-                         ("dll" :shared-library)
-                         ("so" :shared-library)
-                         ("fas" :fasl))
-                       :test #'string-equal)))
-    (if record
-        (second record)
-        (progn
-          (warn "File ~s is of no known file type. Assuming it is an object file."
-                pathname)
-          :object))))
-
-(defun guess-ld-libs (pathname &key (kind (guess-kind pathname)))
-  "Given a file name, return the compiler command line argument to link this file in."
-  (case kind
-    ((:object :c)
-     (brief-namestring pathname))
-    ((:fasl :fas)
-     nil)
-    ((:static-library :lib)
-     (brief-namestring pathname))
-    ((:shared-library :dll)
-     (brief-namestring pathname))
-    ((:program)
-     nil)
-    (otherwise
-     (error "C::BUILDER cannot accept files of kind ~s" kind))))
-
-(defun system-ld-flag (library)
-  "Given a symbol, try to find a library that matches it, either by looking in the
-filesystem or in the database of ASDF modules."
-  (let ((asdf #+asdf (find-package "ASDF"))
-        system)
-    (labels ((asdfsym (x) (find-symbol (string x) asdf))
-             (asdfcall (fun &rest rest) (apply (asdfsym fun) rest))
-             (system-output (system type)
-               (let ((build (make-instance (asdfsym :build-op) :type type)))
-                 (first (asdfcall :output-files build system))))
-             (existing-system-output (system type)
-               (let ((o (system-output system type)))
-                 (and o (setf o (probe-file o)) (namestring o))))
-             (find-archive (system)
-                 (or (existing-system-output system :library)
-                     (existing-system-output system :shared-library)))
-             (fallback ()
-                 (translate-logical-pathname
-                  (merge-pathnames
-                   "SYS:"
-                   (compile-file-pathname (string-downcase library)
-                                          :type :library)))))
-      (or
-       #-ecl-min
-       (and asdf
-            (setf system (asdfcall :find-system library nil))
-            (find-archive system))
-       (fallback)))))
-
-(defun builder (target output-name
-                &key
-                  lisp-files ld-flags ld-libs
-                  (init-name nil)
-                  (main-name nil)
-                  (prologue-code "")
-                  (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T)))
-                  #+:win32 (system :console)
-                &aux
-                  (*suppress-compiler-messages* (or *suppress-compiler-messages*
-                                                    (not *compile-verbose*)))
-                  (target (normalize-build-target-name target))
-                  (output-name (if (or (symbolp output-name) (stringp output-name))
-                                   (compile-file-pathname output-name :type target)
-                                   output-name))
-                  ;; wrap-name is the init function name defined by a programmer
-                  (wrap-name init-name))
-  ;; init-name should always be unique
-  (setf init-name (compute-init-name output-name :kind target))
-  (cond ((null wrap-name) nil)
-        ((equal init-name wrap-name)        ; fixup for ASDF
-         (cmpwarn "Parameter `init-name' is the same as the result of an internal function `compute-init-name'. Ignoring.")
-         (setf wrap-name nil))
-        ((null (member target '(:static-library :shared-library)))
-         (cmpwarn "Supplying `init-name' is valid only for libraries. Ignoring.")))
-  (unless main-name
-    (setf main-name (compute-init-name output-name :kind target :prefix "main_")))
-
-
-  ;;
-  ;; The epilogue-code can be either a string made of C code, or a
-  ;; lisp form.  In the latter case we add some additional C code to
-  ;; clean up, and the lisp form is stored in a text representation,
-  ;; to avoid using the compiler.
-  ;;
-  (cond ((null epilogue-code)
-         (setf epilogue-code ""))
-        ((stringp epilogue-code)
-         nil)
-        (t
-         (with-standard-io-syntax
-           (setq epilogue-code
-                 (with-output-to-string (stream)
-                   (princ "{ const char *lisp_code = " stream)
-                   (wt-filtered-data (write-to-string epilogue-code) stream)
-                   (princ ";
-cl_object output;
-si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
-output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
-}" stream)
-                   )))))
-  (cond ((null prologue-code)
-         (setf prologue-code ""))
-        ((stringp prologue-code)
-         )
-        (t
-         (with-standard-io-syntax
-           (setq prologue-code
-                 (with-output-to-string (stream)
-                   (princ "{ const char *lisp_code = " stream)
-                   (wt-filtered-data (write-to-string prologue-code) stream)
-                   (princ ";
-cl_object output;
-si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7));
-output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
-}" stream)
-                   )))))
-  ;;
-  ;; When a module is built out of several object files, we have to
-  ;; create an additional object file that initializes those ones.
-  ;; This routine is responsible for creating this file.
-  ;;
-  ;; To avoid name clashes, this object file will have a temporary
-  ;; file name (tmp-name).
-  ;;
-  (let* ((tmp-names (safe-mkstemp #P"TMP:ECLINIT"))
-         (tmp-name (first tmp-names))
-         (c-name (brief-namestring
-                  (compile-file-pathname tmp-name :type :c)))
-         (o-name (brief-namestring
-                  (compile-file-pathname tmp-name :type :object)))
-         submodules
-         c-file)
-    (dolist (item (reverse lisp-files))
-      (let* ((path (etypecase item
-                     (symbol (system-ld-flag item))
-                     (pathname item)
-                     (string (parse-namestring item))))
-             (kind (guess-kind path)))
-
-        ;; Shared and static libraries may be linked in a program or
-        ;; fasl, but if we try to create a `static-library' from two
-        ;; static libraries we will end with broken binary because
-        ;; `ar' works fine only with object files. See #274.
-        (unless (member kind `(,@(unless (eql target :static-library)
-                                   '(:shared-library :static-library))
-                                 :object :c))
-          (error "C::BUILDER does not accept a file ~s of kind ~s for target ~s" item kind target))
-        (let ((init-fn (guess-init-name path kind))
-              (guessed-libs (guess-ld-libs path)))
-          ;; We should give a warning that we cannot link this module in
-          (when guessed-libs
-            (push guessed-libs ld-libs))
-          (when init-fn
-            (push (list init-fn path) submodules)))))
-    (setq c-file (open c-name :direction :output :external-format :default))
-    (format c-file +lisp-program-header+ submodules)
-
-    (let ((init-tag (init-name-tag init-name :kind target)))
-      (ecase target
-        (:program
-         (format c-file +lisp-program-init+ init-name init-tag "" submodules "")
-         ;; 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+
-                 prologue-code init-name epilogue-code)
-         (close c-file)
-         (compiler-cc c-name o-name)
-         (linker-cc output-name (append ld-flags (list (namestring o-name))
-                                        ld-libs)))
-        (:static-library
-         (format c-file +lisp-program-init+
-                 init-name init-tag prologue-code submodules epilogue-code)
-         (when wrap-name
-           (format c-file +lisp-init-wrapper+ wrap-name init-name))
-         (format c-file +lisp-library-main+
-                 main-name prologue-code init-name epilogue-code)
-         (close c-file)
-         (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)
-         (when wrap-name
-           (format c-file +lisp-init-wrapper+ wrap-name init-name))
-         (format c-file +lisp-library-main+
-                 main-name prologue-code init-name epilogue-code)
-         (close c-file)
-         (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)
-         ;; we don't need wrapper in the fasl, we scan for init function name
-         ;(format c-file +lisp-init-wrapper+ wrap-name init-name)
-         (close c-file)
-         (compiler-cc c-name o-name)
-         (bundle-cc output-name init-name (append ld-flags (list o-name)
-                                                  ld-libs))))
-      (mapc 'cmp-delete-file tmp-names)
-      (cmp-delete-file c-name)
-      (cmp-delete-file o-name)
-      output-name)))
-
-(defun build-fasl (&rest args)
-  (apply #'builder :fasl args))
-
-(defun build-program (&rest args)
-  (apply #'builder :program args))
-
-(defun build-static-library (&rest args)
-  (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))
-
 (defun compile-file
     (input-pathname &rest args
      &key
@@ -638,15 +75,15 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
        (ext:*source-location* (cons source-truename 0))
        (*suppress-compiler-messages* (or *suppress-compiler-messages*
                                          (not *compile-verbose*))))
-  (declare (ignore output-file)
-           (notinline compiler-cc))
+  (declare (notinline compiler-cc)
+           (ignorable c-file h-file data-file))
   "Compiles the file specified by INPUT-PATHNAME and generates a fasl file
 specified by OUTPUT-FILE.  If the filetype is not specified in INPUT-PATHNAME,
 then \".lsp\" is used as the default file type for the source file.  LOAD
 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"
+compiled successfully, returns the pathname of the compiled file."
   #-dlopen
   (unless system-p
     (format t "~%;;;~
@@ -658,7 +95,7 @@ compiled successfully, returns the pathname of the compiled file"
     (if (pathname-type input-pathname)
         (error 'file-error :pathname input-pathname)
         (dolist (ext '("lsp" "LSP" "lisp" "LISP")
-                 (error 'file-error :pathname input-pathname))
+                     (error 'file-error :pathname input-pathname))
           (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname))
           (when (probe-file *compile-file-pathname*)
             (return)))))
@@ -668,50 +105,24 @@ compiled successfully, returns the pathname of the compiled file"
   (let* ((input-file (truename *compile-file-pathname*))
          (*compile-file-truename* input-file)
          (*compiler-in-use* *compiler-in-use*)
-         (*load-time-values* nil) ;; Load time values are compiled
-         (output-file (apply #'compile-file-pathname input-file args))
-         (true-output-file nil) ;; Will be set at the end
-         (c-pathname (apply #'compile-file-pathname output-file :output-file c-file
-                                                                :type :c args))
-         (h-pathname (apply #'compile-file-pathname output-file :output-file h-file
-                                                                :type :h args))
-         (data-pathname (apply #'compile-file-pathname output-file
-                               :output-file data-file :type :data args))
-         (compiler-conditions nil)
-         (to-delete (nconc (unless c-file (list c-pathname))
-                           (unless h-file (list h-pathname))
-                           (unless data-file (list data-pathname))))
-         (init-name (compute-init-name output-file
-                                       :kind (if system-p :object :fasl))))
+         (*load-time-values* nil)       ; Load time values are compiled.
+         (output-file (apply #'compile-file-pathname input-file :output-file output-file args))
+         (true-output-file nil)         ; Will be set at the end.
+         (compiler-conditions nil))
     (with-compiler-env (compiler-conditions)
       (print-compiler-info)
       (when (probe-file "./cmpinit.lsp")
         (load "./cmpinit.lsp" :verbose *compile-verbose*))
-      (with-open-file (stream *compile-file-pathname*
-                              :external-format external-format)
+      (with-open-file (stream *compile-file-pathname* :external-format external-format)
         (unless source-truename
           (setf (car ext:*source-location*) *compile-file-pathname*))
         (compiler-pass1 stream source-offset))
       (compiler-pass/propagate-types)
-      (compiler-pass2 c-pathname h-pathname data-pathname init-name
-                      :input-designator (namestring input-pathname))
-      (data-c-dump data-pathname)
-      (let ((o-pathname (if system-p
-                            output-file
-                            (compile-file-pathname output-file :type :object))))
-        (compiler-cc c-pathname o-pathname)
-        #+dlopen
-        (unless system-p
-          (push o-pathname to-delete)
-          (bundle-cc (brief-namestring output-file)
-                     init-name
-                     (list (brief-namestring o-pathname)))))
+      (apply #'compiler-pass/assemble-cxx input-file output-file args)
       (if (setf true-output-file (probe-file output-file))
-          (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%"
-                       (namestring input-pathname))
+          (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname))
           (cmperr "The C compiler failed to compile the intermediate file."))
-      (mapc #'cmp-delete-file to-delete)
-      (when (and load true-output-file (not system-p))
+      (when load
         (load true-output-file :verbose *compile-verbose*))) ; with-compiler-env
     (compiler-output-values true-output-file compiler-conditions)))
 
@@ -737,17 +148,17 @@ compiled successfully, returns the pathname of the compiled file"
 
 #+dlopen
 (defun compile (name &optional (def nil supplied-p)
-                      &aux form data-pathname
-                      (lexenv nil)
-                      (*suppress-compiler-messages* (or *suppress-compiler-messages*
-                                                        (not *compile-verbose*)))
-                      (*compiler-in-use* *compiler-in-use*)
-                      (*standard-output* *standard-output*)
-                      (*error-output* *error-output*)
-                      (*package* *package*)
-                      (*compile-print* nil)
-                      (*print-pretty* nil)
-                      (si:*compiler-constants* t))
+                &aux form data-pathname
+                  (lexenv nil)
+                  (*suppress-compiler-messages* (or *suppress-compiler-messages*
+                                                    (not *compile-verbose*)))
+                  (*compiler-in-use* *compiler-in-use*)
+                  (*standard-output* *standard-output*)
+                  (*error-output* *error-output*)
+                  (*package* *package*)
+                  (*compile-print* nil)
+                  (*print-pretty* nil)
+                  (si:*compiler-constants* t))
   "Args: (name &optional definition)
 
 If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function.
@@ -760,7 +171,8 @@ If NAME is NIL, then the compiled function is not installed but is simply
 returned as the value of COMPILE.  In any case, COMPILE creates temporary
 files, whose filenames begin with \"gazonk\", which are automatically deleted
 after compilation."
-  (unless (si:valid-function-name-p name) (error "~s is not a valid function name." name))
+  (unless (si:valid-function-name-p name)
+    (error "~s is not a valid function name." name))
 
   (cond ((and supplied-p def)
          (when (functionp def)
@@ -788,12 +200,7 @@ after compilation."
 
   (let* ((*load-time-values* 'values) ;; Only the value is kept
          (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*))))
-         (data-pathname (first tmp-names))
-         (c-pathname (compile-file-pathname data-pathname :type :c))
-         (h-pathname (compile-file-pathname data-pathname :type :h))
-         (o-pathname (compile-file-pathname data-pathname :type :object))
-         (so-pathname (compile-file-pathname data-pathname))
-         (init-name (compute-init-name so-pathname :kind :fasl))
+         (so-pathname (compile-file-pathname (first tmp-names)))
          (compiler-conditions nil)
          (*permanent-data* t)        ; needed for literal objects in closures
          (*cmp-env-root* *cmp-env-root*))
@@ -803,22 +210,8 @@ after compilation."
       (compiler-pass1 form)
       (compiler-pass/propagate-types)
       (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
-        (compiler-pass2 c-pathname h-pathname data-pathname init-name
-                        :input-designator (let* ((*print-circle* t)
-                                                 (*print-length* 8)
-                                                 (*print-depth* 4))
-                                            (format nil "~W" def))))
-      (data-c-dump data-pathname)
-
-      (compiler-cc c-pathname o-pathname)
-      (bundle-cc (brief-namestring so-pathname)
-                 init-name
-                 (list (brief-namestring o-pathname)))
-      (cmp-delete-file c-pathname)
-      (cmp-delete-file h-pathname)
-      (cmp-delete-file o-pathname)
+        (compiler-pass/assemble-cxx nil so-pathname))
       (mapc 'cmp-delete-file tmp-names)
-
       (cond ((probe-file so-pathname)
              (load so-pathname :verbose nil)
              (cmp-delete-file so-pathname))
@@ -827,10 +220,6 @@ after compilation."
              (set 'GAZONK nil)
              (cmperr "The C compiler failed to compile the intermediate code for ~s." name)))
       ) ; with-compiler-env
-    (cmp-delete-file c-pathname)
-    (cmp-delete-file h-pathname)
-    (cmp-delete-file so-pathname)
-    (mapc 'cmp-delete-file tmp-names)
     (let ((output (or name (and (boundp 'GAZONK) (symbol-value 'GAZONK))
                       #'(lambda (&rest x)
                           (declare (ignore x))
@@ -838,10 +227,10 @@ after compilation."
                           ;; function which does nothing but resignal
                           ;; the compiler errors we got
                           (loop for c in compiler-conditions
-                             if (typep c 'compiler-error)
-                             do (apply #'si::simple-program-error
-                                       (simple-condition-format-control c)
-                                       (simple-condition-format-arguments c)))))))
+                                if (typep c 'compiler-error)
+                                  do (apply #'si::simple-program-error
+                                            (simple-condition-format-control c)
+                                            (simple-condition-format-arguments c)))))))
       ;; By unsetting GAZONK we avoid spurious references to the
       ;; loaded code.
       (set 'GAZONK nil)
@@ -850,9 +239,9 @@ after compilation."
 
 (defun disassemble (thing &key (h-file nil) (data-file nil)
                     &aux lexenv disassembled-form
-                    (*compiler-in-use* *compiler-in-use*)
-                    (*print-pretty* nil))
-"Compiles the form specified by THING and prints the intermediate C language
+                      (*compiler-in-use* *compiler-in-use*)
+                      (*print-pretty* nil))
+  "Compiles the form specified by THING and prints the intermediate C language
 code for that form.  But does not install the result of compilation.  If THING
 is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd.  If THING is
 a symbol that names a function not yet compiled, the function definition is
@@ -860,24 +249,24 @@ disassembled.  If THING is a lambda expression, it is disassembled as a
 function definition.  Otherwise, THING itself is disassembled as a top-level
 form.  H-FILE and DATA-FILE specify intermediate files to build a fasl file
 from the C language code.  NIL means \"do not create the file\"."
-  (when (si::valid-function-name-p thing)
+  (when (si:valid-function-name-p thing)
     (setq thing (fdefinition thing)))
   (when (and (functionp thing) (function-lambda-expression thing))
     (multiple-value-setq (thing lexenv)
       (function-lambda-expression thing))
     (when (eq lexenv t)
-      (warn "DISASSEMBLE can not disassemble C closures")
+      (warn "DISASSEMBLE can not disassemble C closures.")
       (return-from disassemble nil)))
   (cond ((null thing))
         ((functionp thing)
-         (unless (si::bc-disassemble thing)
+         (unless (si:bc-disassemble thing)
            (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing)
            (return-from disassemble nil)))
         ((atom thing)
          (error 'simple-type-error
                 :datum thing
                 :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
-                :format-control "DISASSEMBLE cannot accept ~A"
+                :format-control "DISASSEMBLE cannot accept ~A."
                 :format-arguments (list thing)))
         ((eq (car thing) 'LAMBDA)
          (setq disassembled-form `(defun gazonk ,@(cdr thing))))
@@ -887,7 +276,7 @@ from the C language code.  NIL means \"do not create the file\"."
          (error 'simple-type-error
                 :datum thing
                 :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
-                :format-control "DISASSEMBLE cannot accept ~A"
+                :format-control "DISASSEMBLE cannot accept ~A."
                 :format-arguments (list thing))))
 
   (let* ((null-stream (make-broadcast-stream))
@@ -925,8 +314,8 @@ from the C language code.  NIL means \"do not create the file\"."
   (if (streamp object)
       (do* ((eof '(NIL))
             (*compile-file-position* 0 (file-position object))
-            (form (si::read-object-or-ignore object eof)
-                  (si::read-object-or-ignore object eof)))
+            (form (si:read-object-or-ignore object eof)
+                  (si:read-object-or-ignore object eof)))
            ((eq form eof))
         (when form
           (setf (cdr ext:*source-location*)
@@ -941,78 +330,7 @@ from the C language code.  NIL means \"do not create the file\"."
   (when *do-type-propagation*
     (setq *compiler-phase* 'p1propagate)
     (dolist (form *top-level-forms*)
-      (p1propagate form nil))
-    (dolist (fun *local-funs*)
-      (p1propagate (fun-lambda fun) nil))))
-
-(defun compiler-pass2 (c-pathname h-pathname data-pathname init-name
-                       &key input-designator)
-
-  (setq *compiler-phase* 't2)
-  (with-open-file (*compiler-output1* c-pathname :direction :output
-                                                 :if-does-not-exist :create
-                                                 :if-exists :supersede)
-    (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
-    #-ecl-min
-    (multiple-value-bind (second minute hour day month year)
-        (get-decoded-time)
-      (declare (ignore second))
-      (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
-      (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
-    (wt-comment-nl "Source: ~A" input-designator)
-    (with-open-file (*compiler-output2* h-pathname :direction :output
-                                                   :if-does-not-exist :create
-                                                   :if-exists :supersede)
-      (wt-nl1 "#include " *cmpinclude*)
-      (ctop-write init-name h-pathname data-pathname)
-      (terpri *compiler-output1*)
-      (terpri *compiler-output2*))))
-
-(defun ecl-include-directory ()
-  "Finds the directory in which the header files were installed."
-  (cond ((and *ecl-include-directory*
-              (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*)))
-         *ecl-include-directory*)
-        ((probe-file "SYS:ecl;config.h")
-         (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:"))))
-        ((error "Unable to find include directory"))))
-
-(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)
-                                           *ecl-library-directory*)))
-         *ecl-library-directory*)
-        ((probe-file "SYS:BUILD-STAMP")
-         (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:"))))
-        ((error "Unable to find library directory"))))
-
-(defun compiler-cc (c-pathname o-pathname)
-  (safe-run-program
-   *cc*
-   `("-I."
-     ,@(precompiled-header-flags)
-     ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory)))
-     ,@(split-program-options *cc-flags*)
-     ,@(and (>= (cmp-env-optimization 'speed) 2)
-            (split-program-options *cc-optimize*))
-     "-c"
-     ,(brief-namestring c-pathname)
-     #-msvc
-     ,@(list "-o" (brief-namestring o-pathname))
-     #+msvc
-     ,(concatenate 'string "-Fo" (brief-namestring o-pathname))
-     ,@(split-program-options *user-cc-flags*))))
-; Since the SUN4 assembler loops with big files, you might want to use this:
-;   (format nil
-;          "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A"
-;          *cc* (>= *speed* 2)
-;          *include-directory*
-;          (namestring c-pathname)
-;          (namestring o-pathname)
-;          (namestring s-pathname))
+      (p1propagate form))))
 
 (defun print-compiler-info ()
   (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%"
@@ -1022,78 +340,6 @@ from the C language code.  NIL means \"do not create the file\"."
   (declare (ignore options))
   `(progn ,@body))
 
-(defun need-to-dump-precompiled-header ()
-  (let* ((config *precompiled-header-cc-config*)
-         (need-to-dump (or (null config)
-                           (not (eq (svref config 0) *cc*))
-                           (not (eq (svref config 1) (ecl-include-directory)))
-                           (not (eq (svref config 2) *cc-flags*))
-                           (not (eq (svref config 3) *cc-optimize*))
-                           (not (eq (svref config 4) *user-cc-flags*)))))
-    (when need-to-dump
-      (setf *precompiled-header-cc-config*
-            (vector *cc* (ecl-include-directory) *cc-flags*
-                    *cc-optimize* *user-cc-flags*)))
-    need-to-dump))
-
-(defun precompiled-header-flags ()
-  (when *use-precompiled-headers*
-    (when (need-to-dump-precompiled-header)
-      (handler-case
-          (dump-precompiled-header)
-        (error (err)
-          (setf *use-precompiled-headers* nil
-                *precompiled-header-flags* nil
-                *precompiled-header-cc-config* nil)
-          (cmpnote "Disabling precompiled header files due to error:~%  ~A" err))))
-    *precompiled-header-flags*))
-
-#+msvc
-(defun dump-precompiled-header ()
-  ;; The way precompiled headers work on msvc is not compatible with
-  ;; what we want to use them for. The msvc compiler creates a
-  ;; precompiled header file out of ordinary source files by
-  ;; processing them up to a certain point at which all needed headers
-  ;; are included. This creates both a precompiled header and a object
-  ;; file. The object file created by this compilation must be
-  ;; included in all binaries which are linked together from other
-  ;; source files compiled using the precompiled header. Thus, we
-  ;; would need to include the first object file created in a session
-  ;; in all further object files if we wanted to support that.
-  (error "Precompiled headers are not supported for msvc."))
-
-#-msvc
-(defun dump-precompiled-header ()
-  (let* ((input-file (make-pathname
-                      :directory (append (pathname-directory (ecl-include-directory))
-                                         '("ecl"))
-                      :defaults (ecl-include-directory)
-                      :name "ecl-cmp"
-                      :type "h"))
-         (output-dir (merge-pathnames
-                      (format nil "ecl-include~4,'0x/" (random #xffff))
-                      (translate-logical-pathname "TMP:")))
-         (output-file (compile-file-pathname
-                       (make-pathname :name "ecl-cmp" :defaults output-dir)
-                       :type :precompiled-header)))
-        (ensure-directories-exist output-dir)
-        (push output-dir *files-to-be-deleted*)
-        (safe-run-program
-         *cc*
-         `("-x" "c-header"
-                ,(fix-for-mingw (namestring input-file))
-                ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory)))
-                ,@(split-program-options *cc-flags*)
-                ,@(split-program-options *cc-optimize*)
-                "-o"
-                ,(fix-for-mingw (namestring output-file))
-                ,@(split-program-options *user-cc-flags*)))
-        (push output-file *files-to-be-deleted*)
-        (setf *precompiled-header-flags*
-              (list (concatenate 'string "-I" (namestring output-dir))
-                    "-include"
-                    (concatenate 'string (namestring output-dir) "ecl-cmp.h")))))
-
 (ext:package-lock "CL" t)
 
 (setf *features* (delete :ecl-bytecmp *features*))
@@ -1103,12 +349,12 @@ from the C language code.  NIL means \"do not create the file\"."
        (compile-file #'compile-file)
        (compile-file-pathname #'compile-file-pathname))
   (defun ext:install-c-compiler ()
-    (ext::package-lock (find-package :cl) nil)
+    (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)
-    (ext::package-lock (find-package :cl) t)))
+    (ext:package-lock (find-package :cl) t)))
 
 (provide 'cmp)

src/cmp/cmpnum.lsp

@@ -1,322 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
-;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
-
-;;;;
-;;;; CMPNUM -- Optimizer for numerical expressions.
-
-;;;;  Copyright (c) 2005, Juan Jose Garcia Ripoll
-;;;;
-;;;;    ECoLisp is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-
-(in-package "COMPILER")
-
-;;----------------------------------------------------------------------
-;; We transform BOOLE into the individual operations, which have
-;; inliners
-;;
-
-(define-compiler-macro boole (&whole form op-code op1 op2)
-  (or (and (constantp op-code *cmp-env*)
-           (case (ext:constant-form-value op-code *cmp-env*)
-             (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0))
-             (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1))
-             (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
-             (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
-             (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2)))
-             (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2)))
-             (#. boole-and `(logand ,op1 ,op2))
-             (#. boole-ior `(logior ,op1 ,op2))
-             (#. boole-xor `(logxor ,op1 ,op2))
-             (#. boole-eqv `(logeqv ,op1 ,op2))
-             (#. boole-nand `(lognand ,op1 ,op2))
-             (#. boole-nor `(lognor ,op1 ,op2))
-             (#. boole-andc1 `(logandc1 ,op1 ,op2))
-             (#. boole-andc2 `(logandc2 ,op1 ,op2))
-             (#. boole-orc1 `(logorc1 ,op1 ,op2))
-             (#. boole-orc2 `(logorc2 ,op1 ,op2))))
-      form))
-
-(defun simplify-arithmetic (operator args whole)
-  (if (every #'numberp args)
-      (apply operator args)
-      (let ((l (length args)))
-        (cond ((> l 2)
-               (simplify-arithmetic
-                operator
-                (list* (simplify-arithmetic operator
-                                            (list (first args) (second args))
-                                            nil)
-                       (cddr args))
-                nil))
-              ((= l 2)
-               (or whole (list* operator args)))
-              ((= l 1)
-               (if (or (eq operator '*) (eq operator '+))
-                   (first args)
-                   (or whole (list* operator args))))
-              ((eq operator '*)
-               1)
-              ((eq operator '+)
-               0)
-              (t
-               (error 'simple-program-error
-                      :format-error "Wrong number of arguments for operator ~a in ~a"
-                      :format-arguments (list operator (or whole
-                                                           (list* operator args)))))))))
-
-(define-compiler-macro * (&whole all &rest args)
-  (simplify-arithmetic '* args all))
-
-(define-compiler-macro + (&whole all &rest args)
-  (simplify-arithmetic '+ args all))
-
-(define-compiler-macro / (&whole all &rest args)
-  (simplify-arithmetic '/ args all))
-
-(define-compiler-macro - (&whole all &rest args)
-  (simplify-arithmetic '- args all))
-
-;;;
-;;; The following are type propagators for arithmetic operations. Note
-;;; that some of they have become binary operators.
-;;;
-
-(defun maximum-number-type (type1 type2 &key only-real integer-result)
-  ;; Computes the output type of an operation between number types T1
-  ;; and T2 using the rules of floating point contagion. It returns
-  ;; the type of the result, and the types of T1 and T2, if they
-  ;; represent known types, or NUMBER, in other cases.
-  (let ((t1-eq nil)
-        (t2-eq nil)
-        (t1 type1)
-        (t2 type2)
-        (output nil)
-        (complex-t1 nil)
-        (complex-t2 nil)
-        (default (if only-real 'REAL 'NUMBER))
-        (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
-                        DOUBLE-FLOAT LONG-FLOAT FLOAT REAL)))
-    (when (and (consp t1) (eq (first t1) 'COMPLEX))
-      (setf t1 (second t1) complex-t1 t))
-    (when (and (consp t2) (eq (first t2) 'COMPLEX))
-      (setf t2 (second t2) complex-t2 t))
-    (when (and only-real (or complex-t1 complex-t2))
-      (return-from maximum-number-type (values default default default)))
-    (loop for i across number-types
-          do (when (and (null t1-eq) (type>= i t1))
-               (when (equalp t1 t2)
-                 (setf t2-eq i))
-               (setf t1-eq i output i))
-             (when (and (null t2-eq) (type>= i t2))
-               (setf t2-eq i output i)))
-    (unless (and t1-eq t2-eq output)
-      (setf output default))
-    (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER)))
-      (setf output integer-result))
-    (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER)))
-      (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output))))
-    (values output (if t1-eq type1 default) (if t2-eq type2 default))))
-
-(defun ensure-number-type (general-type &key integer-result)
-  (maximum-number-type general-type general-type :integer-result integer-result))
-
-(defun ensure-nonrational-type (general-type)
-  (maximum-number-type general-type 'single-float))
-
-(defun ensure-real-type (general-type)
-  (maximum-number-type general-type 'integer :only-real t))
-
-(defun arithmetic-propagator (op1-type others integer-result)
-  ;; Propagates types for an associative operator (we do not care which one).
-  ;; We collect either the types of the arguments or 'NUMBER, as a generic
-  ;; expected type. The output type is computed using the rules of floating
-  ;; point contagion, with the exception that an operation between two
-  ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else)
-  (multiple-value-bind (result-type op1-type)
-      (ensure-number-type op1-type :integer-result integer-result)
-    (loop with arg-types = (list op1-type)
-       for x in others
-       for op2-type = x
-       do (progn
-            (multiple-value-setq (result-type op1-type op2-type)
-              (maximum-number-type result-type op2-type :integer-result integer-result))
-            (setf arg-types (cons op2-type arg-types)))
-       finally (return (values (nreverse arg-types) result-type)))))
-
-(def-type-propagator * (fname op1 &rest others)
-  (arithmetic-propagator op1 others 'integer))
-
-(copy-type-propagator '* '(+ -))
-
-(def-type-propagator / (fname op1 &rest others)
-  (arithmetic-propagator op1 others 'rational))
-
-(defun most-generic-number-rep-type (r1 r2)
-  (let* ((r1 (rep-type-record r1))
-         (r2 (rep-type-record r2)))
-    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
-                       r2
-                       r1))))
-
-(defun inline-binop (expected-type arg1 arg2 consing non-consing)
-  (let ((arg1-type (inlined-arg-type arg1))
-        (arg2-type (inlined-arg-type arg2)))
-    (if (and (policy-assume-right-type)
-             (c-number-type-p expected-type)
-             (c-number-type-p arg1-type)
-             (c-number-type-p arg2-type))
-        ;; The input arguments have to be coerced to a C
-        ;; type that fits the output, to avoid overflow which
-        ;; would happen if we used say, long c = (int)a * (int)b
-        ;; as the output would be an integer, not a long.
-        (let* ((arg1-rep (lisp-type->rep-type arg1-type))
-               (arg2-rep (lisp-type->rep-type arg2-type))
-               (out-rep (lisp-type->rep-type expected-type))
-               (max-rep (most-generic-number-rep-type
-                         (most-generic-number-rep-type
-                          arg1-rep arg2-rep) out-rep))
-               (max-name (rep-type->c-name max-rep)))
-          (produce-inline-loc
-           (list arg1 arg2)
-           (list arg1-rep arg2-rep)
-           (list max-rep)
-           (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)"
-                   (unless (eq arg1-rep max-rep) max-name)
-                   non-consing
-                   (unless (eq arg2-rep max-rep) max-name))
-           nil t))
-        (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
-                            consing nil t))))
-
-(defun inline-arith-unop (expected-type arg1 consing non-consing)
-  (let ((arg1-type (inlined-arg-type arg1)))
-    (if (and (policy-assume-right-type)
-             (c-number-type-p expected-type)
-             (c-number-type-p arg1-type))
-        (produce-inline-loc (list arg1)
-                            (list (lisp-type->rep-type arg1-type))
-                            (list (lisp-type->rep-type expected-type))
-                            non-consing nil t)
-        (produce-inline-loc (list arg1) '(:object :object) '(:object)
-                            consing nil t))))
-
-(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
-  (when (null arguments)
-    (return '(fixnum-value 0)))
-  (setf arg1 (pop arguments))
-  (when (null arguments)
-    (return (inlined-arg-loc arg1)))
-  (loop for arg2 = (pop arguments)
-     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
-     do (if arguments
-            (setf arg1 (save-inline-loc result))
-            (return result))))
-
-(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
-  (when (null arguments)
-    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
-  (loop for arg2 = (pop arguments)
-     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
-     do (if arguments
-            (setf arg1 (save-inline-loc result))
-            (return result))))
-
-(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
-  (when (null arguments)
-    (return '(fixnum-value 1)))
-  (setf arg1 (pop arguments))
-  (when (null arguments)
-    (return (inlined-arg-loc arg1)))
-  (loop for arg2 = (pop arguments)
-     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
-     do (if arguments
-            (setf arg1 (save-inline-loc result))
-            (return result))))
-
-(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
-  (when (null arguments)
-    (return (inline-arith-unop return-type arg1
-                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
-  (loop for arg2 = (pop arguments)
-     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
-     do (if arguments
-            (setf arg1 (save-inline-loc result))
-            (return result))))
-
-;;;
-;;; SPECIAL FUNCTIONS
-;;;
-
-(def-type-propagator cos (fname op1-type)
-  (multiple-value-bind (output-type op1-type)
-      (ensure-nonrational-type op1-type)
-    (values (list op1-type) output-type)))
-
-(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp))
-
-(def-type-propagator acos (fname op1-type)
-  (multiple-value-bind (output-type op1-type)
-      (ensure-nonrational-type op1-type)
-    (declare (ignore output-type))
-    (values (list op1-type) 'NUMBER)))
-
-(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p))
-  (multiple-value-bind (float-t1 t1)
-      (ensure-nonrational-type op1-type)
-    (if op2-p
-        (multiple-value-bind (result t1 t2)
-            (maximum-number-type t1 op2-type :only-real t)
-          (values (list t1 t2) result))
-        (values (list t1) float-t1))))
-
-(def-type-propagator expt (fname base exponent)
-  ;; Rules:
-  ;;    (expt fixnum integer) -> integer
-  ;;    (expt number-type integer) -> number-type
-  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
-  ;;
-  (let ((exponent (ensure-real-type exponent)))
-    (values (list base exponent)
-            (cond ((eql exponent 'integer)
-                   (if (subtypep base 'fixnum)
-                       'integer
-                       base))
-                  ((type>= '(real 0 *) base)
-                   (let* ((exponent (ensure-nonrational-type exponent)))
-                     (maximum-number-type exponent base)))
-                  (t
-                   'number)))))
-
-(def-type-propagator abs (fname arg)
-  (multiple-value-bind (output arg)
-      (ensure-number-type arg)
-    (values (list arg)
-            (or (cdr (assoc output
-                            '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM))
-                              (INTEGER . (INTEGER 0 *))
-                              (RATIONAL . (RATIONAL 0 *))
-                              (SHORT-FLOAT . (SHORT-FLOAT 0 *))
-                              (SINGLE-FLOAT . (SINGLE-FLOAT 0 *))
-                              (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *))
-                              (LONG-FLOAT . (LONG-FLOAT 0 *))
-                              (REAL . (REAL 0 *))
-                              (NUMBER . (REAL 0 *)))))
-                output))))
-
-(def-type-propagator sqrt (fname arg)
-  (multiple-value-bind (output arg)
-      (ensure-nonrational-type arg)
-    (values (list arg)
-            (if (type>= '(REAL 0 *) arg) output 'NUMBER))))
-
-(def-type-propagator isqrt (fname arg)
-  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
-      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
-              '(integer 0 #.MOST-POSITIVE-FIXNUM))
-      (values '((integer 0 *)) '(integer 0 *))))
-

src/cmp/cmpopt-num.lsp

@@ -1,21 +1,40 @@
 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
 ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
 
+;;;;  Copyright (c) 2010, Juan Jose Garcia Ripoll
 ;;;;
-;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
-;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-;;;;
-;;;;  CMPOPT-BITS  -- Optimize operations acting on bits
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
 
+;;;; Optimizer for numerical expressions.
+
 (in-package "COMPILER")
 
+;;;
+;;; We transform BOOLE into the individual operations, which have inliners
+;;;
+
+(define-compiler-macro boole (&whole form op-code op1 op2)
+  (or (and (constantp op-code *cmp-env*)
+           (case (ext:constant-form-value op-code *cmp-env*)
+             (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0))
+             (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1))
+             (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
+             (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
+             (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2)))
+             (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2)))
+             (#. boole-and `(logand ,op1 ,op2))
+             (#. boole-ior `(logior ,op1 ,op2))
+             (#. boole-xor `(logxor ,op1 ,op2))
+             (#. boole-eqv `(logeqv ,op1 ,op2))
+             (#. boole-nand `(lognand ,op1 ,op2))
+             (#. boole-nor `(lognor ,op1 ,op2))
+             (#. boole-andc1 `(logandc1 ,op1 ,op2))
+             (#. boole-andc2 `(logandc2 ,op1 ,op2))
+             (#. boole-orc1 `(logorc1 ,op1 ,op2))
+             (#. boole-orc2 `(logorc2 ,op1 ,op2))))
+      form))
+
 ;;;
 ;;; LDB
 ;;; Look for inline expansion of LDB1 in sysfun.lsp
@@ -123,9 +142,6 @@
 
 ;;;
 ;;; ASH
-;;; Bit fiddling. It is a bit tricky because C does not allow
-;;; shifts in << or >> which exceed the integer size. In those
-;;; cases the compiler may do whatever it wants (and gcc does!)
 ;;;
 
 (define-compiler-macro ash (&whole whole argument shift)
@@ -140,39 +156,42 @@
         (t
          whole)))
 
-(define-c-inliner shift (return-type argument orig-shift)
-  (let* ((arg-type (inlined-arg-type argument))
-         (arg-c-type (lisp-type->rep-type arg-type))
-         (return-c-type (lisp-type->rep-type return-type))
-         (shift (loc-immediate-value (inlined-arg-loc orig-shift))))
-    (if (or (not (c-integer-rep-type-p arg-c-type))
-            (not (c-integer-rep-type-p return-c-type)))
-        (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object)
-                            "ecl_ash(#0,#1)" nil t)
-        (let* ((arg-bits (c-integer-rep-type-bits arg-c-type))
-               (return-bits (c-integer-rep-type-bits return-c-type))
-               (max-type (if (and (plusp shift)
-                                  (< arg-bits return-bits))
-                           return-c-type
-                           arg-c-type)))
-          (produce-inline-loc (list argument) (list max-type) (list return-type)
-                              (format nil
-                                      (if (minusp shift)
-                                          "((#0) >> (~D))"
-                                          "((#0) << (~D))")
-                                      (abs shift))
-                              nil t)))))
+(defun simplify-arithmetic (operator args whole)
+  (if (every #'numberp args)
+      (apply operator args)
+      (let ((l (length args)))
+        (cond ((> l 2)
+               (simplify-arithmetic
+                operator
+                (list* (simplify-arithmetic operator
+                                            (list (first args) (second args))
+                                            nil)
+                       (cddr args))
+                nil))
+              ((= l 2)
+               (or whole (list* operator args)))
+              ((= l 1)
+               (if (or (eq operator '*) (eq operator '+))
+                   (first args)
+                   (or whole (list* operator args))))
+              ((eq operator '*)
+               1)
+              ((eq operator '+)
+               0)
+              (t
+               (error 'simple-program-error
+                      :format-error "Wrong number of arguments for operator ~a in ~a"
+                      :format-arguments (list operator (or whole
+                                                           (list* operator args)))))))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; TYPE PROPAGATION
-;;;
+(define-compiler-macro * (&whole all &rest args)
+  (simplify-arithmetic '* args all))
 
-(def-type-propagator logand (fname &rest args)
-  (values args
-          (if args
-              (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer)
-                (when (loop for value in args
-                         always (subtypep value int-type))
-                  (return int-type)))
-              'fixnum)))
+(define-compiler-macro + (&whole all &rest args)
+  (simplify-arithmetic '+ args all))
+
+(define-compiler-macro / (&whole all &rest args)
+  (simplify-arithmetic '/ args all))
+
+(define-compiler-macro - (&whole all &rest args)
+  (simplify-arithmetic '- args all))

src/cmp/cmpopt-printer.lsp

@@ -1,85 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
-;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
-
-;;;;
-;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
-;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-;;;;
-;;;;  CMPOPT-PRINTER  -- Optimize output operations
-;;;;
-
-(in-package "COMPILER")
-
-(defun printer-default-stream (stream env)
-  (declare (si::c-local))
-  (if (constantp stream env)
-      (let ((value (ext:constant-form-value stream env)))
-        (case value
-          ((nil) '*standard-output*)
-          ((t) '*terminal-io*)
-          (otherwise (cmpwarn
-                      (if (streamp value)
-                          "Found~%~A~%as expression for a stream, but it cannot be externalized."
-                          "Found~%~A~%where a stream was expected.")
-                      stream)
-                     stream)))
-      `(ffi:c-inline (,stream) (:object) :object
-                     "_ecl_stream_or_default_output(#0)"
-                     :one-liner t)))
-
-(define-compiler-macro princ (expression &optional stream &environment env)
-  (if (constantp expression env)
-      (let ((value (ext:constant-form-value expression env)))
-        (cond ((eql value #\Newline)
-               `(terpri ,stream))
-              ((characterp value)
-               `(ffi:c-inline ,(list value stream) (:wchar :object) :wchar
-                              "ecl_princ_char(#0,#1)"
-                              :one-liner t))
-              ((and (stringp value)
-                    (= (length value) 1))
-               `(ffi:c-inline ,(list (aref value 0) stream) (:wchar :object) :wchar
-                              "ecl_princ_char(#0,#1)"
-                              :one-liner t))
-              ((and (typep value 'base-string)
-                    (< (length value) 80))
-               `(progn
-                  (ffi:c-inline ,(list stream) (:object) :void
-                                ,(concatenate 'string
-                                              "ecl_princ_str("
-                                              (c-inline-safe-string value)
-                                              ",#0)")
-                                :one-liner t)
-                  ,value))
-              (t
-               `(ffi:c-inline ,(list expression stream) (:object :object) :object
-                              "ecl_princ(#0,#1)"
-                              :one-liner t))))
-      `(ffi:c-inline ,(list expression stream) (:object :object) :object
-                     "ecl_princ(#0,#1)"
-                     :one-liner t)))
-
-(define-compiler-macro terpri (&optional stream)
-  `(ffi:c-inline (,stream)
-                 (:object) :object
-                 "ecl_terpri(#0)"
-                 :one-liner t))
-
-(define-compiler-macro print (value &optional stream)
-  `(ffi:c-inline (,value ,stream)
-                 (:object :object) :object
-                 "ecl_print(#0,#1)"
-                 :one-liner t))
-
-(define-compiler-macro prin1 (value &optional stream)
-  `(ffi:c-inline (,value ,stream)
-                 (:object :object) :object
-                 "ecl_prin1(#0,#1)"
-                 :one-liner t))
-

src/cmp/cmpopt.lsp

@@ -339,25 +339,14 @@
 (define-compiler-macro coerce (&whole form value type &environment env)
   (expand-coerce form value type env))
 
-(define-compiler-macro float (&whole form value &optional float &environment env)
-  (or 
-   (and
-    float
-    (policy-inline-type-checks env)
-    (multiple-value-bind (constant-p float)
-        (constant-value-p float env)
-      (when (and constant-p (floatp float))
-        (let* ((float (type-of float))
-               (c-type (lisp-type->rep-type float)))
-          `(let ((value ,value))
-             (declare (:read-only value))
-             (ext:compiler-typecase value
-               (,float value)
-               (t
-                (ffi:c-inline (value) (:object) ,c-type
-                              ,(ecase c-type
-                                      (:double "ecl_to_double(#0)")
-                                      (:float "ecl_to_float(#0)")
-                                      (:long-double "ecl_to_long_double(#0)"))
-                              :one-liner t :side-effects nil))))))))
-   form))
+(define-compiler-macro princ (&whole whole expression &optional stream &environment env)
+  (if (constantp expression env)
+      (let ((value (ext:constant-form-value expression env)))
+        (typecase value
+          ((eql #\newline)
+           `(terpri ,stream))
+          ((string 1)
+           `(princ ,(aref value 0) ,stream))
+          (otherwise
+           whole)))
+      whole))

src/cmp/cmppass1-call.lsp

@@ -4,12 +4,7 @@
 ;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;  Copyright (c) 2021, Daniel Kochmański
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
 
 (in-package #:compiler)
@@ -125,10 +120,9 @@
          (if (and macros-allowed
                   (setf fd (cmp-macro-function fname)))
              (cmp-expand-macro fd (list* fname args))
-             ;; When it is a function and takes many arguments, we will
-             ;; need a special C form to call it. It takes extra code for
-             ;; handling the stack
-             (unoptimized-long-call `#',fname args)))
+             ;; When it is a function and takes too many arguments, we need a
+             ;; special C form to call it with the stack (see with-stack).
+             (unoptimized-long-call `(function ,fname) args)))
         ((setq fd (local-function-ref fname))
          (c1call-local fname fd args))
         ((and macros-allowed            ; macrolet
@@ -245,10 +239,8 @@
                  (return
                    (let ((results (multiple-value-list (apply fname (nreverse all-values)))))
                      (if (endp (rest results))
-                         (c1constant-value (first results) :only-small-values nil)
-                         (let ((results (mapcar (lambda (r)
-                                                  (c1constant-value r :only-small-values nil))
-                                                results)))
+                         (c1constant-value (first results))
+                         (let ((results (mapcar #'c1constant-value results)))
                            (when (every #'identity results)
                              (make-c1form* 'values :args results)))))))
       (error (c) (cmpdebug "Can't constant-fold ~s ~s: ~a~%" fname forms c)))))

src/cmp/cmppass1-cont.lsp

@@ -43,7 +43,7 @@
           body))))
 
 (defun c1return-from (args)
-  (check-args-number 'RETURN-FROM args 1 2)
+  (check-args-number 'CL:RETURN-FROM args 1 2)
   (let ((name (first args)))
     (unless (symbolp name)
       (cmperr "The block name ~s is not a symbol." name))
@@ -53,13 +53,12 @@
         (cmperr "The block ~s is undefined." name))
       (let* ((val (c1expr (second args)))
              (var (blk-var blk))
-             (type T))
-        (cond (cfb (setf type 'CLB
-                         (var-ref-clb var) T))
-              (unw (setf type 'UNWIND-PROTECT)))
+             (nonlocal (or cfb unw)))
+        (when cfb
+          (setf (var-ref-ccb var) T))
         (incf (blk-ref blk))
         (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val)))
-        (let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val)))
+        (let ((output (make-c1form* 'CL:RETURN-FROM :type 'T :args blk nonlocal val)))
           (when (or cfb unw)
             (add-to-read-nodes var output))
           output)))))

src/cmp/cmppass1-data.lsp

@@ -79,6 +79,19 @@
 (defun data-empty-loc ()
   (add-object 0 :duplicate t :permanent t))
 
+;;; Note that we can't use GET-OBJECT to probe for referenced objects because
+;;; ADD-OBJECT (when failed and :DUPLICATE is T) may return an object that is
+;;; not in any storage when the object is a known ECL symbol.
+(defun get-object (object &key permanent (errorp t))
+  (let* ((test (if si:*compiler-constants* 'eq 'equal-with-circularity))
+         (item (if permanent
+                   (find object *permanent-objects* :test test :key #'vv-value)
+                   (or (find object *permanent-objects* :test test :key #'vv-value)
+                       (find object *temporary-objects* :test test :key #'vv-value)))))
+    (when (and (null item) errorp)
+      (cmperr "Unable to find object ~s." object))
+    item))
+
 (defun add-object (object &key
                             (duplicate nil)
                             (used-p nil)
@@ -97,11 +110,7 @@
     ;; temporary storage from being created (we can't move objects from the
     ;; temporary into the permanent storage once they have been created).
     (setf load-form-p t permanent t))
-  (let* ((test (if si:*compiler-constants* 'eq 'equal-with-circularity))
-         (item (if permanent
-                   (find object *permanent-objects* :test test :key #'vv-value)
-                   (or (find object *permanent-objects* :test test :key #'vv-value)
-                       (find object *temporary-objects* :test test :key #'vv-value))))
+  (let* ((item (get-object object :permanent permanent :errorp nil))
          (array (if permanent
                     *permanent-objects*
                     *temporary-objects*))

src/cmp/cmppass1-eval.lsp

@@ -25,9 +25,8 @@
                ((keywordp form)
                 (make-c1form* 'LOCATION :type (object-type form)
                               :args (add-symbol form)))
-               ((constantp form *cmp-env*)
-                (or (c1constant-value (symbol-value form) :only-small-values t)
-                    (c1var form)))
+               ((and (constantp form *cmp-env*)
+                     (c1constant-value (symbol-value form))))
                (t (c1var form))))
         ((consp form)
          (cmpck (not (si:proper-list-p form))
@@ -117,7 +116,7 @@
        (return form))
      (setf form new-form))))
 
-(defun c1constant-value (val &key always only-small-values)
+(defun c1constant-value (val &key always)
   (cond
     ;; FIXME includes in c1 pass.
     ((ext:when-let ((x (assoc val *optimizable-constants*)))
@@ -135,24 +134,17 @@
      (make-c1form* 'LOCATION :type 'CHARACTER
                              :args (list 'CHARACTER-VALUE (char-code val))))
     ((typep val 'DOUBLE-FLOAT)
-     (when (and (ext:float-nan-p val) (not only-small-values))
-       (cmperr "Cannot externalize value ~A" val))
      (make-c1form* 'LOCATION :type 'DOUBLE-FLOAT
                              :args (list 'DOUBLE-FLOAT-VALUE val (add-object val))))
     ((typep val 'SINGLE-FLOAT)
-     (when (and (ext:float-nan-p val) (not only-small-values))
-       (cmperr "Cannot externalize value ~A" val))
      (make-c1form* 'LOCATION :type 'SINGLE-FLOAT
                              :args (list 'SINGLE-FLOAT-VALUE val (add-object val))))
     ((typep val 'LONG-FLOAT)
-     (when (and (ext:float-nan-p val) (not only-small-values))
-       (cmperr "Cannot externalize value ~A" val))
      (make-c1form* 'LOCATION :type 'LONG-FLOAT
                              :args (list 'LONG-FLOAT-VALUE val (add-object val))))
     #+sse2
     ((typep val 'EXT:SSE-PACK)
      (c1constant-value/sse val))
-    (only-small-values nil)
     (always
      (make-c1form* 'LOCATION :type `(eql ,val)
                              :args (add-object val)))

src/cmp/cmppass1-var.lsp

@@ -171,7 +171,7 @@
   ;;   - e2 produces no side effects
   (when (and (= 0 (var-ref var))
              (not (member (var-kind var) '(special global)))
-             (not (form-causes-side-effect form)))
+             (not (c1form-side-effects form)))
     (unless (var-ignorable var)
       (cmpdebug "Removing unused variable ~A" (var-name var)))
     (delete-c1forms form)
@@ -210,7 +210,7 @@
   ;;  - e2 does not affect v1 nor e3, e3 does not affect e2
   ;;  - e4 does not affect e2
   (when (and (= 1 (var-ref var))
-             (not (form-causes-side-effect form))
+             (not (c1form-side-effects form))
              ;; it does not refer to special variables which
              ;; are changed in the LET form
              (notany #'(lambda (v) (var-referenced-in-form v form)) rest-vars)

src/cmp/cmppass2-ffi.lsp

@@ -1,434 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
-;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
-
-;;;;
-;;;;  CMPFFI --  Foreign functions interface.
-
-;;;;  Copyright (c) 2003, Juan Jose Garcia-Ripoll.
-;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-
-(in-package "COMPILER")
-
-(defun c-number-rep-type-p (rep-type)
-  (let ((r (rep-type-record-unsafe rep-type)))
-    (and r (rep-type-numberp r))))
-
-(defun c-integer-rep-type-p (rep-type)
-  (let ((r (rep-type-record-unsafe rep-type)))
-    (and r (rep-type-integerp r))))
-
-(defun c-integer-rep-type-bits (rep-type)
-  (let ((r (rep-type-record-unsafe rep-type)))
-    (and r (rep-type-bits r))))
-
-(defun c-number-type-p (type)
-  (c-number-rep-type-p (lisp-type->rep-type type)))
-
-(defun c-integer-type-p (type)
-  (c-integer-rep-type-p (lisp-type->rep-type type)))
-
-(defun c-integer-type-bits (type)
-  (c-number-rep-type-bits (lisp-type->rep-type type)))
-
-(defun rep-type->c-name (type)
-  (rep-type-c-name (rep-type-record type)))
-
-(defun wt-to-object-conversion (loc-rep-type loc)
-  (when (and (consp loc) (member (first loc)
-                                 '(single-float-value
-                                   double-float-value
-                                   long-float-value
-                                   csfloat-value
-                                   cdfloat-value
-                                   clfloat-value)))
-    (wt (third loc)) ;; VV index
-    (return-from wt-to-object-conversion))
-  (let ((record (rep-type-record loc-rep-type)))
-    (unless record
-      (cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type))
-    (wt (rep-type-to-lisp record) "(" loc ")")))
-
-(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
-  (let* ((record (rep-type-record rep-type))
-         (coercer (and record (rep-type-from-lisp record))))
-    (unless coercer
-      (cmperr "Cannot coerce lisp object to C type ~A" rep-type))
-    (wt (if (or (policy-assume-no-errors)
-                (subtypep loc-type dest-type))
-            (rep-type-from-lisp-unsafe record)
-            coercer)
-        "(" loc ")")))
-
-(defun wt-coerce-loc (dest-rep-type loc)
-  (setq dest-rep-type (lisp-type->rep-type dest-rep-type))
-                                        ;(print dest-rep-type)
-                                        ;(print loc)
-  (let* ((dest-type (rep-type->lisp-type dest-rep-type))
-         (loc-type (loc-type loc))
-         (loc-rep-type (loc-representation-type loc)))
-    (labels ((coercion-error ()
-               (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~
-                        to C/C++ type (~S,~S)"
-                        loc-type loc-rep-type dest-type dest-rep-type))
-             (ensure-valid-object-type (a-lisp-type)
-               (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
-                 (coercion-error))))
-      (when (eq dest-rep-type loc-rep-type)
-        (wt loc)
-        (return-from wt-coerce-loc))
-      (case dest-rep-type
-        ((:char :unsigned-char :wchar)
-         (case loc-rep-type
-           ((:char :unsigned-char :wchar)
-            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
-           ((:object)
-            (ensure-valid-object-type dest-type)
-            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
-           (otherwise
-            (coercion-error))))
-        ((:float :double :long-double)
-         (cond
-           ((c-number-rep-type-p loc-rep-type)
-            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
-           ((eq loc-rep-type :object)
-            ;; We relax the check a bit, because it is valid in C to coerce
-            ;; between floats of different types.
-            (ensure-valid-object-type 'FLOAT)
-            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
-           (t
-            (coercion-error))))
-        ((:csfloat :cdfloat :clfloat)
-         (cond
-           ((c-number-rep-type-p loc-rep-type)
-            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
-           ((eq loc-rep-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)
-            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
-           (t
-            (coercion-error))))
-        ((:bool)
-         (cond
-           ((c-number-rep-type-p loc-rep-type)
-            (wt "1"))
-           ((eq loc-rep-type :object)
-            (wt "(" loc ")!=ECL_NIL"))
-           (t
-            (coercion-error))))
-        ((:object)
-         (case loc-rep-type
-           ((:int-sse-pack :float-sse-pack :double-sse-pack)
-            (when (>= (cmp-env-optimization 'speed) 1)
-              (cmpwarn-style "Boxing a value of type ~S - performance degraded."
-                             loc-rep-type))))
-         (wt-to-object-conversion loc-rep-type loc))
-        ((:pointer-void)
-         (case loc-rep-type
-           ((:object)
-            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
-           ((:cstring)
-            (wt "(char *)(" loc ")"))
-           (otherwise
-            (coercion-error))))
-        ((:cstring)
-         (coercion-error))
-        ((:char*)
-         (case loc-rep-type
-           ((:object)
-            (wt "ecl_base_string_pointer_safe(" loc ")"))
-           ((:pointer-void)
-            (wt "(char *)(" loc ")"))
-           (otherwise
-            (coercion-error))))
-        ((:int-sse-pack :float-sse-pack :double-sse-pack)
-         (case loc-rep-type
-           ((:object)
-            (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc))
-           ;; Implicitly cast between SSE subtypes
-           ((:int-sse-pack :float-sse-pack :double-sse-pack)
-            (wt (ecase dest-rep-type
-                  (:int-sse-pack (ecase loc-rep-type
-                                   (:float-sse-pack "_mm_castps_si128")
-                                   (:double-sse-pack "_mm_castpd_si128")))
-                  (:float-sse-pack (ecase loc-rep-type
-                                     (:int-sse-pack "_mm_castsi128_ps")
-                                     (:double-sse-pack "_mm_castpd_ps")))
-                  (:double-sse-pack (ecase loc-rep-type
-                                      (:int-sse-pack "_mm_castsi128_pd")
-                                      (:float-sse-pack "_mm_castps_pd"))))
-                "(" loc ")"))
-           (otherwise
-            (coercion-error))))
-        (t
-         ;; At this point we only have coercions to integers
-         (cond
-           ((not (c-integer-rep-type-p dest-rep-type))
-            (coercion-error))
-           ((c-number-rep-type-p loc-rep-type)
-            (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
-           ((eq :object loc-rep-type)
-            (ensure-valid-object-type dest-type)
-            (wt-from-object-conversion dest-type loc-type dest-rep-type loc))
-           (t
-            (coercion-error))))))))
-
-;;; ----------------------------------------------------------------------
-;;; C/C++ DECLARATIONS AND HEADERS
-;;;
-;;; All lines from CLINES statements are grouped at the beginning of the header
-;;; Notice that it does not make sense to guarantee that c-lines statements
-;;; are produced in-between the function definitions, because two functions
-;;; might be collapsed into one, or we might not produce that function at all
-;;; and rather inline it.
-;;;
-
-;;; FIXME pass1 handler defined in the pass2 module.
-(defun c1clines (args)
-  (unless (every #'stringp args)
-    (cmperr "The argument to CLINES, ~s, is not a list of strings." args))
-  (setf *clines-string-list* (nconc *clines-string-list* (copy-list args)))
-  '(progn))
-
-(defun output-clines (output-stream)
-  (flet ((parse-one-string (s output-stream)
-           (with-input-from-string (stream s)
-             (loop for c = (read-char stream nil nil)
-                   while c
-                   do (if (eq c #\@)
-                          (let ((object (handler-case (read stream)
-                                          (serious-condition (c)
-                                            (cmperr "Unable to parse FFI:CLINES string~& ~S"
-                                                    s)))))
-                            (let ((*compiler-output1* output-stream))
-                              (wt (add-object object :permanent t))))
-                          (write-char c output-stream))))))
-    (loop for s in *clines-string-list*
-          do (terpri output-stream)
-          do (if (find #\@ s)
-                 (parse-one-string s output-stream)
-                 (write-string s output-stream)))
-    (terpri output-stream)
-    (setf *clines-string-list* nil)))
-
-;; ----------------------------------------------------------------------
-;; C/C++ INLINE CODE
-;;
-
-(defun c2c-progn (c1form variables statements)
-  (declare (ignore c1form))
-  (loop with *destination* = 'TRASH
-        for form in statements
-        do (cond ((stringp form)
-                  (wt-nl)
-                  (wt-c-inline-loc :void form variables
-                                   t    ; side effects
-                                   nil) ; no output variables
-                  )
-                 (t
-                  (c2expr* form)))
-        finally (unwind-exit nil)))
-
-(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
-                           c-expression side-effects one-liner)
-  (let* (args-to-be-saved
-         coerced-arguments)
-    ;; If the expression begins with @[0-9a-z]*, this means we are
-    ;; saving some variables.
-    (when (and (> (length c-expression) 1)
-               (eq (char c-expression 0) #\@))
-      (do ((ndx 1 (1+ ndx)))
-          ((>= ndx (length c-expression)))
-        (let ((c (char c-expression ndx)))
-          (when (eq c #\;)
-            (setf c-expression (subseq c-expression (1+ ndx)))
-            (return))
-          (unless (alphanumericp c)
-            (setf args-to-be-saved nil)
-            (return))
-          (push (- (char-code c) (char-code #\0))
-                args-to-be-saved))))
-
-    (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved))
-    ;;(setf output-rep-type (lisp-type->rep-type output-rep-type))
-
-    ;; If the form does not output any data, and there are no side
-    ;; effects, try to omit it.
-    (when (null output-rep-type)
-      (if side-effects
-          (progn
-            (wt-nl)
-            (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil)
-            (when one-liner (wt ";")))
-          (cmpnote "Ignoring form ~S" c-expression))
-      (wt-nl "value0 = ECL_NIL;")
-      (wt-nl "cl_env_copy->nvalues = 0;")
-      (return-from produce-inline-loc 'RETURN))
-
-    ;; If the form is a one-liner, we can simply propagate this expression until the
-    ;; place where the value is used.
-    (when one-liner
-      (return-from produce-inline-loc
-        `(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
-                       ,(if (equalp output-rep-type '((VALUES &REST T)))
-                            'VALUES NIL))))
-
-    ;; If the output is a in the VALUES vector, just write down the form and output
-    ;; the location of the data.
-    (when (equalp output-rep-type '((VALUES &REST T)))
-      (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
-                       'VALUES)
-      (return-from produce-inline-loc 'VALUES))
-
-    ;; Otherwise we have to set up variables for holding the output.
-    (flet ((make-output-var (type)
-             (let ((var (make-lcl-var :rep-type type)))
-               (wt-nl (rep-type->c-name type) " " var ";")
-               var)))
-      (open-inline-block)
-      (let ((output-vars (mapcar #'make-output-var output-rep-type)))
-        (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars)
-        (cond ((= (length output-vars) 1)
-               (first output-vars))
-              (t
-               (loop for v in output-vars
-                     for i from 0
-                     do (let ((*destination* `(VALUE ,i))) (set-loc v)))
-               (wt "cl_env_copy->nvalues = " (length output-vars) ";")
-               'VALUES))))))
-
-(defun c2c-inline (c1form arguments &rest rest)
-  (declare (ignore c1form))
-  (let ((*inline-blocks* 0)
-        (*temp* *temp*))
-    (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
-    (close-inline-blocks)))
-
-(defun coerce-locs (inlined-args &optional types args-to-be-saved)
-  ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the
-  ;; inline code. ARGS-TO-BE-SAVED is a positional list created by
-  ;; C-INLINE, instructing that the value should be saved in a temporary
-  ;; variable. Finally, TYPES is a list of destination types, to which
-  ;; the former values are coerced. The destination types can be
-  ;;    - A lisp type (:OBJECT, :FINXUM, etc)
-  ;;    - A machine representation type (T, INTEGER, etc)
-  (loop with block-opened = nil
-        for (lisp-type loc) in inlined-args
-        for type in (or types '#1=(:object . #1#))
-        for i from 0
-        for rep-type = (lisp-type->rep-type type)
-        collect
-        (cond ((and args-to-be-saved
-                    (member i args-to-be-saved :test #'eql)
-                    (not (loc-movable-p loc)))
-               (let ((lcl (make-lcl-var :rep-type rep-type)))
-                 (wt-nl)
-                 (unless block-opened
-                   (setf block-opened t)
-                   (open-inline-block))
-                 (wt (rep-type->c-name rep-type) " " lcl "= ")
-                 (wt-coerce-loc rep-type loc)
-                 (wt ";")
-                 lcl))
-              ((equal rep-type (loc-representation-type loc))
-               loc)
-              (t
-               `(COERCE-LOC ,rep-type ,loc)))))
-
-(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
-  (declare (ignore output-rep-type side-effects))
-  (with-input-from-string (s c-expression)
-    (when (and output-vars (not (eq output-vars 'VALUES)))
-      (wt-nl))
-    (do ((c (read-char s nil nil)
-            (read-char s nil nil)))
-        ((null c))
-      (case c
-        (#\@
-         (let ((object (read s)))
-           (cond ((and (consp object) (equal (first object) 'RETURN))
-                  (if (eq output-vars 'VALUES)
-                      (cmperr "User @(RETURN ...) in a C-INLINE form with no output values")
-                      (let ((ndx (or (second object) 0))
-                            (l (length output-vars)))
-                        (if (< ndx l)
-                            (wt (nth ndx output-vars))
-                            (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values"
-                                    ndx l)))))
-                 (t
-                  (when (and (consp object) (eq (first object) 'QUOTE))
-                    (setq object (second object)))
-                  (wt (add-object object :permanent t))))))
-        (#\#
-         (let* ((k (read-char s))
-                (next-char (peek-char nil s nil nil))
-                (index (digit-char-p k 36)))
-           (cond ((eq k #\#)
-                  (wt #\#))
-                 ((or (null index) (and next-char (alphanumericp next-char)))
-                  (wt #\# k))
-                 ((< index (length coerced-arguments))
-                  (wt (nth index coerced-arguments)))
-                 (t
-                  (cmperr "C-INLINE: Variable code exceeds number of arguments")))))
-        (otherwise
-         (write-char c *compiler-output1*))))))
-
-(defun c-inline-safe-string (constant-string)
-  ;; Produce a text representation of a string that can be used
-  ;; in a C-INLINE form, without triggering the @ or # escape
-  ;; characters
-  (c-filtered-string
-   (concatenate 'string
-                (loop for c across constant-string
-                      when (member c '(#\# #\@))
-                        collect c
-                      collect c))))
-
-(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code
-                       arg-types arg-type-constants call-type &aux (return-p t))
-  (declare (ignore lisp-name))
-  (when (eql return-type :void)
-    (setf return-p nil))
-  (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type)))
-        (fmod (case call-type
-                ((:cdecl :default) "")
-                (:stdcall "__stdcall ")
-                (t (cmperr "DEFCALLBACK does not support ~A as calling convention"
-                           call-type)))))
-    (wt-nl-h "static " return-type-name " " fmod c-name "(")
-    (wt-nl1  "static " return-type-name " " fmod c-name "(")
-    (loop with comma = ""
-          for n from 0
-          for type in arg-types
-          for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type))
-          do (wt-h comma arg-type-name " var" n)
-             (wt   comma arg-type-name " var" n)
-             (setf comma ","))
-    (wt ")")
-    (wt-h ");")
-    (wt-nl-open-brace)
-    (when return-p
-      (wt-nl return-type-name " output;"))
-    (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
-    (wt-nl "cl_object aux;")
-    (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
-    (loop for n from 0
-          and type in arg-types
-          and ct in arg-type-constants
-          do (wt-nl "ecl_stack_frame_push("
-                    "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")"
-                    ");"))
-    (wt-nl "aux = ecl_apply_from_stack_frame(frame,"
-           "ecl_fdefinition(" c-name-constant "));")
-    (wt-nl "ecl_stack_frame_close(frame);")
-    (when return-p
-      (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);")
-      (wt-nl "return output;"))
-    (wt-nl-close-brace)))

src/cmp/cmppass2-loc.lsp

@@ -1,150 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
-;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
-
-;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
-;;;;  Copyright (c) 1990, Giuseppe Attardi.
-;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-
-;;;; CMPLOC  Set-loc and Wt-loc.
-
-(in-package "COMPILER")
-
-(defun wt-loc (loc)
-  (cond ((consp loc)
-         (let ((fd (gethash (car loc) *wt-loc-dispatch-table*)))
-           (if fd
-               (apply fd (cdr loc))
-               (unknown-location 'wt-loc loc))))
-        ((symbolp loc)
-         (let ((txt (gethash loc *wt-loc-dispatch-table* :not-found)))
-           (when (eq txt :not-found)
-             (unknown-location 'wt-loc loc))
-           (wt txt)))
-        ((stringp loc)
-         (wt loc))
-        ((var-p loc)
-         (wt-var loc))
-        ((vv-p loc)
-         (wt-vv loc))
-        (t
-         (unknown-location 'wt-loc loc))))
-
-(defun wt-lcl (lcl)
-  (unless (numberp lcl) (baboon :format-control "wt-lcl: ~s NaN"
-                                :format-arguments (list lcl)))
-  (wt "v" lcl))
-
-(defun wt-lcl-loc (lcl &optional type name)
-  (declare (ignore type))
-  (unless (numberp lcl)
-    (baboon :format-control "wt-lcl-loc: ~s NaN"
-            :format-arguments (list lcl)))
-  (wt "v" lcl name))
-
-(defun wt-temp (temp)
-  (wt "T" temp))
-
-(defun wt-fixnum (value &optional vv)
-  (declare (ignore vv))
-  (princ value *compiler-output1*)
-  ;; Specify explicit type suffix as a workaround for MSVC. C99
-  ;; standard compliant compilers don't need type suffixes and choose
-  ;; the correct type themselves. Note that we cannot savely use
-  ;; anything smaller than a long long here, because we might perform
-  ;; some other computation on the integer constant which could
-  ;; overflow if we use a smaller integer type (overflows in long long
-  ;; computations are taken care of by the compiler before we get to
-  ;; this point).
-  #+msvc (princ (cond ((typep value (rep-type->lisp-type :long-long)) "LL")
-                      ((typep value (rep-type->lisp-type :unsigned-long-long)) "ULL")
-                      (t (baboon :format-control
-                                 "wt-fixnum: The number ~A doesn't fit any integer type."
-                                 value)))
-                *compiler-output1*))
-
-(defun wt-number (value &optional vv)
-  (declare (ignore vv))
-  (wt value))
-
-(defun wt-character (value &optional vv)
-  (declare (ignore vv))
-  ;; We do not use the '...' format because this creates objects of type
-  ;; 'char' which have sign problems
-  (wt value))
-
-(defun wt-value (i) (wt "cl_env_copy->values[" i "]"))
-
-(defun wt-keyvars (i) (wt "keyvars[" i "]"))
-
-(defun wt-the (type loc)
-  (declare (ignore type))
-  (wt-loc loc))
-
-;;;
-;;; SET-LOC
-;;;
-
-(defun set-unknown-loc (loc)
-  (declare (ignore loc))
-  (unknown-location 'set-loc *destination*))
-
-(defun set-loc (loc &aux fd)
-  (let ((destination *destination*))
-    (cond ((eq destination loc))
-          ((symbolp destination)
-           (funcall (gethash destination *set-loc-dispatch-table*
-                             'set-unknown-loc)
-                    loc))
-          ((var-p destination)
-           (set-var loc destination))
-          ((vv-p destination)
-           (set-vv loc destination))
-          ((atom destination)
-           (unknown-location 'set-loc destination))
-          (t
-           (let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
-             (if fd
-                 (apply fd loc (rest destination))
-                 (progn
-                   (wt-nl) (wt-loc destination) (wt " = ")
-                   (wt-coerce-loc (loc-representation-type *destination*) loc)
-                   (wt ";"))))))))
-
-(defun set-the-loc (loc type orig-loc)
-  (declare (ignore type))
-  (let ((*destination* orig-loc))
-    (set-loc loc)))
-                 
-(defun set-values-loc (loc)
-  (cond ((eq loc 'VALUES))
-        ((uses-values loc)
-         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";"))
-        (t
-         (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc)
-         (wt ";")
-         (wt-nl "cl_env_copy->nvalues = 1;"))))
-
-(defun set-value0-loc (loc)
-  (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
-
-(defun set-return-loc (loc)
-  (cond ((or (eq loc 'VALUES) (uses-values loc))
-         (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
-        ((eq loc 'VALUE0)
-         (wt-nl "cl_env_copy->nvalues = 1;"))
-        ((eq loc 'RETURN))
-        (t
-         (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")
-         (wt-nl "cl_env_copy->nvalues = 1;"))))
-
-(defun set-trash-loc (loc)
-  (when (loc-with-side-effects-p loc)
-    (wt-nl loc ";")
-    t))

src/cmp/cmppass2-special.lsp

@@ -1,120 +0,0 @@
-;;;;
-;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
-;;;;  Copyright (c) 1990, Giuseppe Attardi
-;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
-;;;;  Copyright (c) 2021, Daniel Kochmański
-;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
-;;;;
-;;;;    See file '../Copyright' for full details.
-;;;;
-
-(in-package #:compiler)
-
-(defun c2compiler-let (c1form symbols values body)
-  (declare (ignore c1form))
-  (progv symbols values (c2expr body)))
-
-(defun c2function (c1form kind funob fun)
-  (declare (ignore c1form funob))
-  (case kind
-    (GLOBAL
-     (unwind-exit (list 'FDEFINITION fun)))
-    (CLOSURE
-     ;; XXX: we have some code after baboon – is CLOSURE legal or not?
-     (baboon :format-control "c2function: c1form is of unexpected kind.")
-     (new-local fun)
-     (unwind-exit `(MAKE-CCLOSURE ,fun)))))
-
-;;; Mechanism for sharing code.
-(defun new-local (fun)
-  ;; returns the previous function or NIL.
-  (declare (type fun fun))
-  (case (fun-closure fun)
-    (CLOSURE
-     (setf (fun-level fun) 0 (fun-env fun) *env*))
-    (LEXICAL
-     ;; Only increase the lexical level if there have been some
-     ;; new variables created. This way, the same lexical environment
-     ;; can be propagated through nested FLET/LABELS.
-     (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*)
-           (fun-env fun) 0))
-    (otherwise
-     (setf (fun-env fun) 0 (fun-level fun) 0)))
-  (let ((previous
-         nil
-         #+(or)
-         (dolist (old *local-funs*)
-           (when (similar fun old)
-             (return old)))))
-    (if previous
-        (progn
-          (if (eq (fun-closure fun) 'CLOSURE)
-              (cmpnote "Sharing code for closure")
-              (cmpnote "Sharing code for local function ~A" (fun-name fun)))
-          (setf (fun-cfun fun) (fun-cfun previous)
-                (fun-lambda fun) nil)
-          previous)
-        (push fun *local-funs*))))
-
-(defun wt-fdefinition (fun-name)
-  (let* ((name (si::function-block-name fun-name))
-         (package (symbol-package name))
-         (safe (or (not (safe-compile))
-                   (and (or (eq package (find-package "CL"))
-                            (eq package (find-package "CLOS"))
-                            (eq package (find-package "SI")))
-                        (fboundp fun-name)
-                        (functionp (fdefinition fun-name))))))
-    (if (eq name fun-name)
-        ;; #'symbol
-        (let ((vv (add-symbol name)))
-          (if safe
-              (wt "(" vv "->symbol.gfdef)")
-              (wt "ecl_fdefinition(" vv ")")))
-        ;; #'(SETF symbol)
-        (if safe
-            #+(or)
-            (let ((set-loc (assoc name *setf-definitions*)))
-              (unless set-loc
-                (let* ((setf-vv (data-empty-loc))
-                       (name-vv (add-symbol name))
-                       (setf-form-vv (add-object fun-name)))
-                  (setf set-loc (list name setf-vv name-vv setf-form-vv))
-                  (push set-loc *setf-definitions*)))
-              (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")"))
-            (let ((set-loc (assoc name *setf-definitions*)))
-              (unless set-loc
-                (let* ((setf-vv (data-empty-loc))
-                       (name-vv (add-symbol name)))
-                  (setf set-loc (list name setf-vv name-vv))
-                  (push set-loc *setf-definitions*)))
-              (wt "ECL_CONS_CAR(" (second set-loc) ")"))
-            (let ((vv (add-symbol fun-name)))
-              (wt "ecl_fdefinition(" vv ")"))))))
-
-(defun environment-accessor (fun)
-  (let* ((env-var (env-var-name *env-lvl*))
-         (expected-env-size (fun-env fun)))
-    (if (< expected-env-size *env*)
-        (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var)
-        env-var)))
-
-(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
-  (declare (type fun fun))
-  (let* ((closure (fun-closure fun))
-         narg)
-    (cond ((eq closure 'CLOSURE)
-           (wt "ecl_make_cclosure_va((cl_objectfn)" cfun ","
-               (environment-accessor fun)
-               ",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")"))
-          ((eq closure 'LEXICAL)
-           (baboon :format-control "wt-make-closure: lexical closure detected."))
-          ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args
-           (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")"))
-          (t ; empty environment variable number of args
-           (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock,"
-               (min (fun-minarg fun) si:c-arguments-limit) ")")))))

src/cmp/cmpprop-num.lsp

@@ -0,0 +1,172 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;  Copyright (c) 2010, Juan Jose Garcia Ripoll
+;;;;
+;;;;    See the file 'LICENSE' for the copyright details.
+;;;;
+
+;;;; Type propagators for numerical expressions.
+
+(in-package "COMPILER")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; TYPE PROPAGATION
+;;;
+
+(def-type-propagator logand (fname &rest args)
+  (values args
+          (if args
+              (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer)
+                (when (loop for value in args
+                         always (subtypep value int-type))
+                  (return int-type)))
+              'fixnum)))
+
+;;;
+;;; The following are type propagators for arithmetic operations. Note
+;;; that some of they have become binary operators.
+;;;
+
+(defun maximum-number-type (type1 type2 &key only-real integer-result)
+  ;; Computes the output type of an operation between number types T1
+  ;; and T2 using the rules of floating point contagion. It returns
+  ;; the type of the result, and the types of T1 and T2, if they
+  ;; represent known types, or NUMBER, in other cases.
+  (let ((t1-eq nil)
+        (t2-eq nil)
+        (t1 type1)
+        (t2 type2)
+        (output nil)
+        (complex-t1 nil)
+        (complex-t2 nil)
+        (default (if only-real 'REAL 'NUMBER))
+        (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
+                        DOUBLE-FLOAT LONG-FLOAT FLOAT REAL)))
+    (when (and (consp t1) (eq (first t1) 'COMPLEX))
+      (setf t1 (second t1) complex-t1 t))
+    (when (and (consp t2) (eq (first t2) 'COMPLEX))
+      (setf t2 (second t2) complex-t2 t))
+    (when (and only-real (or complex-t1 complex-t2))
+      (return-from maximum-number-type (values default default default)))
+    (loop for i across number-types
+          do (when (and (null t1-eq) (type>= i t1))
+               (when (equalp t1 t2)
+                 (setf t2-eq i))
+               (setf t1-eq i output i))
+             (when (and (null t2-eq) (type>= i t2))
+               (setf t2-eq i output i)))
+    (unless (and t1-eq t2-eq output)
+      (setf output default))
+    (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER)))
+      (setf output integer-result))
+    (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER)))
+      (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output))))
+    (values output (if t1-eq type1 default) (if t2-eq type2 default))))
+
+(defun ensure-number-type (general-type &key integer-result)
+  (maximum-number-type general-type general-type :integer-result integer-result))
+
+(defun ensure-nonrational-type (general-type)
+  (maximum-number-type general-type 'single-float))
+
+(defun ensure-real-type (general-type)
+  (maximum-number-type general-type 'integer :only-real t))
+
+(defun arithmetic-propagator (op1-type others integer-result)
+  ;; Propagates types for an associative operator (we do not care which one).
+  ;; We collect either the types of the arguments or 'NUMBER, as a generic
+  ;; expected type. The output type is computed using the rules of floating
+  ;; point contagion, with the exception that an operation between two
+  ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else)
+  (multiple-value-bind (result-type op1-type)
+      (ensure-number-type op1-type :integer-result integer-result)
+    (loop with arg-types = (list op1-type)
+       for x in others
+       for op2-type = x
+       do (progn
+            (multiple-value-setq (result-type op1-type op2-type)
+              (maximum-number-type result-type op2-type :integer-result integer-result))
+            (setf arg-types (cons op2-type arg-types)))
+       finally (return (values (nreverse arg-types) result-type)))))
+
+(def-type-propagator * (fname op1 &rest others)
+  (arithmetic-propagator op1 others 'integer))
+
+(copy-type-propagator '* '(+ -))
+
+(def-type-propagator / (fname op1 &rest others)
+  (arithmetic-propagator op1 others 'rational))
+
+;;;
+;;; SPECIAL FUNCTIONS
+;;;
+
+(def-type-propagator cos (fname op1-type)
+  (multiple-value-bind (output-type op1-type)
+      (ensure-nonrational-type op1-type)
+    (values (list op1-type) output-type)))
+
+(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp))
+
+(def-type-propagator acos (fname op1-type)
+  (multiple-value-bind (output-type op1-type)
+      (ensure-nonrational-type op1-type)
+    (declare (ignore output-type))
+    (values (list op1-type) 'NUMBER)))
+
+(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p))
+  (multiple-value-bind (float-t1 t1)
+      (ensure-nonrational-type op1-type)
+    (if op2-p
+        (multiple-value-bind (result t1 t2)
+            (maximum-number-type t1 op2-type :only-real t)
+          (values (list t1 t2) result))
+        (values (list t1) float-t1))))
+
+(def-type-propagator expt (fname base exponent)
+  ;; Rules:
+  ;;    (expt fixnum integer) -> integer
+  ;;    (expt number-type integer) -> number-type
+  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
+  ;;
+  (let ((exponent (ensure-real-type exponent)))
+    (values (list base exponent)
+            (cond ((eql exponent 'integer)
+                   (if (subtypep base 'fixnum)
+                       'integer
+                       base))
+                  ((type>= '(real 0 *) base)
+                   (let* ((exponent (ensure-nonrational-type exponent)))
+                     (maximum-number-type exponent base)))
+                  (t
+                   'number)))))
+
+(def-type-propagator abs (fname arg)
+  (multiple-value-bind (output arg)
+      (ensure-number-type arg)
+    (values (list arg)
+            (or (cdr (assoc output
+                            '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM))
+                              (INTEGER . (INTEGER 0 *))
+                              (RATIONAL . (RATIONAL 0 *))
+                              (SHORT-FLOAT . (SHORT-FLOAT 0 *))
+                              (SINGLE-FLOAT . (SINGLE-FLOAT 0 *))
+                              (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *))
+                              (LONG-FLOAT . (LONG-FLOAT 0 *))
+                              (REAL . (REAL 0 *))
+                              (NUMBER . (REAL 0 *)))))
+                output))))
+
+(def-type-propagator sqrt (fname arg)
+  (multiple-value-bind (output arg)
+      (ensure-nonrational-type arg)
+    (values (list arg)
+            (if (type>= '(REAL 0 *) arg) output 'NUMBER))))
+
+(def-type-propagator isqrt (fname arg)
+  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
+      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
+              '(integer 0 #.MOST-POSITIVE-FIXNUM))
+      (values '((integer 0 *)) '(integer 0 *))))

src/cmp/cmpprop.lsp

@@ -21,17 +21,18 @@
     (when *type-propagation-messages*
       `(format *standard-output* ,string ,@args))))
 
-(defun p1ordinary (c1form assumptions form)
+(defun p1ordinary (c1form form)
   (declare (ignore c1form))
-  (p1propagate form assumptions))
+  (p1propagate form))
 
-(defun p1fset (c1form assumptions fun fname macro pprint c1forms)
-  (declare (ignore c1form fun fname macro pprint c1forms))
-  (values 'function assumptions))
+(defun p1fset (c1form fun fname macro pprint c1forms)
+  (declare (ignore c1form fname macro pprint c1forms))
+  (p1propagate-function fun)
+  'function)
 
-(defun p1propagate (form assumptions)
+(defun p1propagate (form)
   (unless form
-    (return-from p1propagate (values 'null assumptions)))
+    (return-from p1propagate 'null))
   (when (c1form-p form)
     (let ((*cmp-env* (c1form-env form))
           (*compile-file-pathname* (c1form-file form))
@@ -41,211 +42,145 @@
           (name (c1form-name form)))
       (ext:when-let ((propagator (gethash name *p1-dispatch-table*)))
         (prop-message "~&;;; Entering type propagation for ~A" name)
-        (multiple-value-bind (new-type assumptions)
-            (apply propagator form assumptions (c1form-args form))
-          (when assumptions
-            (baboon :format-control "Non-empty assumptions found in P1PROPAGATE"))
+        (let ((new-type (apply propagator form (c1form-args form))))
           (prop-message "~&;;; Propagating ~A gives type ~A" name new-type)
           (return-from p1propagate
-            (values (setf (c1form-type form)
-                          (values-type-and (c1form-type form)
-                                           new-type))
-                    assumptions))))))
+            (setf (c1form-type form)
+                  (values-type-and (c1form-type form) new-type)))))))
   (cmpnote "Refusing to propagate ~A" form)
-  (values (c1form-type form) assumptions))
+  (c1form-type form))
 
-(defun p1trivial (form assumptions &rest rest)
+(defun p1trivial (form &rest rest)
   (declare (ignore rest))
-  (values (c1form-type form) assumptions))
+  (c1form-type form))
 
-(defun p1var (form assumptions var)
-  (let* ((record (and (assoc var assumptions)
-                      (baboon :format-control "Non empty assumptions found in P1VAR")))
-         ;; Use the type of C1FORM because it might have been
+(defun p1var (form var)
+  (let* (;; Use the type of C1FORM because it might have been
          ;; coerced by a THE form.
-         (var-type (if record (cdr record) (var-type var)))
+         (var-type (var-type var))
          (type (type-and var-type (c1form-primary-type form))))
     (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type)
-    (values type assumptions)))
+    type))
 
-(defun p1values (form assumptions values)
+(defun p1values (form values)
   (declare (ignore form))
   (loop for v in values
-        collect (multiple-value-bind (type new-assumptions)
-                    (p1propagate v assumptions)
-                  (setf assumptions new-assumptions)
-                  (values-type-primary-type type))
+        collect (values-type-primary-type (p1propagate v))
           into all-values
-        finally (return (values `(values ,@all-values) assumptions))))
+        finally (return `(values ,@all-values))))
 
-(defun p1propagate-list (list assumptions)
+(defun p1propagate-list (list)
   (loop with final-type = t
-     for f in list
-     do (multiple-value-setq (final-type assumptions) (p1propagate f assumptions))
-     finally (return (values final-type assumptions))))
+        for f in list
+        do (setf final-type (p1propagate f))
+        finally (return final-type)))
 
-(defun p1merge-branches (root chains)
-  "ROOT is a list of assumptions, while CHAINS is list of extended versions of
-ROOT. This function takes all those extensions and makes a final list in which
-type assumptions have been merged, giving the variables the OR type of each
-of the occurrences in those lists."
-  (unless (and (null root)
-               (every #'null chains))
-    (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions")))
-
-(defun revise-var-type (variable assumptions where-to-stop)
-  (declare (ignore variable))
-  (unless (and (null assumptions) (null where-to-stop))
-    (baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions")))
-
-(defun p1block (c1form assumptions blk body)
+(defun p1block (c1form blk body)
   (declare (ignore c1form))
   (setf (blk-type blk) nil)
-  (multiple-value-bind (normal-type assumptions)
-      (p1propagate body assumptions)
-    (let ((blk-type (blk-type blk)))
-      (values (if blk-type (values-type-or blk-type normal-type) normal-type)
-              assumptions))))
+  (let ((normal-type (p1propagate body))
+        (blk-type (blk-type blk)))
+    (if blk-type
+        (values-type-or blk-type normal-type)
+        normal-type)))
 
-(defun p1return-from (c1form assumptions blk return-type value)
+(defun p1return-from (c1form blk return-type value)
   (declare (ignore c1form return-type))
-  (let* ((values-type (p1propagate value assumptions))
+  (let* ((values-type (p1propagate value))
          (blk-type (blk-type blk)))
     (setf (blk-type blk) (if blk-type
                              (values-type-or blk-type values-type)
                              values-type))
-    (values values-type assumptions)))
+    values-type))
 
-(defun p1call-global (c1form assumptions fname args)
+(defun p1call-global (c1form fname args)
   (declare (ignore c1form))
   (loop for v in args
-        do (multiple-value-bind (arg-type local-ass)
-               (p1propagate v assumptions)
-             (declare (ignore arg-type))
-             (setf assumptions local-ass))
+        do (p1propagate v)
         finally (let ((type (propagate-types fname args)))
                   (prop-message "~&;;; Computing output of function ~A with args~&;;;  ~{ ~A~}~&;;; gives ~A, while before ~A"
                                 fname (mapcar #'c1form-primary-type args)
                                 type (c1form-type c1form))
-                  (return (values type assumptions)))))
+                  (return type))))
 
-(defun p1call-local (c1form assumptions fun args)
+(defun p1call-local (c1form fun args)
   (declare (ignore c1form))
   (loop for v in args
-        do (multiple-value-bind (arg-type local-ass)
-               (p1propagate v assumptions)
-             (declare (ignore arg-type))
-             (setf assumptions local-ass))
-        finally (return (values (fun-return-type fun)
-                                assumptions))))
+        do (p1propagate v)
+        finally (return (fun-return-type fun))))
 
-(defun p1catch (c1form assumptions tag body)
+(defun p1catch (c1form tag body)
   (declare (ignore c1form))
-  (multiple-value-bind (tag-type assumptions)
-      (p1propagate tag assumptions)
-    (declare (ignore tag-type))
-    (p1propagate body assumptions))
-  (values t assumptions))
+  (p1propagate tag)
+  (p1propagate body)
+  t)
 
-(defun p1throw (c1form assumptions catch-value output-value)
+(defun p1throw (c1form catch-value output-value)
   (declare (ignore c1form))
-  (multiple-value-bind (type new-assumptions)
-      (p1propagate catch-value assumptions)
-    (declare (ignore type))
-    (p1propagate output-value new-assumptions))
-  (values t assumptions))
+  (p1propagate catch-value)
+  (p1propagate output-value)
+  t)
 
-(defun p1if (c1form assumptions fmla true-branch false-branch)
+(defun p1if (c1form fmla true-branch false-branch)
   (declare (ignore c1form))
-  (multiple-value-bind (fmla-type base-assumptions)
-      (p1propagate fmla assumptions)
-    (declare (ignore fmla-type))
-    (multiple-value-bind (t1 a1)
-        (p1propagate true-branch base-assumptions)
-      (multiple-value-bind (t2 a2)
-          (p1propagate false-branch base-assumptions)
-        (values (values-type-or t1 t2)
-                (p1merge-branches base-assumptions (list a1 a2)))))))
+  (p1propagate fmla)
+  (let ((t1 (p1propagate true-branch))
+        (t2 (p1propagate false-branch)))
+    (values-type-or t1 t2)))
 
-(defun p1fmla-not (c1form assumptions form)
+(defun p1fmla-not (c1form form)
   (declare (ignore c1form))
-  (multiple-value-bind (type assumptions)
-      (p1propagate form assumptions)
-    (declare (ignore type))
-    (values '(member t nil) assumptions)))
+  (p1propagate form)
+  '(member t nil))
 
-(defun p1fmla-and (c1form orig-assumptions butlast last)
+(defun p1fmla-and (c1form butlast last)
   (declare (ignore c1form))
   (loop with type = t
-        with assumptions = orig-assumptions
         for form in (append butlast (list last))
-        collect (progn
-                  (multiple-value-setq (type assumptions)
-                    (p1propagate form assumptions))
-                  assumptions)
-          into assumptions-list
-        finally (return (values (type-or 'null (values-type-primary-type type))
-                                (p1merge-branches orig-assumptions
-                                                  assumptions-list)))))
+        do (setf type (p1propagate form))
+        finally (return (type-or 'null (values-type-primary-type type)))))
 
-(defun p1fmla-or (c1form orig-assumptions butlast last)
+(defun p1fmla-or (c1form butlast last)
   (declare (ignore c1form))
   (loop with type
         with output-type = t
-        with assumptions = orig-assumptions
         for form in (append butlast (list last))
-        collect (progn
-                  (multiple-value-setq (type assumptions)
-                    (p1propagate form assumptions))
-                  (setf output-type (type-or (values-type-primary-type type)
-                                             output-type))
-                  assumptions)
-          into assumptions-list
-        finally (return (values output-type
-                                (p1merge-branches orig-assumptions
-                                                  assumptions-list)))))
+        do (setf type (p1propagate form)
+                 output-type (type-or (values-type-primary-type type)
+                                      output-type))
+        finally (return output-type)))
 
-(defun p1lambda (c1form assumptions lambda-list doc body &rest not-used)
+(defun p1lambda (c1form lambda-list doc body &rest not-used)
   (declare (ignore c1form lambda-list doc not-used))
   (prop-message "~&;;;~&;;; Propagating function~&;;;")
-  (let ((type (p1propagate body assumptions)))
-    (values type assumptions)))
+  (p1propagate body))
 
-(defun p1propagate-function (fun assumptions)
-  (multiple-value-bind (output-type assumptions)
-      (p1propagate (fun-lambda fun) assumptions)
-    (values (setf (fun-return-type fun) output-type)
-            assumptions)))
+(defun p1propagate-function (fun)
+  (setf (fun-return-type fun) (p1propagate (fun-lambda fun))))
 
-(defun p1let* (c1form base-assumptions vars forms body)
+(defun p1let* (c1form vars forms body)
   (declare (ignore c1form))
-  (let ((assumptions base-assumptions))
-    (loop with type
-          for v in vars
-          for f in forms
-          unless (or (global-var-p v) (var-set-nodes v))
-            do (progn
-                 (multiple-value-setq (type assumptions) (p1propagate f assumptions))
-                 (setf (var-type v) (type-and (values-type-primary-type type)
-                                              (var-type v)))
-                 (prop-message "~&;;; Variable ~A assigned type ~A"
-                               (var-name v) (var-type v))))
-    (multiple-value-bind (type assumptions)
-        (p1propagate body assumptions)
-      (loop for v in vars
-            do (revise-var-type v assumptions base-assumptions))
-      (values type assumptions))))
+  (loop with type
+        for v in vars
+        for f in forms
+        unless (or (global-var-p v) (var-set-nodes v))
+          do (progn
+               (setf type (p1propagate f))
+               (setf (var-type v)
+                     (type-and (values-type-primary-type type) (var-type v)))
+               (prop-message "~&;;; Variable ~A assigned type ~A"
+                             (var-name v) (var-type v))))
+  (p1propagate body))
 
-(defun p1locals (c1form assumptions funs body labels)
+(defun p1locals (c1form funs body labels)
   (declare (ignore c1form labels))
   (loop for f in funs
-        do (p1propagate-function f assumptions))
-  (p1propagate body assumptions))
+        do (p1propagate-function f))
+  (p1propagate body))
 
-(defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body)
+(defun p1multiple-value-bind (c1form vars-list init-c1form body)
   (declare (ignore c1form))
-  (multiple-value-bind (init-form-type assumptions)
-      (p1propagate init-c1form assumptions)
+  (let ((init-form-type (p1propagate init-c1form)))
     (loop for v in vars-list
           for type in (values-type-to-n-types init-form-type (length vars-list))
           unless (or (global-var-p v)
@@ -253,116 +188,85 @@ of the occurrences in those lists."
             do (setf (var-type v) (type-and (var-type v) type)) and
           do (prop-message "~&;;; Variable ~A assigned type ~A"
                            (var-name v) (var-type v)))
-    (p1propagate body assumptions)))
+    (p1propagate body)))
 
-(defun p1multiple-value-setq (c1form assumptions vars-list value-c1form)
+(defun p1multiple-value-setq (c1form vars-list value-c1form)
   (declare (ignore c1form vars-list))
-  (multiple-value-bind (init-form-type assumptions)
-      (p1propagate value-c1form assumptions)
-    (values init-form-type assumptions)))
+  (p1propagate value-c1form))
 
-(defun p1progn (c1form assumptions forms)
+(defun p1progn (c1form forms)
   (declare (ignore c1form))
-  (p1propagate-list forms assumptions))
+  (p1propagate-list forms))
 
-(defun p1compiler-typecase (c1form assumptions variable expressions)
+(defun p1compiler-typecase (c1form variable expressions)
   (declare (ignore c1form))
   (let ((var-type (var-type variable)))
     (loop with output-type = t
           for (a-type c1form) in expressions
-          for c1form-type = (p1propagate c1form assumptions)
+          for c1form-type = (p1propagate c1form)
           when (or (member a-type '(t otherwise))
                    (subtypep var-type a-type))
             do (setf output-type c1form-type)
-          finally (return (values output-type assumptions)))))
+          finally (return output-type))))
 
-(defun p1checked-value (c1form assumptions type value let-form)
+(defun p1checked-value (c1form type value let-form)
   (declare (ignore c1form let-form))
-  (let ((value-type (p1propagate value assumptions))
-         ;;(alt-type (p1propagate let-form assumptions))
+  (let ((value-type (p1propagate value))
+         ;;(alt-type (p1propagate let-form))
         )
     (if (subtypep value-type type)
         value-type
         type)))
 
-(defun p1progv (c1form assumptions variables values body)
+(defun p1progv (c1form variables values body)
   (declare (ignore c1form))
-  (let (type)
-    (multiple-value-setq (type assumptions)
-      (p1propagate variables assumptions))
-    (multiple-value-setq (type assumptions)
-      (p1propagate values assumptions))
-    (p1propagate body assumptions)))
+  (p1propagate variables)
+  (p1propagate values)
+  (p1propagate body))
 
-(defun p1setq (c1form assumptions var value-c1form)
+(defun p1setq (c1form var value-c1form)
   (declare (ignore c1form))
-  (multiple-value-bind (value-type assumptions)
-      (p1propagate value-c1form assumptions)
-    (values (type-and (var-type var) (values-type-primary-type value-type))
-            assumptions)))
+  (let ((value-type (p1propagate value-c1form)))
+    (type-and (var-type var) (values-type-primary-type value-type))))
 
-(defun p1psetq (c1form assumptions vars c1forms)
+(defun p1psetq (c1form vars c1forms)
   (declare (ignore c1form vars))
   (loop for form in c1forms
-        do (p1propagate form assumptions))
-  (values 'null assumptions))
+        do (p1propagate form))
+  'null)
 
-(defun p1with-stack (c1form assumptions body)
+(defun p1with-stack (c1form body)
   (declare (ignore c1form))
-  (p1propagate body assumptions))
+  (p1propagate body))
 
-(defun p1stack-push-values (c1form assumptions form inline)
+(defun p1stack-push-values (c1form form inline)
   (declare (ignore c1form inline))
-  (multiple-value-bind (form-type assumptions)
-      (p1propagate form assumptions)
-    (declare (ignore form-type))
-    (values nil assumptions)))
+  (p1propagate form)
+  nil)
 
 (defvar *tagbody-depth* -1
   "If n > 0, limit the number of passes to converge tagbody forms. If
 -1, let the compiler do as many passes as it wishes. Complexity grows
 as 2^*tagbody-limit* in the worst cases.")
 
-(defun p1go (c1form assumptions tag-var return-type)
+(defun p1go (c1form tag-var return-type)
   (declare (ignore c1form tag-var return-type))
-  (values t assumptions))
+  t)
 
-(defun filter-only-declarations (assumptions)
-  (when assumptions
-    (baboon :format-control "FILTER-ONLY-DECLARATIONS gets a non-empty assumption list"))
-  nil)
-
-(defun p1tagbody (c1form orig-assumptions tag-loc body)
-  (prop-message "~&;;; P1TAGBODY-SIMPLE pass")
-  (let* ((assumptions (filter-only-declarations orig-assumptions))
-         (ass-list (p1tagbody-one-pass c1form assumptions tag-loc body)))
-    (values 'null (append (p1merge-branches nil ass-list) orig-assumptions))))
-
-(defun p1tagbody-one-pass (c1form assumptions tag-loc body)
+(defun p1tagbody (c1form tag-loc body)
   (declare (ignore c1form tag-loc))
-  (loop with local-ass = assumptions
-     with ass-list = '()
-     with aux
-     for f in body
-     do (if (tag-p f)
-            (let ((diff (ldiff local-ass assumptions)))
-              (when diff
-                (push diff ass-list))
-              (prop-message "~&;;; Label ~A found" (tag-name f))
-              (setf local-ass assumptions))
-            (multiple-value-setq (aux local-ass) (p1propagate f local-ass)))
-     finally (return
-               (let ((diff (ldiff local-ass assumptions)))
-                 (if diff
-                     (cons diff ass-list)
-                     ass-list)))))
+  (prop-message "~&;;; P1TAGBODY-SIMPLE pass")
+  (loop for f in body do
+    (if (tag-p f)
+        (prop-message "~&;;; Label ~A found" (tag-name f))
+        (p1propagate f)))
+  'null)
 
-(defun p1unwind-protect (c1form assumptions form body)
+(defun p1unwind-protect (c1form form body)
   (declare (ignore c1form))
-  (multiple-value-bind (output-type assumptions)
-      (p1propagate form assumptions)
-    (p1propagate body assumptions)
-    (values output-type assumptions)))
+  (let ((output-type (p1propagate form)))
+    (p1propagate body)
+    output-type))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

src/cmp/cmptables.lsp

@@ -4,12 +4,8 @@
 ;;;;
 ;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU Library General Public
-;;;;    License as published by the Free Software Foundation; either
-;;;;    version 2 of the License, or (at your option) any later version.
+;;;;    See the file 'LICENSE' for the copyright details.
 ;;;;
-;;;;    See file '../Copyright' for full details.
 
 ;;;; CMPPROP Type propagation.
 
@@ -17,42 +13,54 @@
 
 (eval-when (:compile-toplevel :execute)
 (defconstant +all-c1-forms+
-  '((LOCATION           loc :pure :single-valued)
+  '(;; top-level forms
+    (ORDINARY           c1form :pure)
+    (MAKE-FORM          vv-loc value-c1form :side-effects)
+    (INIT-FORM          vv-loc value-c1form :side-effects)
+    ;; both-level forms (different semantics)
+    (EXT:COMPILER-LET   symbols values body)
+    (SI:FSET            function-object vv-loc macro-p pprint-p lambda-form :side-effects)
+    (CL:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
+    (CL:PROGN           body :pure)
+    ;; sub-level forms
+    (LOCATION           loc :pure :single-valued)
     (VAR                var :single-valued)
-    (cl:SETQ            var value-c1form :side-effects)
-    (cl:PSETQ           var-list value-c1form-list :side-effects)
-    (cl:BLOCK           blk-var progn-c1form :pure)
-    (cl:PROGN           body :pure)
-    (cl:PROGV           symbols values form :side-effects)
-    (cl:TAGBODY         tag-var tag-body :pure)
-    (cl:RETURN-FROM     blk-var return-type value :side-effects)
-    (cl:FUNCALL         fun-value (arg-value*) :side-effects)
+    (CL:SETQ            var value-c1form :side-effects)
+    (CL:PSETQ           var-list value-c1form-list :side-effects)
+    (CL:BLOCK           blk-var progn-c1form :pure)
+
+    (CL:PROGV           symbols values form :side-effects)
+    (CL:TAGBODY         tag-var tag-body :pure)
+    (CL:RETURN-FROM     blk-var nonlocal value :side-effects)
+    (CL:FUNCALL         fun-value (arg-value*) :side-effects)
     (CALL-LOCAL         obj-fun (arg-value*) :side-effects)
     (CALL-GLOBAL        fun-name (arg-value*))
-    (cl:CATCH           catch-value body :side-effects)
-    (cl:UNWIND-PROTECT  protected-c1form body :side-effects)
-    (cl:THROW           catch-value output-value :side-effects)
-    (cl:GO              tag-var return-type :side-effects)
-    (ffi:C-INLINE       (arg-c1form*)
+    (CL:CATCH           catch-value body :side-effects)
+    (CL:UNWIND-PROTECT  protected-c1form body :side-effects)
+    (CL:THROW           catch-value output-value :side-effects)
+    (CL:GO              tag-var nonlocal :side-effects)
+
+    (FFI:C-INLINE       (arg-c1form*)
                         (arg-type-symbol*)
                         output-rep-type
                         c-expression-string
                         side-effects-p
                         one-liner-p)
-    (ffi:C-PROGN        variables forms)
+    (FFI:C-PROGN        variables forms)
+
     (LOCALS             local-fun-list body labels-p :pure)
-    (cl:IF              fmla-c1form true-c1form false-c1form :pure)
+    (CL:IF              fmla-c1form true-c1form false-c1form :pure)
     (FMLA-NOT           fmla-c1form :pure)
     (FMLA-AND           * :pure)
     (FMLA-OR            * :pure)
-    (cl:LAMBDA          lambda-list doc body-c1form)
-    (cl:LET*            vars-list var-init-c1form-list decl-body-c1form :pure)
-    (cl:VALUES          values-c1form-list :pure)
-    (cl:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
-    (cl:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
-    (ext:COMPILER-LET       symbols values body)
-    (cl:FUNCTION        (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
-    (cl:RPLACD          (dest-c1form value-c1form) :side-effects)
+    (CL:LAMBDA          lambda-list doc body-c1form)
+    (CL:LET*            vars-list var-init-c1form-list decl-body-c1form :pure)
+    (CL:VALUES          values-c1form-list :pure)
+    (CL:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
+    (CL:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
+
+    (CL:FUNCTION        (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
+    (CL:RPLACD          (dest-c1form value-c1form) :side-effects)
 
     (SI:STRUCTURE-REF   struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
     (SI:STRUCTURE-SET   struct-c1form type-name slot-index value-c1form :side-effects)
@@ -60,12 +68,6 @@
     (WITH-STACK         body :side-effects)
     (STACK-PUSH-VALUES  value-c1form push-statement-c1form :side-effects)
 
-    (ORDINARY           c1form :pure)
-    (cl:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
-    (SI:FSET            function-object vv-loc macro-p pprint-p lambda-form
-                        :side-effects)
-    (MAKE-FORM          vv-loc value-c1form :side-effects)
-    (INIT-FORM          vv-loc value-c1form :side-effects)
     (ext:COMPILER-TYPECASE var expressions)
     (ext:CHECKED-VALUE  type value-c1form let-form))))
 

src/cmp/cmptype-arith.lsp

@@ -50,7 +50,7 @@
 ;;; Depends on the implementation of TYPE-OF.
 ;;; (only used for saving constants?)
 (defun object-type (thing)
-  (let ((type (if thing (type-of thing) 'SYMBOL)))
+  (let ((type (type-of thing)))
     (case type
       ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
       ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)

src/cmp/cmptype.lsp

@@ -49,7 +49,7 @@
                                  (si:complex-single-float . #c(0.0l0 0.0l0)))
                                :test #'subtypep))))
     (if new-value
-        (c1constant-value new-value :only-small-values t)
+        (c1constant-value new-value)
         (c1nil))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

src/cmp/cmputil.lsp

@@ -153,12 +153,6 @@
         :format-control "The expansion of the compiler macro~%~T~A~%was aborted because of a serious condition~%~A" :format-arguments (list fname c))
       (values nil nil))))
 
-(defun si::compiler-clear-compiler-properties (symbol)
-  (si:rem-sysprop symbol 't1)
-  (si:rem-sysprop symbol 't2)
-  (si:rem-sysprop symbol 't3)
-  (si:rem-sysprop symbol 'lfun))
-
 (defun lisp-to-c-name (obj)
   "Translate Lisp object prin1 representation to valid C identifier name"
   (and obj 
@@ -478,79 +472,5 @@ comparing circular objects."
 (defmacro defun-equal-cached (name lambda-list &body body)
   `(defun-cached ,name ,lambda-list equal-with-circularity ,@body))
 
-;;; ----------------------------------------------------------------------
-;;; CONVENIENCE FUNCTIONS / MACROS
-;;;
-
-(defun-cached env-var-name (n) eql
-  (format nil "env~D" n))
-
-(defun-cached lex-env-var-name (n) eql
-  (format nil "lex~D" n))
-
 (defun same-fname-p (name1 name2)
   (equal name1 name2))
-
-;;; from cmplabel.lsp
-(defun next-label ()
-  (cons (incf *last-label*) nil))
-
-(defun next-label* ()
-  (cons (incf *last-label*) t))
-
-(defun labelp (x)
-  (and (consp x) (integerp (si:cons-car x))))
-
-(defun maybe-next-label ()
-  (if (labelp *exit*)
-      *exit*
-      (next-label)))
-
-(defmacro with-exit-label ((label) &body body)
-  `(let* ((,label (next-label))
-          (*unwind-exit* (cons ,label *unwind-exit*)))
-     ,@body
-     (wt-label ,label)))
-
-(defmacro with-optional-exit-label ((label) &body body)
-  `(let* ((,label (maybe-next-label))
-          (*unwind-exit* (adjoin ,label *unwind-exit*)))
-     ,@body
-     (unless (eq ,label *exit*)
-       (wt-label ,label))))
-
-(defun next-lcl (&optional name)
-  (list 'LCL (incf *lcl*) T
-        (if (and name (symbol-package name))
-            (lisp-to-c-name name)
-            "")))
-
-(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
-  (let ((code (incf *next-cfun*)))
-    (format nil prefix code (lisp-to-c-name lisp-name))))
-
-(defun next-temp ()
-  (prog1 *temp*
-         (incf *temp*)
-         (setq *max-temp* (max *temp* *max-temp*))))
-
-(defun next-lex ()
-  (prog1 (cons *level* *lex*)
-         (incf *lex*)
-         (setq *max-lex* (max *lex* *max-lex*))))
-
-(defun next-env ()
-  (prog1 *env*
-    (incf *env*)
-    (setq *max-env* (max *env* *max-env*))))
-
-(defun env-grows (possibily)
-  ;; if additional closure variables are introduced and this is not
-  ;; last form, we must use a new env.
-  (and possibily
-       (plusp *env*)
-       (dolist (exit *unwind-exit*)
-         (case exit
-           (RETURN (return NIL))
-           (BDS-BIND)
-           (t (return T))))))

src/cmp/cmpvar.lsp

@@ -37,7 +37,7 @@
                 (last-form (car (last args))))
                (VAR (c1form-arg 0 x))
                (t x))))
-    (and (not (form-causes-side-effect form))
+    (and (not (c1form-side-effects form))
          (or (< (var-ref var) 1)
              (and (= (var-ref var) 1)
                   (eq var (last-form body))

src/cmp/load.lsp.in

@@ -10,7 +10,6 @@
     "src:cmp;cmptype-arith.lsp"
     "src:cmp;cmppolicy.lsp"
     ;; Internal representation
-    "src:cmp;cmpmach.lsp"
     "src:cmp;cmprefs.lsp"
     "src:cmp;cmplocs.lsp"
     ;; Environment
@@ -27,14 +26,10 @@
     "src:cmp;cmpform.lsp"
     "src:cmp;cmpvar.lsp"
     "src:cmp;cmpfun.lsp"
-    "src:cmp;cmpinline.lsp"
     ;; Types
     "src:cmp;cmptype-prop.lsp"
     "src:cmp;cmptype.lsp"
     "src:cmp;cmptype-assert.lsp"
-    ;; Abstract C machine
-    "src:cmp;cmpc-wt.lsp"
-    "src:cmp;cmpc-inliner.lsp"
     ;; AST building pass
     "src:cmp;cmppass1-data.lsp"
     "src:cmp;cmppass1-top.lsp"
@@ -48,36 +43,45 @@
     "src:cmp;cmppass1-ffi.lsp"
     ;; Type propagation pass
     "src:cmp;cmpprop.lsp"
+    "src:cmp;cmpprop-num.lsp"
+    ;; C/C++ backend
+    "src:cmp;cmpbackend-cxx;cmpc-util.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-mach.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-wt.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-inl-sysfun.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-opt-ct.lsp"
+    "src:cmp;cmpbackend-cxx;cmpc-opt-printer.lsp"
     ;; Code generation pass
-    "src:cmp;cmppass2-data.lsp"
-    "src:cmp;cmppass2-top.lsp"
-    "src:cmp;cmppass2-stack.lsp"
-    "src:cmp;cmppass2-special.lsp"
-    "src:cmp;cmppass2-exit.lsp"
-    "src:cmp;cmppass2-cont.lsp"
-    "src:cmp;cmppass2-eval.lsp"
-    "src:cmp;cmppass2-call.lsp"
-    "src:cmp;cmppass2-var.lsp"
-    "src:cmp;cmppass2-loc.lsp"
-    "src:cmp;cmppass2-fun.lsp"
-    "src:cmp;cmppass2-ffi.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-data.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-top.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-stack.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-special.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-exit.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-cont.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-eval.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-call.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-var.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-loc.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-fun.lsp"
+    "src:cmp;cmpbackend-cxx;cmppass2-ffi.lsp"
+    "src:cmp;cmpbackend-cxx;cmpbackend-cxx.lsp"
     ;; Optimizations
-    "src:cmp;cmpct.lsp"
     "src:cmp;cmpmap.lsp"
-    "src:cmp;cmpnum.lsp"
     "src:cmp;cmpname.lsp"
     "src:cmp;cmpopt.lsp"
-    "src:cmp;cmpopt-bits.lsp"
+    "src:cmp;cmpopt-num.lsp"
     "src:cmp;cmpopt-clos.lsp"
     "src:cmp;cmpopt-constant.lsp"
     "src:cmp;cmpopt-cons.lsp"
-    "src:cmp;cmpopt-printer.lsp"
     "src:cmp;cmpopt-sequence.lsp"
     "src:cmp;cmpopt-type.lsp"
     "src:cmp;cmpclos.lsp"               ;unused
     "src:cmp;cmpstructures.lsp"         ;unused
     "src:cmp;cmparray.lsp"
-    "src:cmp;sysfun.lsp"
     ;; Other
     "src:cmp;cmpos-run.lsp"
     "src:cmp;cmpos-features.lsp"