From f127ffb824f556d17519defe10fcfc8935711ef9 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" <rpgoldman@gmail.com> Date: Mon, 17 Mar 2014 11:22:59 -0500 Subject: [PATCH] Patch from Jean-Claude Beaudoin adding MKCL support. --- Makefile | 3 ++ bundle.lisp | 75 ++++++++++++++++++++++++++++-------- footer.lisp | 2 +- source-registry.lisp | 2 +- test/dll-test.lisp | 10 +++++ test/dll-user.lisp | 6 +++ test/hello-world-example.asd | 15 ++++++++ test/hello.lisp | 3 +- test/make-hello-world.lisp | 2 +- test/monodll-1.lisp | 10 +++++ test/monodll.lisp | 10 +++++ test/script-support.lisp | 3 ++ test/test-bundle.script | 20 ++++++++++ test/test-program.script | 22 ++++++++++- uiop/common-lisp.lisp | 2 +- uiop/driver.lisp | 2 + uiop/filesystem.lisp | 2 +- uiop/image.lisp | 7 ++-- uiop/lisp-build.lisp | 7 ++-- uiop/os.lisp | 2 +- uiop/pathname.lisp | 13 ++++--- uiop/run-program.lisp | 45 +++++++++++----------- uiop/utility.lisp | 4 +- 23 files changed, 204 insertions(+), 63 deletions(-) diff --git a/Makefile b/Makefile index 2f290f3f9..ee5d24198 100644 --- a/Makefile +++ b/Makefile @@ -60,7 +60,9 @@ all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) # Making ASDF itself should be our first, default, target: build/asdf.lisp: $(all_lisp) mkdir -p build + rm -f $@ cat $(all_lisp) > $@ + chmod -w $@ # try to prevent accidental editing. # This quickly locates such mistakes as unbalanced parentheses: load: build/asdf.lisp @@ -120,6 +122,7 @@ clean: fi; \ done rm -rf build/ LICENSE test/try-reloading-dependency.asd test/hello-world-example asdf.lisp + rm -rf test/hello-world-example.exe test/mkcl_*.dll # needed only on MS-Windows rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap ${MAKE} -C doc clean diff --git a/bundle.lisp b/bundle.lisp index 2ab256044..ff32ecf19 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -26,9 +26,7 @@ ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) - #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) - #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files))) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its @@ -47,6 +45,20 @@ itself.")) ;; operation on a system and its dependencies ((prologue-code :accessor prologue-code) (epilogue-code :accessor epilogue-code))) + #+mkcl + (defclass program (bundle-system) + ( + (prologue-code :initarg :prologue-code :initform nil :accessor prologue-code) + (epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code) + (prefix-lisp-object-files :initarg :prefix-lisp-object-files + :initform nil :accessor program-prefix-lisp-object-files) + (postfix-lisp-object-files :initarg :postfix-lisp-object-files + :initform nil :accessor program-postfix-lisp-object-files) + (object-files :initarg :object-files + :initform nil :accessor program-object-files) + (extra-build-args :initarg :extra-build-args + :initform nil :accessor program-extra-build-args))) + (defmethod prologue-code ((x t)) nil) (defmethod epilogue-code ((x t)) nil) @@ -77,7 +89,7 @@ itself.")) ;; operation on a system and its dependencies ((bundle-type :initform :fasl))) (defclass prepare-fasl-op (sideway-operation) - ((sideway-operation :initform #+ecl 'load-fasl-op #-ecl 'load-op :allocation :class))) + ((sideway-operation :initform #+(or ecl mkcl) 'load-fasl-op #-(or ecl mkcl) 'load-op :allocation :class))) (defclass lib-op (link-op gather-op non-propagating-operation) ((bundle-type :initform :lib)) @@ -123,7 +135,7 @@ itself.")) ;; operation on a system and its dependencies (defclass image-op (monolithic-bundle-op selfward-operation #+ecl link-op #+(or ecl mkcl) gather-op) ((bundle-type :initform :image) - (selfward-operation :initform '(#-ecl load-op) :allocation :class)) + (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) (defclass program-op (image-op) @@ -139,8 +151,9 @@ itself.")) ;; operation on a system and its dependencies ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) ((member :image) "image") - ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) + ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((member :lib :static-library) (cond ((os-unix-p) "a") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (defun bundle-output-files (o c) @@ -189,14 +202,14 @@ itself.")) ;; operation on a system and its dependencies (unless name-suffix-p (setf (slot-value instance 'name-suffix) (unless (typep instance 'program-op) - (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames + (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&key lisp-files prologue-code epilogue-code + (destructuring-bind (&key #-mkcl lisp-files prologue-code epilogue-code &allow-other-keys) (operation-original-initargs instance) (setf (prologue-code instance) prologue-code (epilogue-code instance) epilogue-code) - #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) + #-(or ecl mkcl) (assert (null (or lisp-files epilogue-code prologue-code))) #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) (setf (bundle-op-build-args instance) (remove-plist-keys @@ -208,7 +221,9 @@ itself.")) ;; operation on a system and its dependencies (declare (ignorable type)) (or #+ecl (or (equalp type (compile-file-type :type :object)) (equalp type (compile-file-type :type :static-library))) - #+mkcl (equalp type (compile-file-type :fasl-p nil)) + #+mkcl (or (equalp type (compile-file-type :fasl-p nil)) + #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW + #+(and windows (not (or mingw32 mingw64))) (equalp type "lib")) #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) (defgeneric* (trivial-system-p) (component)) @@ -344,7 +359,15 @@ itself.")) ;; operation on a system and its dependencies nil) (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) - nil)) + nil) + + #+mkcl + (defmethod perform ((o fasl-op) (c prebuilt-system)) + nil) + + #+mkcl + (defmethod output-files ((o lib-op) (c prebuilt-system)) + (list (prebuilt-system-static-library c)))) ;;; @@ -361,6 +384,7 @@ itself.")) ;; operation on a system and its dependencies (library (second inputs)) (asd (first (output-files o s))) (name (if (and fasl asd) (pathname-name asd) (return-from perform))) + (version (component-version s)) (dependencies (if (operation-monolithic-p o) (remove-if-not 'builtin-system-p @@ -388,8 +412,9 @@ itself.")) ;; operation on a system and its dependencies (machine-type) (software-version)) (let ((*package* (find-package :asdf-user))) - (pprint `(defsystem ,name + (pprint `(asdf/defsystem:defsystem ,name :class prebuilt-system + :version ,version :depends-on ,depends-on :components ((:compiled-file ,(pathname-name fasl))) ,@(when library `(:lib ,(file-namestring library)))) @@ -430,7 +455,7 @@ itself.")) ;; operation on a system and its dependencies (asdf:load-system :precompiled-asdf-utils) |# -#+(or ecl mkcl) +#+ecl (with-upgradability () (defun uiop-library-file () (or (and (find-system :uiop nil) @@ -447,8 +472,10 @@ itself.")) ;; operation on a system and its dependencies (and (system-source-directory :asdf) (plan-operates-on-p plan '("asdf")))) (pushnew (uiop-library-file) files :test 'pathname-equal)) - files)) + files))) +#+(or ecl mkcl) +(with-upgradability () (defun register-pre-built-system (name) (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) @@ -477,14 +504,28 @@ itself.")) ;; operation on a system and its dependencies #+mkcl (with-upgradability () + (defmethod perform ((o dll-op) (s system)) + (apply #'compiler::build-shared-library (output-file o s) + :lisp-object-files (input-files o s) (bundle-op-build-args o))) + (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (output-file o c) + (apply #'compiler::build-static-library (output-file o s) :lisp-object-files (input-files o s) (bundle-op-build-args o))) (defmethod perform ((o basic-fasl-op) (s system)) - (apply #'compiler::build-bundle (output-file o c) ;; second??? + (apply #'compiler::build-bundle (output-file o s) :lisp-object-files (input-files o s) (bundle-op-build-args o))) + (defmethod perform ((o program-op) (s system)) + (apply #'compiler::build-program (output-file o s) + :lisp-object-files (append (program-prefix-lisp-object-files s) + (input-files o s) + (program-postfix-lisp-object-files s)) + :object-files (program-object-files s) + :prologue-code (prologue-code s) + :epilogue-code (epilogue-code s) + (program-extra-build-args s))) + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate 'deliver-asd-op system args))) diff --git a/footer.lisp b/footer.lisp index f824748c7..f90c8ef47 100644 --- a/footer.lisp +++ b/footer.lisp @@ -20,7 +20,7 @@ #+(or ecl mkcl) (progn - (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) + (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car) #+(or (and ecl win32) (and mkcl windows)) (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) diff --git a/source-registry.lisp b/source-registry.lisp index 70bac4b96..ee83e48d7 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -155,8 +155,8 @@ system names to pathnames of .asd files") (defun wrapping-source-registry () `(:source-registry #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) - #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) :inherit-configuration + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) #+cmu (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-source-registry () diff --git a/test/dll-test.lisp b/test/dll-test.lisp index ef251c3ee..5bf1f8633 100644 --- a/test/dll-test.lisp +++ b/test/dll-test.lisp @@ -9,3 +9,13 @@ int sample_function() return 42; } ") + +#+mkcl +(ffi:clines " +extern MKCL_DLLEXPORT int sample_function(void); + +int sample_function(void) +{ + return 42; +} +") diff --git a/test/dll-user.lisp b/test/dll-user.lisp index a60d529a4..7bcc0c079 100644 --- a/test/dll-user.lisp +++ b/test/dll-user.lisp @@ -1,4 +1,10 @@ (defpackage :test-asdf/dll-user (:use)) ;; dummy, for package-system dependencies. (in-package :test-package) + +#+(and mkcl windows) +(ffi:clines "extern __declspec(dllimport) int sample_function(void);") +#-(and mkcl windows) +(ffi:clines "extern int sample_function(void);") + (ffi:def-function "sample_function" () :returning :int) diff --git a/test/hello-world-example.asd b/test/hello-world-example.asd index c1c5eaad5..87352d791 100644 --- a/test/hello-world-example.asd +++ b/test/hello-world-example.asd @@ -1,7 +1,22 @@ ;; Example executable program +#-mkcl (defsystem :hello-world-example :build-operation program-op :entry-point "hello:entry-point" :depends-on (:uiop) :components ((:file "hello"))) + +#+mkcl +(defsystem :hello-world-example + :class asdf/bundle::program + :build-operation program-op + :entry-point "hello:entry-point" + :depends-on (:uiop) + :components ((:file "hello")) + :prefix-lisp-object-files #.(list (namestring (truename (translate-logical-pathname #P"SYS:cmp.a")))) + :extra-build-args #.(or #-windows '(:use-mkcl-shared-libraries nil)) + :epilogue-code (progn + (setq uiop/image:*image-dumped-p* :executable) + (uiop/image:restore-image :entry-point (read-from-string "hello:entry-point")))) + diff --git a/test/hello.lisp b/test/hello.lisp index 7bcdaf9c9..edae1073a 100644 --- a/test/hello.lisp +++ b/test/hello.lisp @@ -12,4 +12,5 @@ t) (defun entry-point () - (apply 'main *command-line-arguments*)) + (apply 'main *command-line-arguments*) + #+mkcl (quit)) diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index a51f7fac6..117ab3410 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -2,7 +2,7 @@ #+lispworks (lispworks:load-all-patches) (load (make-pathname :name "script-support" :defaults *load-pathname*)) (load-asdf) -#+ecl (require :cmp) +#+(or ecl mkcl) (require :cmp) (asdf-test::register-directory asdf-test::*asdf-directory*) ;; we need UIOP, and ECL can dump. (asdf-test::register-directory asdf-test::*uiop-directory*) diff --git a/test/monodll-1.lisp b/test/monodll-1.lisp index f4cfa5faf..3de4d355b 100644 --- a/test/monodll-1.lisp +++ b/test/monodll-1.lisp @@ -9,3 +9,13 @@ int always_7() return 7; } ") + +#+mkcl +(ffi:clines " +extern MKCL_DLLEXPORT int always_7(void); + +int always_7(void) +{ + return 7; +} +") diff --git a/test/monodll.lisp b/test/monodll.lisp index 1984900c3..68b94f5df 100644 --- a/test/monodll.lisp +++ b/test/monodll.lisp @@ -9,3 +9,13 @@ int always_42() return 6*always_7(); } ") + +#+mkcl +(ffi:clines " +extern MKCL_DLLEXPORT int always_42(void); + +int always_42(void) +{ + return 6*always_7(); +} +") diff --git a/test/script-support.lisp b/test/script-support.lisp index 0ab83108e..857f8a594 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -142,6 +142,9 @@ Some constraints: (cond ((equal x y) (format t "~S and~% ~S both evaluate to same path:~% ~S~%" qx qy x)) + #+mkcl + ((acall :pathname-equal x y) + (format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~% ~S~%and~% ~S~%" qx qy x y)) ((acall :pathname-equal x y) (warn "These two expressions yield pathname-equal yet not equal path~%~ the first expression ~S yields this:~% ~S~% ~S~% diff --git a/test/test-bundle.script b/test/test-bundle.script index 5669c83a3..95f6be823 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -61,3 +61,23 @@ (si:load-foreign-module (first (output-files 'monolithic-dll-op :test-asdf/monodll))) (operate 'load-op :test-asdf/monodll-user) (assert-equal (test-package::always-42) 42)) + +;;; Test DLL-op and monolithic-dll-op on MKCL. +#+mkcl +(progn + (require 'sockets) ;; Test the pre-compiled system feature + (operate 'dll-op :test-asdf/dll-test) + (let ((dll (first (output-files 'dll-op :test-asdf/dll-test)))) + (si:load-foreign-module dll) + (let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll)))) + (operate 'load-op :test-asdf/dll-user))) + (assert (= (test-package::sample-function) 42)) + (let* #+windows ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1))) + (compiler::*builder-default-libraries* (list (namestring lib)))) + #-windows () + (operate 'monolithic-dll-op :test-asdf/monodll)) + (let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll)))) + (si:load-foreign-module dll) + (let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll)))) + (operate 'load-op :test-asdf/monodll-user))) + (assert-equal (test-package::always-42) 42)) diff --git a/test/test-program.script b/test/test-program.script index 4d6ba6f0f..b65cb8a5c 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -2,7 +2,7 @@ (DBG :foo (current-lisp-file-pathname)) -(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks sbcl) t +(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t #+cmu nil ;; uncomment if you have 32-bit gcc support - or can autodetect #+clisp (version-satisfies (first (split-string (lisp-implementation-version) :separator " ")) @@ -13,6 +13,8 @@ (defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example))) (assert (absolute-pathname-p exe)) +#-mkcl +(progn ;; Try to load lisp-invocation from xcvb (setf *central-registry* (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF @@ -35,7 +37,23 @@ (symbol-call :lisp-invocation :lisp-invocation-arglist :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))) :output t :error-output :output :input nil)) - 0) + 0)) + +#+mkcl +(progn + (operate 'program-op :hello-world-example) + #+windows + (let* + ((dll-orig (merge-pathnames (make-pathname :name (mkcl:str+ "mkcl_" (lisp-implementation-version)) :type "dll") + (si::self-truename))) + (exe (car (asdf::output-files 'program-op :hello-world-example))) + (exe-dir (make-pathname :name nil :type nil :defaults exe)) + (dll-dest (merge-pathnames exe-dir dll-orig))) + ;; make sure mkcl-X.X.X.dll is the same directory as the executable + (copy-file dll-orig dll-dest))) + + + (assert (probe-file* exe)) (assert-equal (run-program `(,(native-namestring exe)) :output :lines) diff --git a/uiop/common-lisp.lisp b/uiop/common-lisp.lisp index aa2e4efad..4e156063b 100644 --- a/uiop/common-lisp.lisp +++ b/uiop/common-lisp.lisp @@ -30,7 +30,7 @@ ;;;; Early meta-level tweaks -#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl) +#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) (eval-when (:load-toplevel :compile-toplevel :execute) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. diff --git a/uiop/driver.lisp b/uiop/driver.lisp index 4d342d2ad..f36e02df0 100644 --- a/uiop/driver.lisp +++ b/uiop/driver.lisp @@ -13,3 +13,5 @@ :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) + +#+mkcl (provide :uiop) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index f42c3f6de..392bb3956 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -598,7 +598,7 @@ in an atomic way if the implementation allows." `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) diff --git a/uiop/image.lisp b/uiop/image.lisp index 47bb43b94..c7100266b 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -118,7 +118,7 @@ This is designed to abstract away the implementation specific quit forms." (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) - #+ecl + #+(or ecl mkcl) (let* ((top (si:ihs-top)) (repeats (if count (min top count) top)) (backtrace (loop :for ihs :from 0 :below top @@ -233,9 +233,10 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* + #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) @@ -266,7 +267,7 @@ Otherwise, return NIL." ;; NB: not currently available on ABCL, Corman, Genera, MCL, MKCL (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) - #+ecl (si:argv 0))) + #+ecl (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. (getenvp "__CL_ARGV0")))) diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index b42165d31..adab079ba 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -62,16 +62,17 @@ This can help you produce more deterministic output for FASLs.")) "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or clisp clozure cmu ecl sbcl scl) + #-(or clisp clozure cmu ecl mkcl sbcl scl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) #+clozure (ccl:declaration-information 'optimize nil) - #+(or clisp cmu ecl sbcl scl) + #+(or clisp cmu ecl mkcl sbcl scl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) #.`(loop :for x :in settings ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+mkcl '(:for v :in '(si::*speed* si::*space* si::*safety* si::*debug*)) #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity))) :for y = (or #+clisp (gethash x system::*optimize*) - #+(or ecl) (symbol-value v) + #+(or ecl mkcl) (symbol-value v) #+(or cmu scl) (funcall f c::*default-cookie*) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) diff --git a/uiop/os.lisp b/uiop/os.lisp index 6d7afebe5..2f26bc818 100644 --- a/uiop/os.lisp +++ b/uiop/os.lisp @@ -49,7 +49,7 @@ keywords explicitly." (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" (or #+abcl (featurep :windows) - #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) + #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t)) (defun os-genera-p () "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index edd157717..8bb82ac8a 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -91,8 +91,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu genera lispworks mkcl sbcl scl) :unspecific - #+(or clisp ecl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil + #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific + #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key (directory nil) @@ -190,8 +190,9 @@ when merging, making or parsing pathnames" ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) - #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil - :host (or #+cmu lisp::*unix-host*) + #.`(make-pathname* :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl unix) :unspecific) + :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost") #+scl ,@'(:scheme nil :scheme-specific-part nil :username nil :password nil :parameters nil :query nil :fragment nil) ;; the default shouldn't matter, but we really want something physical @@ -224,11 +225,11 @@ when merging, making or parsing pathnames" (or (and (null p1) (null p2)) (and (pathnamep p1) (pathnamep p2) (and (=? pathname-host) - (=? pathname-device) + #-(and mkcl unix) (=? pathname-device) (=? normalize-pathname-directory-component pathname-directory) (=? pathname-name) (=? pathname-type) - (=? pathname-version))))))) + #-mkcl (=? pathname-version))))))) (defun absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index 0863b1d9e..bae693bf8 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -341,6 +341,7 @@ for the implementation's underlying run-program function" #+os-unix (list command) #+os-windows (string + #+mkcl (list "cmd" '#:/c command) ;; NB: We do NOT add cmd /c here. You might want to. #+(or allegro clisp) command ;; On ClozureCL for Windows, we assume you are using @@ -350,7 +351,7 @@ for the implementation's underlying run-program function" ;; NB: On other Windows implementations, this is utterly bogus ;; except in the most trivial cases where no quoting is needed. ;; Use at your own risk. - #-(or allegro clisp clozure) (list "cmd" "/c" command)) + #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command)) #+os-windows (list #+allegro (escape-windows-command command) @@ -377,8 +378,8 @@ argument to pass to the internal RUN-PROGRAM" ((eql :interactive) #+allegro nil #+clisp :terminal - #+(or clozure cmu ecl sbcl scl) t) - #+(or allegro clozure cmu ecl lispworks sbcl scl) + #+(or clozure cmu ecl mkcl sbcl scl) t) + #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl) ((eql :output) (if (eq role :error-output) :output @@ -409,12 +410,12 @@ to be normalized by %NORMALIZE-IO-SPECIFIER. It returns a process-info plist with possible keys: PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." ;; NB: these implementations have unix vs windows set at compile-time. - (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists)) + (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists)) (assert (not (and wait (member :stream (list input output error-output))))) - #-(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) + #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl) (progn command keys directory (error "run-program not available")) - #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) + #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl) (let* ((%command (%normalize-command command)) (%input (%normalize-io-specifier input :input)) (%output (%normalize-io-specifier output :output)) @@ -434,7 +435,7 @@ It returns a process-info plist with possible keys: #+os-windows :show-window #+os-windows (if interactive nil :hide) :allow-other-keys t keys)) #-allegro - (with-current-directory (#-sbcl directory) + (with-current-directory (#-(or sbcl mkcl) directory) #+clisp (flet ((run (f x &rest args) (multiple-value-list @@ -446,11 +447,11 @@ It returns a process-info plist with possible keys: #+os-windows (string (run 'ext:run-shell-command %command)) (list (run 'ext:run-program (car %command) :arguments (cdr %command))))) - #+(or clozure cmu ecl sbcl scl) - (#-ecl progn #+ecl multiple-value-list + #+(or clozure cmu ecl mkcl sbcl scl) + (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list (apply '#+(or cmu ecl scl) ext:run-program - #+clozure ccl:run-program #+sbcl sb-ext:run-program + #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program (car %command) (cdr %command) :input %input :output %output @@ -458,7 +459,7 @@ It returns a process-info plist with possible keys: :wait wait :allow-other-keys t (append - #+(or clozure cmu sbcl scl) + #+(or clozure cmu mkcl sbcl scl) `(:if-input-does-not-exist ,if-input-does-not-exist :if-output-exists ,if-output-exists :if-error-exists ,if-error-output-exists) @@ -525,8 +526,8 @@ It returns a process-info plist with possible keys: #+clozure (ccl:external-process-error-stream process*) #+(or cmu scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) - #+ecl - (destructuring-bind (stream code process) process* + #+(or ecl mkcl) + (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process* (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((zerop mode)) @@ -553,8 +554,9 @@ It returns a process-info plist with possible keys: #+clozure (ccl::external-process-pid process) #+ecl (si:external-process-pid process) #+(or cmu scl) (ext:process-pid process) + #+mkcl (mkcl:process-id process) #+sbcl (sb-ext:process-pid process) - #-(or allegro cmu sbcl scl) (error "~S not implemented" '%process-info-pid))) + #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid))) (defun %wait-process-result (process-info) (or (getf process-info :exit-code) @@ -578,7 +580,8 @@ It returns a process-info plist with possible keys: (system:pipe-exit-status stream :wait t) (if-let ((f (find-symbol* :pid-exit-status :system nil))) (funcall f process :wait t))) - #+sbcl (sb-ext:process-exit-code process))))) + #+sbcl (sb-ext:process-exit-code process) + #+mkcl (mkcl:join-process process))))) (defun %check-result (exit-code &key command process ignore-error-status) (unless ignore-error-status @@ -678,7 +681,7 @@ It returns a process-info plist with possible keys: (defun %use-run-program (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %run-program - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) (progn command keys input output error-output ignore-error-status ;; ignore (error "Not implemented on this platform")) @@ -788,11 +791,7 @@ It returns a process-info plist with possible keys: (ext:system %command)) #+gcl (system:system %command) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) - #+mkcl ;; PROBABLY BOGUS -- ask jcb - (multiple-value-bind (io process exit-code) - (mkcl:run-program #+windows %command #+windows () - #-windows "/bin/sh" #-windows (list "-c" %command) - :input t :output t)) + #+mkcl (mkcl:system %command) #+xcl (system:%run-shell-command %command)))) (defun %use-system (command &rest keys @@ -871,7 +870,7 @@ RUN-PROGRAM returns 3 values: 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable ignore-error-status)) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell @@ -879,7 +878,7 @@ or an indication of failure via the EXIT-CODE of the process" #+clisp (eq error-output :interactive) #+(or abcl clisp) (eq :error-output :output) #+(and lispworks os-unix) (%interactivep input output error-output) - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t) + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t) '%use-system '%use-run-program) command :input (default input inputp output) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 230c0c76f..5b2406164 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -526,10 +526,10 @@ with later being determined by a lexicographical comparison of minor numbers." #+clisp 'system::$format-control #+clozure 'ccl::format-control #+(or cmu scl) 'conditions::format-control - #+ecl 'si::format-control + #+(or ecl mkcl) 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) -- GitLab