Commit 79ee29aa authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

launch-program: avoid consing by run-time append

Replace ugly runtime append by a nicer read-time append.
parent 9edd4725
...@@ -540,6 +540,9 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object." ...@@ -540,6 +540,9 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object."
(error-output (%normalize-io-specifier error-output :error-output)) (error-output (%normalize-io-specifier error-output :error-output))
#+(and allegro os-windows) (interactive (%interactivep input output error-output)) #+(and allegro os-windows) (interactive (%interactivep input output error-output))
(command (%normalize-command command)))) (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)) #-(or allegro mkcl sbcl) (with-current-directory (directory))
(multiple-value-bind (multiple-value-bind
#+(or abcl clozure cmucl sbcl scl) (process) #+(or abcl clozure cmucl sbcl scl) (process)
...@@ -547,34 +550,29 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object." ...@@ -547,34 +550,29 @@ LAUNCH-PROGRAM returns a PROCESS-INFO object."
#+ecl (stream code process) #+ecl (stream code process)
#+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
#+mkcl (stream process code) #+mkcl (stream process code)
(apply #.`(apply
#+abcl #'sys:run-program #+abcl 'sys:run-program
#+allegro 'excl:run-shell-command #+allegro ,@'('excl:run-shell-command
#+(and allegro os-unix) (coerce (cons (first command) command) 'vector) #+os-unix (coerce (cons program command) 'vector)
#+(and allegro os-windows) command #+os-windows command)
#+clozure 'ccl:run-program #+clozure 'ccl:run-program
#+(or cmucl ecl scl) 'ext:run-program #+(or cmucl ecl scl) 'ext:run-program
#+lispworks 'system:run-shell-command #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
#+lispworks (cons "/usr/bin/env" command) ; LW wants a full path #+mkcl 'mk-ext:run-program
#+mkcl 'mk-ext:run-program #+sbcl 'sb-ext:run-program
#+sbcl 'sb-ext:run-program #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
(append :input input :if-input-does-not-exist :error
#+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car command) ,(cdr command)) :output output :if-output-exists :append
`(:input ,input :output ,output ,(or #+(or allegro lispworks) :error-output :error) error-output
#.(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 :wait nil :element-type element-type :external-format external-format
:if-input-does-not-exist :error :allow-other-keys t
:if-output-exists :append #+allegro ,@`(:directory directory
#-(or allegro lispworks) :if-error-exists #+os-windows ,@'(:show-window (if interactive nil :hide)))
#+(or allegro lispworks) :if-error-output-exists :append #+lispworks ,@'(:save-exit-status t)
:allow-other-keys t) #+mkcl ,@'(:directory (native-namestring directory))
#+allegro `(:directory ,directory) #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
#+(and allegro os-windows) `(:show-window ,(if interactive nil :hide)) #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
#+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)))))
(labels ((prop (key value) (setf (slot-value process-info key) value))) (labels ((prop (key value) (setf (slot-value process-info key) value)))
#+allegro #+allegro
(cond (cond
......
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