Index: /branches/win64/level-1/linux-files.lisp
===================================================================
--- /branches/win64/level-1/linux-files.lisp	(revision 9548)
+++ /branches/win64/level-1/linux-files.lisp	(revision 9549)
@@ -492,6 +492,23 @@
     (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
 
+#-windows-target
 (defun fd-dup (fd)
   (int-errno-call (#_dup fd)))
+
+#+windows-target
+(defun fd-dup (fd &key direction inheritable)
+  (rlet ((handle #>LPHANDLE))
+    (#_DuplicateHandle (#_GetCurrentProcess)
+		       (#__get_osfhandle fd)
+		       (#_GetCurrentProcess) 
+		       handle
+		       0
+		       (if inheritable #$TRUE #$FALSE)
+		       #$DUPLICATE_SAME_ACCESS)
+    (#__open_osfhandle (pref handle #>HANDLE) (case direction
+						(:input #$O_RDONLY)
+						(:output #$O_WRONLY)
+						(t #$O_RDWR)))))
+		       
 
 (defun fd-fsync (fd)
@@ -1262,9 +1279,272 @@
 #+windows-target
 (progn
-#+windows-target
+(defun get-descriptor-for (object proc close-in-parent close-on-error
+				  &rest keys &key direction (element-type 'character)
+				  &allow-other-keys)
+  (etypecase object
+    ((eql t)
+     (values nil nil close-in-parent close-on-error))
+    (null
+     (let* ((null-device "nul")
+	    (fd (fd-open null-device (case direction
+				       (:input #$O_RDONLY)
+				       (:output #$O_WRONLY)
+				       (t #$O_RDWR)))))
+       (if (< fd 0)
+	 (signal-file-error fd null-device))
+       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
+    ((eql :stream)
+     (multiple-value-bind (read-pipe write-pipe) (pipe)
+       (case direction
+	 (:input
+	  (values read-pipe
+		  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
+				  :direction :output
+                                  :element-type element-type
+				  :interactive nil
+                                  :basic t
+                                  :auto-close t)
+		  (cons read-pipe close-in-parent)
+		  (cons write-pipe close-on-error)))
+	 (:output
+	  (values write-pipe
+		  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
+				  :direction :input
+                                  :element-type element-type
+				  :interactive nil
+                                  :basic t
+                                  :auto-close t)
+		  (cons write-pipe close-in-parent)
+		  (cons read-pipe close-on-error)))
+	 (t
+	  (fd-close read-pipe)
+	  (fd-close write-pipe)
+	  (report-bad-arg direction '(member :input :output))))))
+    ((or pathname string)
+     (with-open-stream (file (apply #'open object keys))
+       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
+         (values fd
+                 nil
+                 (cons fd close-in-parent)
+                 (cons fd close-on-error)))))
+    (fd-stream
+     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
+       (values fd
+	       nil
+	       (cons fd close-in-parent)
+	       (cons fd close-on-error))))
+    (stream
+     (ecase direction
+       (:input
+	(with-cstrs ((template "lisp-tempXXXXXX"))
+	  (let* ((fd (#_mktemp template)))
+	    (if (< fd 0)
+	      (%errno-disp fd))
+	    (#_unlink template)
+	    (loop
+              (multiple-value-bind (line no-newline)
+                  (read-line object nil nil)
+                (unless line
+                  (return))
+                (let* ((len (length line)))
+                  (%stack-block ((buf (1+ len)))
+                    (%cstr-pointer line buf)
+                    (fd-write fd buf len)
+                    (if no-newline
+                      (return))
+                    (setf (%get-byte buf) (char-code #\newline))
+                    (fd-write fd buf 1)))))
+	    (fd-lseek fd 0 #$SEEK_SET)
+	    (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
+       (:output
+	(multiple-value-bind (read-pipe write-pipe) (pipe)
+          (setf (external-process-watched-fd proc) read-pipe
+                (external-process-watched-stream proc) object)
+          (incf (car (external-process-token proc)))
+	  (values write-pipe
+		  nil
+		  (cons write-pipe close-in-parent)
+		  (cons read-pipe close-on-error))))))))
+
+(defstruct external-process
+  pid
+  %status
+  %exit-code
+  pty
+  input
+  output
+  error
+  status-hook
+  plist
+  token
+  core
+  args
+  (signal (make-semaphore))
+  (completed (make-semaphore))
+  watched-fd
+  watched-stream
+  )
+
+(defmethod print-object ((p external-process) stream)
+  (print-unreadable-object (p stream :type t :identity t)
+    (let* ((status (external-process-%status p)))
+      (let* ((*print-length* 3))
+	(format stream "~a" (external-process-args p)))
+      (format stream "[~d] (~a" (external-process-pid p) status)
+      (unless (eq status :running)
+	(format stream " : ~d" (external-process-%exit-code p)))
+      (format stream ")"))))
+
+(defun run-program (program args &key
+			    (wait t) pty
+			    input if-input-does-not-exist
+			    output (if-output-exists :error)
+			    (error :output) (if-error-exists :error)
+			    status-hook (element-type 'character)
+                            env)
+  "Invoke an external program as an OS subprocess of lisp."
+  (declare (ignore pty))
+  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
+    (error "Program args must all be simple strings : ~s" args))
+;  (push (native-untranslated-namestring program) args)
+  (push program args)
+  (let* ((token (list 0))
+	 (in-fd nil)
+	 (in-stream nil)
+	 (out-fd nil)
+	 (out-stream nil)
+	 (error-fd nil)
+	 (error-stream nil)
+	 (close-in-parent nil)
+	 (close-on-error nil)
+	 (proc
+          (make-external-process
+           :pid nil
+           :args args
+           :%status :running
+           :input nil
+           :output nil
+           :error nil
+           :token token
+           :status-hook status-hook)))
+    (unwind-protect
+	 (progn
+	   (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
+	     (get-descriptor-for input proc  nil nil :direction :input
+				 :if-does-not-exist if-input-does-not-exist
+                                 :element-type element-type))
+	   (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
+	     (get-descriptor-for output proc close-in-parent close-on-error
+				 :direction :output
+				 :if-exists if-output-exists
+                                 :element-type element-type))
+	   (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
+	     (if (eq error :output)
+	       (values out-fd out-stream close-in-parent close-on-error)
+	       (get-descriptor-for error proc close-in-parent close-on-error
+				   :direction :output
+				   :if-exists if-error-exists
+                                   :element-type element-type)))
+	   (setf (external-process-input proc) in-stream
+                 (external-process-output proc) out-stream
+                 (external-process-error proc) error-stream)
+	   (format t "~s ~s ~s" in-fd out-fd error-fd)
+           (process-run-function
+            (format nil "Monitor thread for external process ~a" args)
+                    
+            #'run-external-process proc in-fd out-fd error-fd env)
+           (wait-on-semaphore (external-process-signal proc))
+           )
+      (dolist (fd close-in-parent) (fd-close fd))
+      (unless (external-process-pid proc)
+        (dolist (fd close-on-error) (fd-close fd)))
+      (when (and wait (external-process-pid proc))
+        (with-interrupts-enabled
+            (wait-on-semaphore (external-process-completed proc)))))
+    (and (external-process-pid proc) proc)))
+
+(let* ((external-processes ())
+       (external-processes-lock (make-lock)))
+  (defun add-external-process (p)
+    (with-lock-grabbed (external-processes-lock)
+      (push p external-processes)))
+  (defun remove-external-process (p)
+    (with-lock-grabbed (external-processes-lock)
+      (setq external-processes (delete p external-processes))))
+  ;; Likewise
+  (defun external-processes ()
+    (with-lock-grabbed (external-processes-lock)
+      (copy-list external-processes)))
+  )
+
+
 (defun pipe ()
   (%stack-block ((filedes 8))
     (syscall syscalls::pipe filedes)
     (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))))
+
+(defun run-external-process (proc in-fd out-fd error-fd &optional env)
+  ;; stub, stub
+  (let* ((args (external-process-args proc))
+	 (child-pid (exec-with-io-redirection in-fd out-fd error-fd (car args) (cdr args))))
+    (setf (external-process-pid proc) child-pid)
+    (add-external-process proc)
+    (signal-semaphore (external-process-signal proc))
+    (monitor-external-process proc)))
+
+(defun exec-with-io-redirection (new-in new-out new-err command args)
+  (with-filename-cstrs ((command command))
+    (rletz ((proc-info #>PROCESS_INFORMATION)
+	    (si #>STARTUPINFO))
+      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
+      (setf (pref si #>STARTUPINFO.dwFlags) #$STARTF_USESTDHANDLES)
+      (setf (pref si #>STARTUPINFO.hStdInput) (#__get_osfhandle new-in))
+      (setf (pref si #>STARTUPINFO.hStdOutput) (#__get_osfhandle new-out))
+      (setf (pref si #>STARTUPINFO.hStdError) (#__get_osfhandle new-err))
+      (if (zerop (#_CreateProcessW (%null-ptr)
+				   command
+				   (%null-ptr)
+				   (%null-ptr)
+				   1
+				   #$CREATE_NEW_CONSOLE
+				   (%null-ptr)
+				   (%null-ptr)
+				   si
+				   proc-info))
+	  (error "Process creation failed"))
+      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
+
+(defun fd-uninheritable (fd &key direction)
+  (let ((new-fd (fd-dup fd :direction direction)))
+    (fd-close fd)
+    new-fd))
+
+(defun monitor-external-process (p)
+  (let* ((in-fd (external-process-watched-fd p))
+         (out-stream (external-process-watched-stream p))
+         (token (external-process-token p))
+         (terminated))
+    (loop
+      (when (and terminated (null in-fd))
+        (signal-semaphore (external-process-completed p))
+        (return))
+      (when in-fd
+        (when (fd-input-available-p in-fd 1000)
+          (%stack-block ((buf 1024))
+            (let* ((n (fd-read in-fd buf 1024)))
+              (declare (fixnum n))
+              (if (<= n 0)
+                (progn
+                  (without-interrupts
+                   (decf (car token))
+                   (fd-close in-fd)
+		   (setq terminated t) ; need equiv. of waitpid here
+                   (setq in-fd nil)))
+                (let* ((string (make-string 1024)))
+                  (declare (dynamic-extent string))
+                  (%str-from-ptr buf n string)
+                  (write-sequence string out-stream :end n))))))))))
+  
+
 ) ; #+windows-target (progn