scsh-0.5/scsh/scsh.scm

761 lines
23 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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 #f (lambda () (thunk) (exit 0))))
;; Alternatively: (with-continuation #f thunk)
;;; More portably, but less usefully:
;;; (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))
;;; Environment stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 ((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))))
;; Tail-recursive loops suck.
;; (define (alist-compress alist)
;; (loop (initial (ans '()))
;; (for key/val in alist)
;;
;; (when (not (assoc (car key/val) ans)))
;; (next (ans (cons key/val ans)))
;;
;; (result (reverse 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)))
;;; Or, just say...
;;; (reverse (add-before elt after (reverse list)))
(define (with-env* alist-delta thunk)
(let* ((old-env #f)
(new-env (reduce (lambda (alist key/val)
(alist-update (car key/val) (cdr key/val) alist))
(env->alist)
alist-delta)))
(dynamic-wind
(lambda ()
(set! old-env (env->alist))
(alist->env new-env))
thunk
(lambda ()
(set! new-env (env->alist))
(alist->env old-env)))))
(define (with-total-env* alist thunk)
(let ((old-env (env->alist)))
(dynamic-wind
(lambda ()
(set! old-env (env->alist))
(alist->env alist))
thunk
(lambda ()
(set! alist (env->alist))
(alist->env old-env)))))
(define (with-cwd* dir thunk)
(let ((old-wd #f))
(dynamic-wind
(lambda ()
(set! old-wd (cwd))
(chdir dir))
thunk
(lambda ()
(set! dir (cwd))
(chdir old-wd)))))
(define (with-umask* mask thunk)
(let ((old-mask #f))
(dynamic-wind
(lambda ()
(set! old-mask (umask))
(set-umask mask))
thunk
(lambda ()
(set! mask (umask))
(set-umask old-mask)))))
;;; Sugar:
(define-simple-syntax (with-cwd dir . body)
(with-cwd* dir (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 "/usr/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 (car maybe-prefix) ".~a"))))))
(define *temp-file-template*
(make-fluid (string-append "/usr/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)))))))))
;;; 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.
;;; (reduce-port 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.
;;; PORT->LIST is just (REDUCE-PORT 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 (reduce-port port reader op . seeds)
(letrec ((reduce (lambda seeds
(let ((x (reader port)))
(if (eof-object? x) (apply values seeds)
(call-with-values (lambda () (apply op x seeds))
reduce))))))
(apply reduce seeds)))
;;; 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-error-output-port! (fdes->outport 2)))
(define (with-stdio-ports* thunk)
(with-current-input-port (fdes->inport 0)
(with-current-output-port (fdes->outport 1)
(with-error-output-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 (error-output-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)
(%exec prog (cons prog arglist) env))
;(define (exec-path/env prog env . arglist)
; (cond ((exec-path-search (stringify prog) 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)
(let ((prog (stringify prog)))
(if (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)))
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-enabled-interrupts 0
(let ((pid (%%fork)))
(if (zero? pid)
;; Child
(lambda () ; Do all this outside the WITH-INTERRUPTS.
(set! reaped-procs '())
(if 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)
(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 relink-ff? (lookup-all-externals)) ; Re-link C calls.
(init-fdports!)
(%install-unix-scsh-handlers))
;;; Some globals:
(define home-directory "")
(define exec-path-list '())
(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! 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))