scsh-0.6/scsh/scsh.scm

;;; A Scheme shell.
;;; Copyright (c) 1992 by Olin Shivers.
;;; Copyright (c) 1994 by Brian D. Carlstrom.

;;; Call THUNK, then die.
;;; A clever definition in a clever implementation allows the caller's stack
;;; and dynamic env to be gc'd away, since this procedure never returns.

;;;(define (call-terminally thunk)
;;;  (with-continuation (lambda () #f) (lambda () (thunk) (exit 0))))
;;;  ;; Alternatively: (with-continuation #f thunk)

;;; More portably, but less usefully:
;;; New version of s48 requires with-continuation to take a continuation
(define (call-terminally thunk)
  (thunk)
  (exit 0))

;;; Like FORK, but the parent and child communicate via a pipe connecting
;;; the parent's stdin to the child's stdout. This function side-effects
;;; the parent by changing his stdin.

(define (fork/pipe . maybe-thunk)
  (really-fork/pipe fork maybe-thunk))

(define (%fork/pipe . maybe-thunk)
  (really-fork/pipe %fork maybe-thunk))
  
;;; Common code for FORK/PIPE and %FORK/PIPE.
(define (really-fork/pipe forker maybe-thunk)
  (receive (r w) (pipe)
    (let ((proc (forker)))
      (cond (proc		; Parent
	     (close w)
	     (move->fdes r 0))
	    (else		; Child
	     (close r)
	     (move->fdes w 1)
	     (if (pair? maybe-thunk)
		 (call-terminally (car maybe-thunk)))))
      proc)))


;;; FORK/PIPE with a connection list.
;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)

(define (%fork/pipe+ conns . maybe-thunk)
  (really-fork/pipe+ %fork conns maybe-thunk))

(define (fork/pipe+ conns . maybe-thunk)
  (really-fork/pipe+ fork conns maybe-thunk))

;;; Common code.
(define (really-fork/pipe+ forker conns maybe-thunk)
  (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
		     conns))
	 (rev-conns (map reverse conns))
	 (froms (map (lambda (conn) (reverse (cdr conn)))
		     rev-conns))
	 (tos (map car rev-conns)))

    (let ((proc (forker)))
      (cond (proc			; Parent
	     (for-each (lambda (to r/w)
			 (let ((w (cdr r/w))
			       (r (car r/w)))
			   (close w)
			   (move->fdes r to)))
		       tos pipes))

	    (else		; Child
	     (for-each (lambda (from r/w)
			 (let ((r (car r/w))
			       (w (cdr r/w)))
			   (close r)
			   (for-each (lambda (fd) (dup w fd)) from)
			   (close w))) ; Unrevealed ports win.
		       froms pipes)
	     (if (pair? maybe-thunk)
		 (call-terminally (car maybe-thunk)))))
      proc)))

(define (tail-pipe a b)
  (fork/pipe a)
  (call-terminally b))

(define (tail-pipe+ conns a b)
  (fork/pipe+ conns a)
  (call-terminally b))

;;; Lay a pipeline, one process for each thunk. Last thunk is called
;;; in this process. PIPE* never returns.

(define (pipe* . thunks)
  (letrec ((lay-pipe (lambda (thunks)
		       (let ((thunk (car thunks))
			     (thunks (cdr thunks)))
			 (if (pair? thunks)
			     (begin (fork/pipe thunk)
				    (lay-pipe thunks))
			     (call-terminally thunk)))))) ; Last one.
    (if (pair? thunks)
	(lay-pipe thunks)
	(error "No thunks passed to PIPE*"))))

;;; Splice the processes into the i/o flow upstream from us.
;;; First thunk's process reads from our stdin; last thunk's process'
;;; output becomes our new stdin. Essentially, n-ary fork/pipe.
;;;
;;; This procedure is so trivial it isn't included.
;;; (define (pipe-splice . thunks) (for-each fork/pipe thunks))




