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