;;; Fork a process and rejuvenate the listed ports.  Other ports are closed.
;;; current-input-port etc., are not set.
;;; proc is a procedure taking one argument 
;;; (the list of inherited ports.)

(define fork/ports
  (lambda (ports proc)
    (if (not (procedure? proc))
	(error "Wrong type in arg2" proc))
    (let ((pid (fork)))
      (cond ((eq? pid 0)
	     (close-all-ports-except ports)
	     (proc ports))
	    (else pid)))))


;; fork/ports used to do this;
;; 
;;	     (let ((inherited-ports (map (lambda (old-port)
;;					   (duplicate-port
;;					    old-port
;;					    (port-mode old-port)))
;;					 ports)))
;;	       (map close-port ports)
;;	       (proc inherited-ports)
;;	       (exit #t))

(define fork/thunk
  (lambda (thunk)
    (if (not (procedure? thunk))
	(error "Wrong type in arg1" thunk))
    (fork/ports (list (current-input-port)
		      (current-output-port)
		      (current-error-port))
		(lambda (inherited-ports)
		  (set-current-input-port (car inherited-ports))
		  (set-current-output-port (cadr inherited-ports))
		  (set-current-error-port (caddr inherited-ports))
		  (thunk)))))

;;; Fork a Scheme child process with child's current-output-port
;;; connected to parent's current-input-port.
(define fork/pipe
  (lambda (thunk)
    (if (not (procedure? thunk))
	(error "Wrong type in arg1" thunk))
    (let ((ppe (unbuffered-pipe)))
      (let ((pid (fork/ports
		  (list (current-input-port)
			(cdr ppe)
			(current-error-port))
		  (lambda (inherited-ports)
		    (set-current-input-port (car inherited-ports))
		    (set-current-output-port (cadr inherited-ports))
		    (set-current-error-port (caddr inherited-ports))
		    (thunk)))))
	(close-port (cdr ppe))
	(set-current-input-port (car ppe))
	pid))))

(define unbuffered-pipe
  (lambda ()
    (let* ((tmp (pipe))
	   (new (cons (duplicate-port (car tmp) "r0")
		      (duplicate-port (cdr tmp) "w0"))))
      (close-port (car tmp))
      (close-port (cdr tmp))
      new)))

;;; SCSH fork/pipe+ (taking a connection list of fds) is replaced with
;;; fork/ports.
;;; For testing.		    
(define run
  (lambda (prog . args)
    (let ((ppe (unbuffered-pipe)))
      (let ((pid (fork/ports
		  (list (current-input-port)
			(cdr ppe)
			(current-error-port))
		  (lambda (inherited-ports)
		    (%%move->fdes (car inherited-ports) 0)
		    (%%move->fdes (cadr inherited-ports) 1)
		    (%%move->fdes (caddr inherited-ports) 2)
		    (apply %%exec prog args)))))
	(close-port (cdr ppe))
	(cons pid (car ppe))))))

(define run-bidi
  (lambda (prog . args)
    (let ((s-pipe (unbuffered-pipe))
	  (r-pipe (unbuffered-pipe)))
      (let ((pid (fork/ports
		  (list (car s-pipe)
			(cdr r-pipe)
			(current-error-port))
		  (lambda (inherited-ports)
		    (%%move->fdes (car inherited-ports) 0)
		    (%%move->fdes (cadr inherited-ports) 1)
		    (%%move->fdes (caddr inherited-ports) 2)
		    (apply %%exec prog args)))))
	(close-port (cdr r-pipe))
	(close-port (car s-pipe))
	(list pid (car r-pipe) (cdr s-pipe))))))

(define exec-pipe
  (lambda ppe
    (let* ((comps (separate-components ppe))
	   (commands (car comps))
	   (connections (map remove-dup-connections
			     (insert-default-connections
			      'exec (cdr comps)))))
      (really-exec-pipe commands connections))))

(define really-exec-pipe
  (lambda (commands connections)
    (let* ((initial-pipes (make-conn-pipes (list-ref connections 1)))
	   (input-pipes initial-pipes))
      (do ((i 1 (+ i 1))
	   (pids ()))
	  ((= i (length commands)))
	(let ((output-pipes (make-conn-pipes (list-ref connections (+ i 1)))))
	  (exec-child (list-ref commands i)
		      (list-ref connections i)
		      (list-ref connections (+ i 1))
		      input-pipes
		      output-pipes)
	  (set! input-pipes output-pipes)))
      (do-pipe-exec (car commands)
		    (car connections)
		    (cadr connections)
		    initial-pipes))))

(define fg-pipe
  (lambda ppe
    (let ((pid (fork)))
      (cond ((eq? pid 0)
	     (apply exec-pipe ppe)
	     ;; In case exec fails.
	     (exit 1))
	    (else
	     (cdr (waitpid pid)))))))

(define bg-pipe
  (lambda ppe
    (let* ((comps (separate-components ppe))
	   (commands (car comps))
	   (connections (map remove-dup-connections
			     (insert-default-connections
			      'bg (cdr comps)))))
      ;; Generate pipes for the returned ports.
      (let ((returned-ports ())
	    (sent-ports ()))
	(do ((pipe-left connections (cdr pipe-left)))
	    ((null? pipe-left))
	  (cond ((and (list? (car pipe-left)) (list? (caar pipe-left)))
		 (do ((conns (car pipe-left) (cdr conns)))
		     ((null? conns))
		   (cond ((list? (car conns))
			  (cond ((eq? (caar conns) 'return-port)
				 (let ((ppe (unbuffered-pipe)))
				   (set! returned-ports
					 (append returned-ports
						 (list (cdr ppe))))
				   (set! sent-ports
					 (append sent-ports
						 (list (car ppe))))
				   (set-car! (car conns) (car ppe))))
				((eq? (cadar conns) 'return-port)
				 (let ((ppe (unbuffered-pipe)))
				   (set! returned-ports
					 (append returned-ports
						 (list (car ppe))))
				   (set! sent-ports
					 (append sent-ports
						 (list (cdr ppe))))
				   (set-cdr! (car conns) 
					     (list (cdr ppe))))))))))))
	(let ((pid (fork)))
	  (cond ((eq? pid 0)
		 (for-each close-port returned-ports)
		 (really-exec-pipe commands connections)
		 ;; In case exec fails.
		 (exit 1))
		(else
		 (for-each close-port sent-ports)
		 (cons pid returned-ports))))))))
  
;;; Step through the pipe to separate commands from connections.
;;; Adds #t for missing connections to represent default list.
(define separate-components
  (lambda (ppe)
    (let next-thing ((rest-pipe ppe)
		     (was-connection #f)
		     (commands ())
		     (connections ()))
      (cond
       ((null? rest-pipe)
	(if (null? commands)
	    (error "Invalid pipe: no commands"))
	(if (not was-connection)
	    (set! connections (append connections (list #t))))
	;; Check that pipe doesn't start or end with a file descriptor.
	(if (and (list? (car connections))
		 (not (apply eq? #f
			     (map (lambda (conn)
				    (number? (car conn)))
				  (car connections)))))
	    (error "Can not start from a file descriptor"))
	(let ((rev-conns (reverse connections)))
	  (if (and (list? (car rev-conns))
		   (not (apply eq? #f
			       (map (lambda (conn)
				      (number? (car (reverse conn))))
				    (car rev-conns)))))
	      (error "Can not end with a file descriptor")))
	(cons commands connections))
       (else
	(let ((is-connection (connection-list? (car rest-pipe))))
	  (if (and was-connection is-connection)
	      (error "Unexpected connection in pipe" (car rest-pipe)))
	  (next-thing
	   (cdr rest-pipe)
	   is-connection
	   (cond (is-connection
		  commands)
		 (else
		  (append commands (list (car rest-pipe)))))
	   (cond (is-connection
		  (append connections (list (car rest-pipe))))
		 ((not was-connection)
		  (append connections (list #t)))
		 (else
		  connections)))))))))

;;; Return #t if thing is a connection list, #f if a command,
;;; check for errors.
(define connection-list?
  (lambda (thing)
    (if (not (list? thing))
	(error "Invalid component in pipe" thing))
    (cond ((list? (car thing))
	   (map (lambda (sub-thing)
		  (if (not (and 
			    (list? sub-thing)
			    (> (length sub-thing) 1)))
		      (error "Invalid connection list" thing)
		      (let* ((rev (reverse sub-thing))
			     (target (car rev))
			     (sources (cdr rev)))
			(if (and
			     (or (number? target)
				 (and (string? target)
				      (number? (car sources)))
				 (and (output-port? target)
				      (number? (car sources))))
			     (or (apply eq? #t (map number? sources))
				 (and (string? (car sources))
				      (= (length sources) 1))
				 (and (input-port? (car sources))
				      (= (length sources) 1))))
			    #t
			    (error
			     "Invalid connection list" thing)))))
		thing)
	   #t)
	  (else
	   (if (or (apply eq? #t (map string? thing))
		   (and (procedure? (car thing)) (= (length thing) 1)))
	       #f
	       (error "Invalid command" thing))))))

;;; Convert connection specs like ((1 0)(2 0)) into ((1 2 0)).
(define remove-dup-connections
  (lambda (conns)
    (let ((rev-conns (map reverse conns))
	  (num-conns (length conns)))
      (let i-loop ((i 0))
	(if (= i num-conns)
	    conns
	    (let j-loop ((j (+ i 1)))
	      (if (= j num-conns)
		  (i-loop (+ i 1))
		  (if (equal? (car (list-ref rev-conns i))
			      (car (list-ref rev-conns j)))
		      (remove-dup-connections
		       (do-remove-dup (cons i j) conns))
		      (j-loop (+ j 1))))))))))

(define do-remove-dup
  (lambda (dup-pair all)
    (let next-pair ((remaining all)
		    (i 0)
		    (result ()))
      (if (null? remaining) result
	  (next-pair (cdr remaining)
		     (+ i 1)
		     (cond ((= i (car dup-pair))
			    result)
			   ((= i (cdr dup-pair))
			    (append
			     result
			     (list
			      (append
			       (cdr (reverse (list-ref all (car dup-pair))))
			       (cdr (reverse (car remaining)))
			       (list (car (reverse (car remaining))))))))
			   (else
			    (append
			     result
			     (list (car remaining))))))))))

;;; Replace the #t symbol in a connection list (representing unspecified
;;; connections) with the default connections for exec-pipe and fg-pipe.
;;; Type should be 'exec or 'bg to get the right connections.
(define insert-default-connections
  (lambda (type conn-list)
    (append
     ;; Second part of the list may disappear.
     ;; Lists inserted may be written to: do not use quote.
     (append
      (list
       (cond ((eq? type 'exec)
	      (if (eq? (car conn-list) #t)
		  (list (list (current-input-port) 0))
		  (car conn-list)))
	     ((eq? type 'bg)
	      (if (eq? (car conn-list) #t)
		  (list (list 'return-port 0))
		  (car conn-list)))))
      (if (> (length conn-list) 2)
	  (map (lambda (conns)
		 (if (eq? conns #t)
		     (list (list 1 0)
			   (list 2 (current-error-port)))
		     conns))
	       (reverse (cdr (reverse (cdr conn-list)))))
	  ()))
     (list
      (cond ((eq? type 'exec)
	     (if (eq? (car (reverse conn-list)) #t)
		 (list (list 1 (current-output-port))
		       (list 2 (current-error-port)))
		 (car (reverse conn-list))))
	    ((eq? type 'bg)
	     (if (eq? (car (reverse conn-list)) #t)
		 (list (list 1 'return-port)
		       (list 2 (current-error-port)))
		 (car (reverse conn-list)))))))))

;;; Setup an input file descriptor.  Returns a port if one is used,
;;; otherwise unspecified.
(define make-input-fdes
  (lambda (conns pipes)
    (let* ((rev-conns (reverse conns))
	   (fdes (car rev-conns))
	   (sources (cdr rev-conns))
	   (last-source (car sources)))
      (cond ((number? fdes)
	     (let ((new-port #f))
	       (cond ((number? last-source)
		      (set! new-port (car pipes)))
		     ((string? last-source)
		      (set! new-port
			    (open-input-file last-source)))
		     ((input-port? last-source)
		      (set! new-port last-source)))
	       (%%move->fdes new-port fdes)
	       new-port))))))

;;;; Make a set of pipes for a connection list.
(define make-conn-pipes
  (lambda (conns)
    (map (lambda (conn)
	   (cond ((and (number? (car conn))
		       (number? (car (reverse conn))))
		  (unbuffered-pipe))
		 (else
		  ())))
	 conns)))

;;; Setup an output file descriptor (possibly dup'd).
;;; Returns a list of ports if any, otherwise unspecified.
(define make-output-fdes
  (lambda (conns pipes)
    (let* ((rev-conns (reverse conns))
	   (target (car rev-conns))
	   (sources (cdr rev-conns))
	   (fdes (car sources))
	   (ports ()))
      (cond ((number? fdes)
	     (let ((new-port #f))
	       (cond ((number? target)
		      (set! new-port (cdr pipes)))
		     ((string? target)
		      (set! new-port
			    (open-output-file target)))
		     ((output-port? target)
		      (set! new-port target)))
	       (do ((dups (cdr sources) (cdr dups)))
		   ((null? dups))
		 (let ((tmp-port (duplicate-port
				  new-port
				  "w")))
		   (%%move->fdes tmp-port (car dups))
		   (redirect-port! new-port tmp-port)
		   (set! ports (append ports (list tmp-port)))))
	       (%%move->fdes new-port fdes)
	       (append ports (list new-port))))))))

;;; Setup input and output file descriptors, returning a list of ports used.
(define make-all-fdes
  (lambda (conn-in conn-out pipes-in pipes-out)
    (let ((port-list ()))
      (do ((w-conn conn-in (cdr w-conn))
	   (w-pipes pipes-in (cdr w-pipes)))
	  ((null? w-conn))
	(let ((tmp-port (make-input-fdes (car w-conn) (car w-pipes))))
	  (if (input-port? tmp-port)
	      (set! port-list (append port-list (list tmp-port))))))
      (do ((w-conn conn-out (cdr w-conn))
	   (w-pipes pipes-out (cdr w-pipes)))
	  ((null? w-conn))
	(let ((tmp-ports (make-output-fdes (car w-conn) (car w-pipes))))
	  (if (list? tmp-ports)
	      (set! port-list (append port-list tmp-ports)))))
      port-list)))

;;; Create a child process, given a command to exec, two connection
;;; lists and the list of pipes for each connection list.
(define exec-child
  (lambda (command conn-in conn-out pipes-in pipes-out)
    (let ((pid (fork)))
      (cond
       ((eq? pid 0)
	;; Child.
	(let ((ports (make-all-fdes conn-in conn-out pipes-in pipes-out)))
	  (close-all-ports-except ports)
	  (if (procedure? (car command))
	      (do-exec-proc (car command))
	      (apply %%exec command))))
       (else
	;; Parent: close unneeded pipe ends.
	(map (lambda (ppe)
	       (if (not (null? ppe))
		   (close-port (car ppe))))
	     pipes-in)
	(map (lambda (ppe)
	       (if (not (null? ppe))
		   (close-port (cdr ppe))))
	     pipes-out)
	pid)))))

;;; Exec or call the first exec-pipe process.  There are no input pipes.
(define do-pipe-exec
  (lambda (command conn-in conn-out pipes-out)
    (let ((ports (make-all-fdes conn-in conn-out
				(map (lambda (conn) ()) conn-in)
				pipes-out)))
      (close-all-ports-except ports)
      (if (procedure? (car command))
	  (do-exec-proc (car command))
	  (apply %%exec command)))))

;;: Set up standard ports and start a Scheme child process.
(define do-exec-proc
  (lambda (thunk)
    (let ((input-port (%%fdes->port 0 "r"))
	  (output-port (%%fdes->port 1 "w"))
	  (error-port (%%fdes->port 2 "w")))
      (if input-port
	  (set-current-input-port (duplicate-port 
				   input-port
				   (port-mode input-port))))
      (if output-port	       
	  (set-current-output-port (duplicate-port 
				    output-port
				    (port-mode output-port))))
      (if error-port
	  (set-current-error-port (duplicate-port 
				   error-port
				   (port-mode error-port))))
      (thunk)
      (exit 0))))