;;; Should be moved to somewhere else
(define (with-lock lock thunk)
  (with-handler (lambda (condition more)
		  (release-lock lock)
		  (more))
		(lambda ()
		  (obtain-lock lock)
		  (let ((result (thunk)))
		    (release-lock lock)
		    result))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; A resource is a part of the process state for which every thread
;;; has its own value
;;; uses the procedures:
;;; (process-read-resource (-> 'X))
;;; (process-set-resource ('X -> unspec))
;;; (resource-eq? ('X 'X -> bool))

;;; defines the procedures:
;;; (initialize-resource  (-> unspec)) ; call on startup
;;; (with-resource* ((-> 'X) -> 'X))
;;; (with-resource-aligned* ((-> 'X) -> 'X))
;;; (thread-read-resource (-> 'X))
;;; (thread-set-resource ('X -> unspec))

(define-syntax  make-process-resource
  (syntax-rules ()
    ((make-process-resource 
      initialize-resource 
      thread-read-resource thread-set-resource! thread-change-resource 
      with-resource* with-resource-aligned* 
      process-read-resource process-set-resource resource-eq?)
(begin 
(define *resource-cache* 'uninitialized)
(define resource-lock 'uninitialized)

(define (initialize-resource)
  (set! *resource-cache* (process-read-resource))
  (set! $resource ;;; TODO The old thread-fluid will remain
  (make-thread-fluid
   (process-read-resource)))
  (set! resource-lock (make-lock)))

(define (cache-value)
  *resource-cache*)

;;; Actually do the syscall and update the cache
;;; assumes the resource lock obtained
(define (change-and-cache dir)
  (process-set-resource dir)
  (set! *resource-cache* (process-read-resource)))

;;; Dynamic-wind is not the right thing to take care of the lock;
;;; it would release the lock on every context switch.
;;; With-lock releases the lock on a condition, using call/cc will 
;;; skrew things up

;;; The thread-specific resource: A thread fluid

(define $resource 'emtpy-resource-value)

(define (thread-read-resource) (thread-fluid $resource))
(define (thread-set-resource! dir) (set-thread-fluid! $resource dir))
(define (let-resource dir thunk)
  (let-thread-fluid $resource dir thunk))

(define (with-resource* dir thunk) 
  (let ((changed-dir #f))  ; TODO 0.5 used to have a dynamic-wind here!!!
    (with-lock resource-lock
	       (lambda ()
		 (change-and-cache dir)
		 (set! changed-dir (cache-value))))
    (let-resource changed-dir thunk)))

;; Align the value of the Unix resource with scsh's value.
;; Since another thread could disalign, this call and
;; any ensuring syscall that relies upon it should
;; be "glued together" with the resource lock.

(define (align-resource!)
  (let ((dir (thread-read-resource)))
    (if (not (resource-eq? dir (cache-value)))
	(change-and-cache dir))))

(define (thread-change-resource dir)
  (with-lock resource-lock
	     (lambda ()
	       (change-and-cache dir)
	       (thread-set-resource! (cache-value)))))

;;; For thunks that don't raise exceptions or throw to continuations,
;;; this is overkill & probably a little heavyweight for frequent use.
;;; But it is general.
;;;
;;; A less-general, more lightweight hack could be done just for
;;; syscalls.  We could probably dump the DYNAMIC-WINDs and build the
;;; rest of the pattern into one of the syscall-defining macros, or
;;; something.  
;;; Olin adds the following: the efficient way to do things is not
;;; with a dynamic wind or a lock. Just turn off interrupts, sync the
;;; resource, do the syscall, turn them back on.

(define (with-resource-aligned* thunk)
  (dynamic-wind (lambda ()
		  (with-lock resource-lock
			     align-resource!)) 
		thunk 
		values))

;;; example syscall
;;; (define (exported-delete-file fname)
;;;;  (with-cwd-aligned (really-delete-file fname)))


(define resource-reinitializer
  (make-reinitializer (lambda () (warn "calling resumer") (initialize-resource))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; working directory per thread
(make-process-resource 
 initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned*
 process-cwd process-chdir string=?)

(initialize-cwd)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; umask per thread

(make-process-resource 
 initialize-umask umask thread-set-umask set-umask 
 with-umask* with-umask-aligned*
 process-umask set-process-umask =)

(initialize-umask)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environment per thread

(define-record env
      envvec
      alist)	; Corresponding alist

(define-record-resumer type/env
  (lambda (env)
    (set-env:envvec env #f)))

(define (env=? e1 e2)
  (and (env:envvec e1)
       (eq? (env:envvec e1) 
	    (env:envvec e2))))

(define-record envvec 
  environ ;; char**
  )

(define (add-envvec-finalizer! envvec)
  (add-finalizer! envvec envvec-finalizer))

(define-exported-binding "envvec-record-type" type/envvec)
(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!)

(define (envvec-finalizer envvec)
  (%free-env envvec))

(define (environ**-read)
  (let ((alist.envvec (environ-env->alist)))
    (make-env (cdr alist.envvec) (car alist.envvec))))

(define (environ**-set env)
   (if (env:envvec env)
       (%align-env (env:envvec env))
       (set-env:envvec env (envvec-alist->env (env:alist env)))))

(define (getenv var)
  (let* ((env (thread-read-env))
	 (res (assoc var (env:alist env))))
    (if res (cdr res) res)))

(define (env->alist)
  (env:alist (thread-read-env)))

(define (setenv var val)
  (let* ((env (thread-read-env))
	 (alist (alist-update 
		 var 
		 val 
		 (fold cons '() (env:alist env)))))
    (thread-set-env! 
     (make-env 
      #f
      alist
      ))))

(define (alist->env alist)
  (thread-set-env!
   (make-env
    #f
    alist)))

(define (with-env* alist-delta thunk)
  (let ((new-env (fold (lambda (key/val alist)
			  (alist-update (car key/val) (cdr key/val) alist))
			(env->alist)
			alist-delta)))
    (with-total-env* new-env thunk)))

(define (with-total-env* alist thunk)
  (with-env-internal* (make-env #f alist) thunk))

(make-process-resource install-env thread-read-env thread-set-env! 
		       useless-set-env
		       with-env-internal* with-env-aligned* 
		       environ**-read environ**-set env=?)

;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
;;; internally so the top-level startup code (INIT-SCSH) can use it
;;; to split up $PATH without requiring the field-splitter or regexp code.

(define (split-colon-list clist)
  (let ((len (string-length clist)))
    (if (= 0 len) '()			; Special case "" -> ().

	;; Main loop.
	(let split ((i 0))
	  (cond ((string-index clist #\: i) =>
		 (lambda (colon)
		   (cons (substring clist i colon)
			 (split (+ colon 1)))))
		(else (list (substring clist i len))))))))

;;; Unix colon lists typically use colons as separators, which
;;; is not as clean to deal with as terminators, but that's Unix.
;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "".

; (define (string-list->colon-list slist)
;   (if (pair? slist)
;       (apply string-append
; 	     (let colonise ((lis slist))	; LIS is always
; 	       (let ((tail (cdr lis))) 		; a pair.
; 		 (cons (car lis)
; 		       (if (pair? tail)
; 			   (cons ":" (colonise tail))
; 			   '())))))
;       ""))	; () case.


(define (alist-delete key alist)
  (filter (lambda (key/val) (not (equal? key (car key/val)))) alist))

(define (alist-update key val alist)
  (cons (cons key val)
	(alist-delete key alist)))

;;; Remove shadowed entries from ALIST. Preserves element order.
;;; (This version shares no structure.)

(define (alist-compress alist) 
  (reverse (let compress ((alist alist) (ans '()))
	     (if (pair? alist)
		 (let ((key/val (car alist))
		       (alist (cdr alist)))
		   (compress alist (if (assoc (car key/val) ans) ans
				       (cons key/val ans))))
		 ans))))

(define (add-before elt before list)
  (let rec ((list list))
    (if (pair? list)
	(let ((x (car list)))
	  (if (equal? x before)
	      (cons elt list)
	      (cons x (rec (cdr list)))))
	(cons elt list))))

;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER
;;; in LIST, and returns the list. However, if the LET finds no occurrence 
;;; of AFTER in LIST, it returns #F instead.

(define (add-after elt after list)
  (or (let rec ((list list))
	(if (pair? list)
	    (let* ((x (car list))
		   (tail (cdr list))
		   (ans (rec tail))) ; #f if AFTER wasn't encountered.
	      (cond (ans (cons x ans))
		    ((equal? x after)
		     (cons x (cons elt tail)))
		    (else #f)))		; AFTER doesn't appear in LIST.
	    #f))			; AFTER doesn't appear in LIST.
      (cons elt list))) 

;;; Sugar:

(define-simple-syntax (with-cwd dir . body)
  (with-cwd* dir (lambda () . body)))

(define-simple-syntax (with-cwd-aligned body ...)
  (with-cwd-aligned* (lambda () body ...)))

(define-simple-syntax (with-umask-aligned body ...)
  (with-cwd-aligned* (lambda () body ...)))

(define-simple-syntax (with-umask mask . body)
  (with-umask* mask (lambda () . body)))

(define-simple-syntax (with-env delta . body)
  (with-env* `delta (lambda () . body)))

(define-simple-syntax (with-total-env env . body)
  (with-total-env* `env (lambda () . body)))


(define (call/temp-file writer user)
  (let ((fname #f))
    (dynamic-wind
      (lambda () (if fname (error "Can't wind back into a CALL/TEMP-FILE")
		     (set! fname (create-temp-file))))
      (lambda ()
	(with-output-to-file fname writer)
	(user fname))
      (lambda () (if fname (delete-file fname))))))

;;; Create a new temporary file and return its name.
;;; The optional argument specifies the filename prefix to use, and defaults
;;; to "/tmp/<pid>.", where <pid> is the current process' id. The procedure
;;; scans through the files named <prefix>0, <prefix>1, ... until it finds a
;;; filename that doesn't exist in the filesystem. It creates the file with 
;;; permission #o600, and returns the filename.
;;; 

(define (create-temp-file . maybe-prefix)
  (let ((oflags (bitwise-ior open/write
			     (bitwise-ior open/create open/exclusive))))
    (apply temp-file-iterate
	   (lambda (fname)
	     (close-fdes (open-fdes fname oflags #o600))
	     fname)
	   (if (null? maybe-prefix) '()
	       (list (string-append (constant-format-string (car maybe-prefix))
				    ".~a"))))))

(define *temp-file-template*
  (make-fluid (string-append "/tmp/" (number->string (pid)) ".~a")))


(define (temp-file-iterate maker . maybe-template)
  (let ((template (:optional maybe-template (fluid *temp-file-template*))))
    (let loop ((i 0))
      (if (> i 1000) (error "Can't create temp-file")
	  (let ((fname (format #f template (number->string i))))
	    (receive retvals (with-errno-handler
			       ((errno data)
				((errno/exist) #f))
			       (maker fname))
	      (if (car retvals) (apply values retvals)
		  (loop (+ i 1)))))))))


;; Double tildes in S. 
;; Using the return value as a format string will output exactly S.
(define (constant-format-string s)	; Ugly code. Would be much clearer
  (let* ((len (string-length s))	; if written with string SRFI.
	 (tilde? (lambda (s i) (char=? #\~ (string-ref s i))))
	 (newlen (do ((i (- len 1) (- i 1))
		      (ans 0 (+ ans (if (tilde? s i) 2 1))))
		     ((< i 0) ans)))
	 (fs (make-string newlen)))
    (let lp ((i 0) (j 0))
      (cond ((< i len)
	     (let ((j (cond ((tilde? s i) (string-set! fs j #\~) (+ j 1))
			    (else j))))
	       (string-set! fs j (string-ref s i))
	       (lp (+ i 1) (+ j 1))))))
    fs))


;;; Roughly equivalent to (pipe).
;;; Returns two file ports [iport oport] open on a temp file.
;;; Use this when you may have to buffer large quantities between
;;; writing and reading. Note that if the consumer gets ahead of the
;;; producer, it won't hang waiting for input, it will just return
;;; EOF. To play it safe, make sure that the producer runs to completion
;;; before starting the consumer.
;;;
;;; The temp file is deleted before TEMP-FILE-CHANNEL returns, so as soon
;;; as the ports are closed, the file's disk storage is reclaimed.

(define (temp-file-channel)
  (let* ((fname (create-temp-file))
	 (iport (open-input-file fname))
	 (oport (open-output-file fname)))
    (delete-file fname)
    (values iport oport)))
    

;; Return a Unix port such that reads on it get the chars produced by
;; DISPLAYing OBJ. For example, if OBJ is a string, then reading from
;; the port produces the characters of OBJ.
;; 
;; This implementation works by writing the string out to a temp file,
;; but that isn't necessary. It could work, for example, by forking off a 
;; writer process that outputs to a pipe, i.e.,
;;     (run/port (begin (display obj (fdes->outport 1))))

(define (open-string-source obj)
  (receive (inp outp) (temp-file-channel)
    (display obj outp)
    (close-output-port outp)
    inp))


;;;; Process->Scheme interface forms: run/collecting, run/port, run/string, ...

;;; (run/collecting FDS . EPF)
;;; --------------------------
;;; RUN/COLLECTING and RUN/COLLECTING* run processes that produce multiple
;;; output streams and return ports open on these streams.
;;;
;;; To avoid issues of deadlock, RUN/COLLECTING first runs the process
;;; with output to temp files, then returns the ports open on the temp files.
;;;
;;; (run/collecting (1 2) (ls))
;;; runs ls with stdout (fd 1) and stderr (fd 2) redirected to temporary files.
;;; When ls is done, RUN/COLLECTING returns two ports open on the temporary
;;; files. The files are deleted before RUN/COLLECTING returns, so when
;;; the ports are closed, they vanish.
;;;
;;; The FDS list of file descriptors is implicitly backquoted.
;;;
;;; RUN/COLLECTING* is the procedural abstraction of RUN/COLLECTING.

(define (run/collecting* fds thunk)
  ;; First, generate a pair of ports for each communications channel.
  ;; Each channel buffers through a temp file.
  (let* ((channels (map (lambda (ignore)
			  (call-with-values temp-file-channel cons))
		       fds))
	 (read-ports (map car channels))
	 (write-ports (map cdr channels))

	 ;; In a subprocess, close the read ports, redirect input from
	 ;; the write ports, and run THUNK.
	 (status (run (begin (for-each close-input-port read-ports)
			     (for-each move->fdes write-ports fds)
			     (thunk)))))

    ;; In this process, close the write ports and return the exit status
    ;; and all the the read ports.
    (for-each close-output-port write-ports)
    (apply values status read-ports)))


;;; Single-stream collectors:
;;; Syntax: run/port, run/file, run/string, run/strings, run/sexp, run/sexps
;;; Procedures: run/port*, run/file*, run/string*, run/strings*, run/sexp*,
;;;             run/sexps*
;;;             port->string, port->string-list, port->sexp-list, 
;;;             port->list
;;; 
;;; Syntax:
;;; (run/port . epf)
;;; 	Fork off the process EPF and return a port on its stdout.
;;; (run/file . epf)
;;; 	Run process EPF with stdout redirected into a temp file.
;;;     When the process exits, return the name of the file.
;;; (run/string . epf)
;;;     Read the process' stdout into a string and return it.
;;; (run/strings . epf)
;;; 	Run process EPF, reading newline-terminated strings from its stdout
;;;     until EOF. After process exits, return list of strings read. Delimiting
;;;	newlines are trimmed from the strings.
;;; (run/sexp . epf)
;;;     Run process EPF, read and return one sexp from its stdout with READ.
;;; (run/sexps . epf)
;;;     Run process EPF, read sexps from its stdout with READ until EOF.
;;;	After process exits, return list of items read.
;;;
;;; Procedural abstractions:
;;; run/port*, run/file*, run/string*, run/strings*, run/sexp*, run/sexps*
;;;
;;; These are all procedural equivalents for the macros. They all take
;;; one argument: the process to be executed passed as a thunk. For example,
;;; (RUN/PORT . epf) expands into (RUN/PORT* (LAMBDA () (EXEC-EPF . epf)))
;;;
;;; Other useful procedures:
;;; 
;;; (port->string port) 
;;; 	Read characters from port until EOF; return string collected.
;;; (port->string-list port)
;;;     Read newline-terminated strings from port until EOF. Return
;;;     the list of strings collected.
;;; (port->sexp-list port)
;;;     Read sexps from port with READ until EOF. Return list of items read.
;;; (port->list reader port)
;;;     Repeatedly applies READER to PORT, accumulating results into a list.
;;;     On EOF, returns the list of items thus collected.
;;; (port-fold port reader op . seeds)
;;;     Repeatedly read things from PORT with READER. Each time you read
;;;     some value V, compute a new set of seeds with (apply OP V SEEDS).
;;;     (More than 1 seed means OP must return multiple values).
;;;     On eof, return the seeds: (apply value SEEDS).
;;;     PORT->LIST is just (PORT-FOLD PORT READ CONS '())

(define (run/port+proc* thunk)
  (receive (r w) (pipe)
    (let ((proc (fork (lambda ()
			(close r)
			(move->fdes w 1)
			(with-current-output-port* w thunk)))))
      (close w)
      (values r proc))))

(define (run/port* thunk)
  (receive (port proc) (run/port+proc* thunk)
    port))

(define (run/file* thunk)
  (let ((fname (create-temp-file)))
    (run (begin (thunk)) (> ,fname))
    fname))

(define (run/string* thunk) 
  (close-after (run/port* thunk) port->string))

(define (run/sexp* thunk)
  (close-after (run/port* thunk) read))

(define (run/sexps* thunk)
  (close-after (run/port* thunk) port->sexp-list))

(define (run/strings* thunk)
  (close-after (run/port* thunk) port->string-list))


;;; Read characters from PORT until EOF, collect into a string.

(define (port->string port)
  (let ((sc (make-string-collector)))
    (letrec ((lp (lambda ()
		   (cond ((read-string 1024 port) =>
			  (lambda (s)
			    (collect-string! sc s)
			    (lp)))
			 (else (string-collector->string sc))))))
      (lp))))

;;; (loop (initial (sc (make-string-collector)))
;;;       (bind (s (read-string 1024 port)))
;;;       (while s)
;;;       (do (collect-string! sc s))
;;;       (result (string-collector->string sc)))

;;; Read items from PORT with READER until EOF. Collect items into a list.

(define (port->list reader port)
  (let lp ((ans '()))
    (let ((x (reader port)))
      (if (eof-object? x) (reverse! ans)
	  (lp (cons x ans))))))

(define (port->sexp-list port)
  (port->list read port))

(define (port->string-list port)
  (port->list read-line port))

(define (port-fold port reader op . seeds)
  (letrec ((fold (lambda seeds
		     (let ((x (reader port)))
		       (if (eof-object? x) (apply values seeds)
			   (call-with-values (lambda () (apply op x seeds))
					     fold))))))
    (apply fold seeds)))

(define reduce-port
  (deprecated-proc port-fold 'reduce-port "Use port-fold instead."))

;;; Not defined:
;;; (field-reader field-delims record-delims)
;;; Returns a reader that reads strings delimited by 1 or more chars from
;;; the string FIELD-DELIMS. These strings are collected in a list until
;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the
;;; accumulated list of strings is returned. For example, if we want
;;; a procedure that reads one line of input, splitting it into 
;;; whitespace-delimited strings, we can use 
;;;     (field-reader " \t" "\n")
;;; for a reader.



;; Loop until EOF reading characters or strings and writing (FILTER char)
;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE.

(define (char-filter filter)
  (lambda ()
    (let lp ()
      (let ((c (read-char)))
	(if (not (eof-object? c))
	    (begin (write-char (filter c))
		   (lp)))))))

(define (string-filter filter . maybe-buflen)
  (let* ((buflen (:optional maybe-buflen 1024))
	 (buf (make-string buflen)))
    (lambda ()
      (let lp ()
	(cond ((read-string! buf 0 buflen) =>
	       (lambda (nread)
		 (display (filter (if (= nread buflen) buf
				      (substring buf 0 nread)))) ; last one.
		 (lp))))))))

(define (y-or-n? question . maybe-eof-value)
  (let loop ((count *y-or-n-eof-count*))
    (display question)
    (display " (y/n)? ")
    (let ((line (read-line)))
      (cond ((eof-object? line)
	     (newline)
	     (if (= count 0)
		 (:optional maybe-eof-value (error "EOF in y-or-n?"))
		 (begin (display "I'll only ask another ")
			(write count)
			(display " times.")
			(newline)
			(loop (- count 1)))))
	    ((< (string-length line) 1) (loop count))
	    ((char=? (string-ref line 0) #\y) #t)
	    ((char=? (string-ref line 0) #\n) #f)
	    (else (loop count))))))

(define *y-or-n-eof-count* 100)


;;; Stdio/stdport sync procedures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (stdio->stdports)
  (set-current-input-port!  (fdes->inport 0))
  (set-current-output-port! (fdes->outport 1))
  (set-current-error-port!   (fdes->outport 2)))

(define (with-stdio-ports* thunk)
  (with-current-input-port (fdes->inport 0)
    (with-current-output-port (fdes->outport 1)
      (with-current-error-port (fdes->outport 2)
	(thunk)))))

(define-simple-syntax (with-stdio-ports body ...)
  (with-stdio-ports* (lambda () body ...)))


(define (stdports->stdio)
  (dup (current-input-port)  0)
  (dup (current-output-port) 1)
  (dup (current-error-port)   2))


;;; Command-line argument access
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Some globals.
(define %command-line '())		; Includes program.
(define command-line-arguments #f)	; Doesn't include program.

(define (set-command-line-args! args)
  (set! %command-line args)
  (set! command-line-arguments (append (cdr args) '())))

(define (arg* arglist n . maybe-default-thunk)
  (let ((oops (lambda () (error "argument out of bounds" arglist n))))
    (if (< n 1) (oops)
	(let lp ((al arglist) (n n))
	  (if (pair? al)
	      (if (= n 1) (car al)
		  (lp (cdr al) (- n 1)))
	      (if (and (pair? maybe-default-thunk)
		       (null? (cdr maybe-default-thunk)))
		  ((car maybe-default-thunk))
		  (oops)))))))

(define (arg arglist n . maybe-default)
  (if maybe-default (arg* arglist n (lambda () (car maybe-default)))
      (arg* arglist n)))

(define (argv n . maybe-default)
  (apply arg %command-line (+ n 1) maybe-default))

(define (command-line) (append %command-line '()))

;;; EXEC support
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Assumes a low-level %exec procedure:
;;; (%exec prog arglist env)
;;;   ENV is either #t, meaning the current environment, or a string->string
;;;       alist.
;;;   %EXEC stringifies PROG and the elements of ARGLIST.

(define (stringify thing)
  (cond ((string? thing) thing)
	((symbol? thing)
	 (symbol->string thing))
;	((symbol? thing)
;	 (list->string (map char-downcase
;			    (string->list (symbol->string thing)))))
	((integer? thing)
	 (number->string thing))
	(else (error "Can only stringify strings, symbols, and integers."
		     thing))))

(define (exec-path-search prog path-list)
  (if (file-name-absolute? prog)
      (and (file-executable? prog) prog)
      (first? (lambda (dir)
		(let ((fname (string-append dir "/" prog)))
		  (and (file-executable? fname) fname)))
	     path-list)))
		    
(define (exec/env prog env . arglist)
  (flush-all-ports)
  (with-env-aligned* 
   (lambda ()
     (with-cwd-aligned*
      (lambda ()
	(with-umask-aligned*
	 (lambda ()
	   (%exec prog (cons prog arglist) env))))))))

;(define (exec-path/env prog env . arglist)
;  (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) =>
;	 (lambda (binary)
;	   (apply exec/env binary env arglist)))
;	(else (error "No executable found." prog arglist))))

;;; This procedure is bummed by tying in directly to %%exec/errno
;;; and pulling some of %exec's code out of the inner loop so that
;;; the inner loop will be fast. Folks don't like waiting...

(define (exec-path/env prog env . arglist)
  (flush-all-ports)
  (with-env-aligned*
   (lambda ()
     (with-cwd-aligned*
      (lambda ()
	(with-umask-aligned*
	 (lambda ()
	   (let ((prog (stringify prog)))
	     (if (string-index prog #\/)
		 
		 ;; Contains a slash -- no path search.
		 (%exec prog (cons prog arglist) env)
		 
		 ;; Try each directory in PATH-LIST.
		 (let ((argv (list->vector (cons prog (map stringify arglist)))))
		   (for-each (lambda (dir)
			       (let ((binary (string-append dir "/" prog)))
				 (%%exec/errno binary argv env)))
			     (fluid exec-path-list)))))
	   
	   (error "No executable found." prog arglist))))))))
   
(define (exec-path prog . arglist)
  (apply exec-path/env prog #t arglist))

(define (exec prog . arglist)
  (apply exec/env prog #t arglist))


;;; Assumes niladic primitive %%FORK.

(define (fork . maybe-thunk)
  (flush-all-ports)
  (really-fork #t maybe-thunk))

(define (%fork . maybe-thunk)
  (really-fork #f maybe-thunk))


(define (really-fork clear-interactive? maybe-thunk)
  (with-env-aligned* ; not neccessary here but doing it on exec
                     ; genereates no cache in the parent
   (lambda ()
   (((structure-ref interrupts with-interrupts-inhibited) (lambda ()
     (let ((pid (%%fork)))
       (if (zero? pid)				

	   ;; Child
	   (lambda ()	; Do all this outside the WITH-INTERRUPTS.
;	     (set! reaped-procs '())

	     ;;; There is no session if parent was started in batch-mode
	     (if (and (session-started?) clear-interactive?)
		 (set-batch-mode?! #t))	; Children are non-interactive.
	     (and (pair? maybe-thunk)
		  (call-terminally (car maybe-thunk))))

	   ;; Parent
	   (let ((proc (new-child-proc pid)))
	     (lambda () proc))))))))))


(define (exit . maybe-status)
  (flush-all-ports)
  (exit/errno (:optional  maybe-status 0))
  (display "The evil undead walk the earth." 2)
  (if #t (error "(exit) returned.")))


;;; The classic T 2.0 primitive.
;;; This definition works for procedures running on top of Unix systems.
(define (halts? proc) #t)


;;; Low-level init absolutely required for any scsh program.

(define (init-scsh-hindbrain relink-ff?)
  (if #t (error "call to init-scsh-hindbrain which is dead"))
;  (if relink-ff? (lookup-all-externals)) ; Re-link C calls.
;  (init-fdports!)
;  (%install-unix-scsh-handlers)
)


;;; Some globals:
(define home-directory "")
(define exec-path-list (make-fluid '()))

(define (init-scsh-vars quietly?)
  (set! home-directory
	(cond ((getenv "HOME") => ensure-file-name-is-nondirectory)
	      (else (if (not quietly?)
			(warn "Starting up with no home directory ($HOME)."))
		    "/")))
  (set-fluid! exec-path-list
	      (cond ((getenv "PATH") => split-colon-list)
		    (else (if (not quietly?)
			      (warn "Starting up with no path ($PATH)."))
			  '()))))


; SIGTSTP blows s48 away. ???
(define (suspend) (signal-process 0 signal/stop))