From 79ee29aac113d02e9d8f330961e7ef795729037a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Tue, 6 Dec 2016 21:47:10 -0500 Subject: [PATCH] launch-program: avoid consing by run-time append Replace ugly runtime append by a nicer read-time append. --- uiop/launch-program.lisp | 54 +++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/uiop/launch-program.lisp b/uiop/launch-program.lisp index 8c375d776..8c274a12b 100644 --- a/uiop/launch-program.lisp +++ b/uiop/launch-program.lisp @@ -540,6 +540,9 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object." (error-output (%normalize-io-specifier error-output :error-output)) #+(and allegro os-windows) (interactive (%interactivep input output error-output)) (command (%normalize-command command)))) + #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl) + (let ((program (car command)) + #-allegro (arguments (cdr command)))) #-(or allegro mkcl sbcl) (with-current-directory (directory)) (multiple-value-bind #+(or abcl clozure cmucl sbcl scl) (process) @@ -547,34 +550,29 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object." #+ecl (stream code process) #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) #+mkcl (stream process code) - (apply - #+abcl #'sys:run-program - #+allegro 'excl:run-shell-command - #+(and allegro os-unix) (coerce (cons (first command) command) 'vector) - #+(and allegro os-windows) command - #+clozure 'ccl:run-program - #+(or cmucl ecl scl) 'ext:run-program - #+lispworks 'system:run-shell-command - #+lispworks (cons "/usr/bin/env" command) ; LW wants a full path - #+mkcl 'mk-ext:run-program - #+sbcl 'sb-ext:run-program - (append - #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car command) ,(cdr command)) - `(:input ,input :output ,output - #.(or #+(or allegro lispworks) :error-output :error) ,error-output - :wait nil :element-type ,element-type :external-format ,external-format - :if-input-does-not-exist :error - :if-output-exists :append - #-(or allegro lispworks) :if-error-exists - #+(or allegro lispworks) :if-error-output-exists :append - :allow-other-keys t) - #+allegro `(:directory ,directory) - #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide)) - #+lispworks `(:save-exit-status t) - #+mkcl `(:directory ,(native-namestring directory)) - #+sbcl `(:search t) - #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys - #+sbcl (if directory keys (remove-plist-key :directory keys))))) + #.`(apply + #+abcl 'sys:run-program + #+allegro ,@'('excl:run-shell-command + #+os-unix (coerce (cons program command) 'vector) + #+os-windows command) + #+clozure 'ccl:run-program + #+(or cmucl ecl scl) 'ext:run-program + #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed + #+mkcl 'mk-ext:run-program + #+sbcl 'sb-ext:run-program + #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments) + :input input :if-input-does-not-exist :error + :output output :if-output-exists :append + ,(or #+(or allegro lispworks) :error-output :error) error-output + ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append + :wait nil :element-type element-type :external-format external-format + :allow-other-keys t + #+allegro ,@`(:directory directory + #+os-windows ,@'(:show-window (if interactive nil :hide))) + #+lispworks ,@'(:save-exit-status t) + #+mkcl ,@'(:directory (native-namestring directory)) + #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys + #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys))))) (labels ((prop (key value) (setf (slot-value process-info key) value))) #+allegro (cond -- GitLab