From 3e45a780af32f4d7149406e8bb0513cc6fe28b82 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 4 Aug 1993 11:51:43 +0000
Subject: [PATCH] Moved the fork/exec stuff into C, for ease in porting.

---
 code/run-program.lisp | 174 ++++++++++++++++++++++--------------------
 1 file changed, 93 insertions(+), 81 deletions(-)

diff --git a/code/run-program.lisp b/code/run-program.lisp
index c5caaba9a..4b19a4dba 100644
--- a/code/run-program.lisp
+++ b/code/run-program.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.12 1992/07/28 00:22:58 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.13 1993/08/04 11:51:43 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -299,54 +299,69 @@
       (values name
 	      (system:make-fd-stream master :input t :output t)))))
 
-;;; SETUP-CHILD -- internal
-;;;
-;;;   Execs the program after setting up the environment correctly. This
-;;; routine never returns under any condition.
-;;;
-(defun setup-child (pfile args env stdin stdout stderr pty-name before-execve)
-  (unwind-protect
-      (handler-bind ((error #'(lambda (condition)
-				(declare (ignore condition))
-				(unix:unix-exit 2))))
-	;; Put us in our own pgrp.
-	(unix:unix-setpgrp 0 (unix:unix-getpid))
-	;; If we want a pty, set it up.
-	(when pty-name
-	  (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))
-	    (when old-tty
-	      (unix:unix-ioctl old-tty unix:TIOCNOTTY nil)
-	      (unix:unix-close old-tty)))
-	  (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))
-	    (when new-tty
-	      (unix:unix-dup2 new-tty 0)
-	      (unix:unix-dup2 new-tty 1)
-	      (unix:unix-dup2 new-tty 2))))
-	;; Setup the three standard descriptors.
-	(when stdin
-	  (unix:unix-dup2 stdin 0))
-	(when stdout
-	  (unix:unix-dup2 stdout 1))
-	(when stderr
-	  (unix:unix-dup2 stderr 2))
-	;; Arange for all the unused FD's to be closed.
-	(do ((fd (1- (unix:unix-getdtablesize))
-		 (1- fd)))
-	    ((= fd 3))
-	  (unix:unix-fcntl fd unix:f-setfd 1))
-	;; Do the before-execve
-	(when before-execve
-	  (funcall before-execve))
-	;; Exec the program
-	(multiple-value-bind
-	    (okay errno)
-	    (unix:unix-execve pfile args env)
-	  (declare (ignore okay))
-	  ;; If the magic number if bogus, try just a shell script.
-	  (when (eql errno unix:ENOEXEC)
-	    (unix:unix-execve "/bin/sh" (cons pfile args) env))))
-    ;; If exec returns, we lose.
-    (unix:unix-exit 1)))
+
+(defmacro round-bytes-to-words (n)
+  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
+
+(defun string-list-to-c-strvec (string-list)
+  ;;
+  ;; Make a pass over string-list to calculate the amount of memory
+  ;; needed to hold the strvec.
+  (let ((string-bytes 0)
+	;; We need an extra for the null, and an extra 'cause exect clobbers
+	;; argv[-1].
+	(vec-bytes (* 4 (+ (length string-list) 2))))
+    (declare (fixnum string-bytes vec-bytes))
+    (dolist (s string-list)
+      (check-type s simple-string)
+      (incf string-bytes (round-bytes-to-words (1+ (length s)))))
+    ;;
+    ;; Now allocate the memory and fill it in.
+    (let* ((total-bytes (+ string-bytes vec-bytes))
+	   (vec-sap (system:allocate-system-memory total-bytes))
+	   (string-sap (sap+ vec-sap vec-bytes))
+	   (i 4))
+      (declare (type (and unsigned-byte fixnum) total-bytes i)
+	       (type system:system-area-pointer vec-sap string-sap))
+      (dolist (s string-list)
+	(declare (simple-string s))
+	(let ((n (length s)))
+	  ;; 
+	  ;; Blast the string into place
+	  (kernel:copy-to-system-area (the simple-string s)
+				      (* vm:vector-data-offset vm:word-bits)
+				      string-sap 0
+				      (* (1+ n) vm:byte-bits))
+	  ;; 
+	  ;; Blast the pointer to the string into place
+	  (setf (sap-ref-sap vec-sap i) string-sap)
+	  (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
+	  (incf i 4)))
+      ;; Blast in last null pointer
+      (setf (sap-ref-sap vec-sap i) (int-sap 0))
+      (values vec-sap (sap+ vec-sap 4) total-bytes))))
+
+
+(defmacro with-c-strvec ((var str-list) &body body)
+  (let ((sap (gensym "SAP-"))
+	(size (gensym "SIZE-")))
+    `(multiple-value-bind
+	 (,sap ,var ,size)
+	 (string-list-to-c-strvec ,str-list)
+       (unwind-protect
+	   (progn
+	     ,@body)
+	 (system:deallocate-system-memory ,sap ,size)))))
+
+(alien:def-alien-routine spawn c-call:int
+  (program c-call:c-string)
+  (argv (* c-call:c-string))
+  (envp (* c-call:c-string))
+  (pty-name c-call:c-string)
+  (stdin c-call:int)
+  (stdout c-call:int)
+  (stderr c-call:int))
+
 
 ;;; RUN-PROGRAM -- public
 ;;;
@@ -387,8 +402,7 @@
 (defun run-program (program args
 		    &key (env *environment-list*) (wait t) pty input
 		    if-input-does-not-exist output (if-output-exists :error)
-		    (error :output) (if-error-exists :error) status-hook
-		    before-execve)
+		    (error :output) (if-error-exists :error) status-hook)
   "Run-program creates a new process and runs the unix progam in the
    file specified by the simple-string program.  Args are the standard
    arguments that can be passed to a Unix program, for no arguments
@@ -423,7 +437,7 @@
            nil (default) - return nil from run-program.
      :output -
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
-	input for the current process is inherited.  If NIL, /dev/null
+	output for the current process is inherited.  If NIL, /dev/null
 	is used.  If a pathname, the file so specified is used.  If a stream,
 	all the output from the process is written to this stream. If
 	:STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
@@ -440,10 +454,7 @@
 	same place as normal output.
      :status-hook -
         This is a function the system calls whenever the status of the
-        process changes.  The function takes the process as an argument.
-     :before-execve -
-        This is a function, without arguments, RUN-PROGRAM runs in the child
-        process just before turning it into the specified program."
+        process changes.  The function takes the process as an argument."
 
   ;; Make sure the interrupt handler is installed.
   (system:enable-interrupt unix:sigchld #'sigchld-handler)
@@ -456,7 +467,7 @@
   ;; info.  Also, establish proc at this level so we can return it.
   (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
     (unwind-protect
-	(let ((pfile (namestring (truename (merge-pathnames program "path:"))))
+	(let ((pfile (unix-namestring (merge-pathnames program "path:")))
 	      (cookie (list 0)))
 	  (multiple-value-bind
 	      (stdin input-stream)
@@ -477,29 +488,30 @@
 		  ;; Make sure we are not notified about the child death before
 		  ;; we have installed the process struct in *active-processes*
 		  (system:without-interrupts
-		    (multiple-value-bind
-			(child-pid errno)
-			(unix:unix-fork)
-		      (cond ((null child-pid)
-			     ;; This should only happen if the bozo has too
-			     ;; many running procs.
-			     (error "Could not fork child process: ~A"
-				    (unix:get-unix-error-msg errno)))
-			    ((zerop child-pid)
-			     ;; We are the child. Note: setup-child NEVER
-			     ;; returns
-			     (setup-child pfile args env stdin stdout stderr
-					  pty-name before-execve))
-			    (t
-			     ;; We are the parent.
-			     (setf proc (make-process :pid child-pid
-						      :%status :running
-						      :pty pty-stream
-						      :input input-stream
-						      :output output-stream
-						      :error error-stream
-						      :status-hook status-hook
-						      :cookie cookie))
+		    (with-c-strvec (argv args)
+		      (with-c-strvec
+			  (envp (mapcar #'(lambda (entry)
+					    (concatenate
+					     'string
+					     (symbol-name (car entry))
+					     "="
+					     (cdr entry)))
+					env))
+			(let ((child-pid
+			       (without-gcing
+				(spawn pfile argv envp pty-name
+				       stdin stdout stderr))))
+			  (when (< child-pid 0)
+			    (error "Could not fork child process: ~A"
+				   (unix:get-unix-error-msg)))
+			  (setf proc (make-process :pid child-pid
+						   :%status :running
+						   :pty pty-stream
+						   :input input-stream
+						   :output output-stream
+						   :error error-stream
+						   :status-hook status-hook
+						   :cookie cookie))
 			     (push proc *active-processes*))))))))))
       (dolist (fd *close-in-parent*)
 	(unix:unix-close fd))
@@ -573,7 +585,7 @@
 				  &allow-other-keys)
   (cond ((eq object t)
 	 ;; No new descriptor is needed.
-	 (values nil nil))
+	 (values -1 nil))
 	((eq object nil)
 	 ;; Use /dev/null.
 	 (multiple-value-bind
-- 
GitLab