run-program: provide simple interface run-program-inner

Both run-program and run-program-inner work on same interface
si:spawn-subprocess.

src/c/unixsys.d

@@ -626,13 +626,9 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ,
     } else {
       pid = ecl_make_fixnum(child_pid);
     }
-    set_external_process_pid(process, pid);
     {
-      /* This guarantees that the child process does not exit
-       * before we have created the process structure. If we do not
-       * do this, the SIGPIPE signal may arrive before
-       * set_external_process_pid() and our call to external-process-wait
-       * down there may block indefinitely. */
+      /* This guarantees that the child process does not exit before
+       * we have created the process structure. */
       char sync[1];
       close(pipe_fd[0]);
       while (write(pipe_fd[1], sync, 1) < 1) {
@@ -647,57 +643,12 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ,
   }
 #else  /* NACL */
   {
-    FElibc_error("ext::run-program not implemented",1);
+    FElibc_error("ext::run-program-inner not implemented",1);
     @(return ECL_NIL);
   }
 #endif
-  if (Null(pid)) {
-    if (parent_write) close(parent_write);
-    if (parent_read) close(parent_read);
-    if (parent_error) close(parent_error);
-    parent_write = 0;
-    parent_read = 0;
-    parent_error = 0;
-    FEerror("Could not spawn subprocess to run ~S.", 1, command);
-  }
-  if (parent_write > 0) {
-    stream_write = ecl_make_stream_from_fd(command, parent_write,
-                                           ecl_smm_output, 8,
-                                           ECL_STREAM_DEFAULT_FORMAT,
-                                           external_format);
-  } else {
-    parent_write = 0;
-    stream_write = cl_core.null_stream;
-  }
-  if (parent_read > 0) {
-    stream_read = ecl_make_stream_from_fd(command, parent_read,
-                                          ecl_smm_input, 8,
-                                          ECL_STREAM_DEFAULT_FORMAT,
-                                          external_format);
-  } else {
-    parent_read = 0;
-    stream_read = cl_core.null_stream;
-  }
-  if (parent_error > 0) {
-    stream_error = ecl_make_stream_from_fd(command, parent_error,
-                                           ecl_smm_input, 8,
-                                           ECL_STREAM_DEFAULT_FORMAT,
-                                           external_format);
-  } else {
-    parent_error = 0;
-    stream_error = cl_core.null_stream;
-  }
-  ecl_structure_set(process, @'ext::external-process', 1, input);
-  ecl_structure_set(process, @'ext::external-process', 2, output);
-  ecl_structure_set(process, @'ext::external-process', 3, error);
-
-  if (!Null(wait)) {
-    exit_status = si_external_process_wait(2, process, ECL_T);
-    exit_status = ecl_nth_value(the_env, 1);
-  }
-  @(return ((parent_read || parent_write)?
-            cl_make_two_way_stream(stream_read, stream_write) :
-            ECL_NIL)
-    exit_status
-    process);
+  @(return pid
+    ecl_make_fixnum(parent_write)
+    ecl_make_fixnum(parent_read)
+    ecl_make_fixnum(parent_error))
 }

src/cmp/cmpos-features.lsp

@@ -21,16 +21,14 @@
               while line
               collect line)))
     (handler-case
-        (multiple-value-bind (stream process)
-            (ext:run-program command args :input nil :output :stream :error :output)
-          (let ((lines (collect-lines stream)))
-            (cond ((null file)
-                   lines)
-                  ((probe-file file)
-                   (with-open-file (s file :direction :input)
-                     (collect-lines s)))
-                  (t
-                   (warn "Unable to find file ~A" file)))))
+        (let ((lines (collect-lines (si:run-program-inner command args nil))))
+          (cond ((null file)
+                 lines)
+                ((probe-file file)
+                 (with-open-file (s file :direction :input)
+                   (collect-lines s)))
+                (t
+                 (warn "Unable to find file ~A" file))))
       (error (c)
         (format t "~&;;; Unable to execute program ~S~&;;; Condition~&;;; ~A"
                 command c)))))

src/cmp/proclamations.lsp

@@ -1329,6 +1329,10 @@
               (values (or null two-way-stream)
                       (or null integer)
                       ext:external-process))
+(proclamation si:run-program-inner (string (or list string) list)
+              (values two-way-stream integer))
+(proclamation si:spawn-subprocess (string (or list string) list t t t)
+              (values (or null integer) fixnum fixnum fixnum))
 (proclamation ext:terminate-process (t &optional gen-bool) null)
 
 (proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects)

src/h/internal.h

@@ -526,10 +526,12 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock);
 extern void ecl_interrupt_process(cl_object process, cl_object function);
 
 /* unixsys.d */
-extern cl_object si_run_program_internal
-(cl_object command, cl_object argv,
- cl_object input, cl_object output, cl_object error,
- cl_object wait, cl_object environ, cl_object external_format);
+extern cl_object si_run_program_inner
+(cl_object command, cl_object argv, cl_object environ);
+
+extern cl_object si_spawn_subprocess
+(cl_object command, cl_object argv, cl_object environ,
+ cl_object input, cl_object output, cl_object error);
 
 /*
  * Fake several ISO C99 mathematical functions if not available

src/lsp/process.lsp

@@ -104,12 +104,34 @@
                                     :if-exists if-error-exists)))
 
     (let ((progname (si:copy-to-simple-base-string command))
-          (args (prepare-args (cons command argv))))
-      (si:run-program-internal progname args
-                               input output error
-                               wait environ external-format))))
+          (args (prepare-args (cons command argv)))
+          (process (make-external-process)))
+      (multiple-value-bind (pid parent-write parent-read parent-error)
+          (si:spawn-subprocess progname args environ input output error)
+        (unless pid
+          (when parent-write (ff-close parent-write))
+          (when parent-read (ff-close parent-read))
+          (when parent-error (ff-close parent-error))
+          (error "Could not spawn subprocess to run ~S." progname))
 
+        (let ((stream-write
+               (when (< 0 parent-write)
+                 (make-output-stream-from-fd progname parent-write external-format)))
+              (stream-read
+               (when (< 0 parent-read)
+                 (make-input-stream-from-fd progname parent-read external-format)))
+              (stream-error
+               (when (< 0 parent-error)
+                 (make-input-stream-from-fd progname parent-error external-format))))
+          (setf (external-process-pid process) pid
+                (external-process-input process)         (or stream-write (null-stream))
+                (external-process-output process)        (or stream-read  (null-stream))
+                (external-process-error-stream process)  (or stream-error (null-stream)))
 
+          (values (make-two-way-stream (external-process-output process)
+                                       (external-process-input process))
+                  (when wait (nth-value 1 (si:external-process-wait process t)))
+                  process))))))
 
 #+windows
 (defun escape-arg (arg stream)
@@ -141,3 +163,21 @@
        (loop repeat slashes
           do (write-char #\\ stream)))
   (write-char #\" stream))
+
+
+;;; low level interface to descriptors
+(defun make-input-stream-from-fd (name fd external-format)
+  (ffi:c-inline (name fd external-format) (:string :int :object) :object
+                "ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)"
+                :one-liner t))
+
+(defun make-output-stream-from-fd (name fd external-format)
+  (ffi:c-inline (name fd external-format) (:string :int :object) :object
+      "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)"
+      :one-liner t))
+
+(defun null-stream ()
+  (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil))
+
+(ffi:defentry ff-close (:int) (:int "close") :no-interrupts t)
+