Add :directory argument to sb-ext:run-program.

[sbcl.git] / src / code / run-program.lisp

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index bec0abe..7c180ea 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -555,7 +555,8 @@ status slot."
   (search sb-alien:int)
   (envp (* sb-alien:c-string))
   (pty-name sb-alien:c-string)
-  (wait sb-alien:int))
+  (wait sb-alien:int)
+  (pwd sb-alien:c-string))
 
 ;;; FIXME: There shouldn't be two semiredundant versions of the
 ;;; documentation. Since this is a public extension function, the
@@ -617,7 +618,8 @@ status slot."
                     (error :output)
                     (if-error-exists :error)
                     status-hook
-                    (external-format :default))
+                    (external-format :default)
+                    (directory nil directory-p))
   #+sb-doc
   #.(concatenate
      'string
@@ -809,23 +811,26 @@ Users Manual for details about the PROCESS structure."#-win32"
                              (with-args-vec (args-vec simple-args)
                                (with-no-with (#+win32 (environment-vec))
                                  (with-environment-vec (environment-vec)
-                                   (setq child
-                                         #+win32
-                                         (sb-win32::mswin-spawn
-                                          progname
-                                          (with-output-to-string (argv)
-                                            (dolist (arg simple-args)
-                                              (write-string arg argv)
-                                              (write-char #\Space argv)))
-                                          stdin stdout stderr
-                                          search nil wait)
-                                         #-win32
-                                         (without-gcing
+                                   (let ((pwd-string
+                                           (and directory-p (native-namestring directory))))
+                                     (setq child
+                                           #+win32
+                                           (sb-win32::mswin-spawn
+                                            progname
+                                            (with-output-to-string (argv)
+                                              (dolist (arg simple-args)
+                                                (write-string arg argv)
+                                                (write-char #\Space argv)))
+                                            stdin stdout stderr
+                                            search nil wait pwd-string)
+                                           #-win32
+                                           (without-gcing
                                              (spawn progname args-vec
                                                     stdin stdout stderr
                                                     (if search 1 0)
                                                     environment-vec pty-name
-                                                    (if wait 1 0))))
+                                                    (if wait 1 0)
+                                                    pwd-string))))
                                    (unless (minusp child)
                                      (setf proc
                                            (apply
@@ -846,10 +851,15 @@ Users Manual for details about the PROCESS structure."#-win32"
                                      (push proc *active-processes*)))))))
                          ;; Report the error outside the lock.
                          (case child
-                           (-2
-                            (error "Couldn't execute ~S: ~A" progname (strerror)))
                            (-1
-                            (error "Couldn't fork child process: ~A" (strerror)))))))))))
+                            (error "Couldn't fork child process: ~A"
+                                   (strerror)))
+                           (-2
+                            (error "Couldn't execute ~S: ~A"
+                                   progname (strerror)))
+                           (-3
+                            (error "Couldn't change directory to ~S: ~A"
+                                   directory (strerror)))))))))))
         (dolist (fd *close-in-parent*)
           (sb-unix:unix-close fd))
         (unless proc