Commit f127ffb8 authored by Robert P. Goldman's avatar Robert P. Goldman

Patch from Jean-Claude Beaudoin adding MKCL support.

parent 52bce047
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......
......@@ -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 ()
......
......@@ -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;
}
")
(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)
;; 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"))))
......@@ -12,4 +12,5 @@
t)
(defun entry-point ()
(apply 'main *command-line-arguments*))
(apply 'main *command-line-arguments*)
#+mkcl (quit))
......@@ -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*)
......
......@@ -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;
}
")
......@@ -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();
}
")
......@@ -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~%
......
......@@ -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))
......@@ -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)
......
......@@ -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.
......
......@@ -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)
......@@ -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))
......
......@@ -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"))))
......
......@@ -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))))
......
......@@ -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)?"
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment