;;; 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.
;; JMG: this should spawn a thread to prevent deadlocking the vm
(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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record env
c-struct ; An alien -- pointer to an envvec struct
alist) ; Corresponding alist
;;; Once more, Olin's define-record is not sufficient
(define (make-environ c-struct alist)
(let ((env (make-env c-struct alist)))
(add-finalizer! env env-finalizer)
env))
(define (env-finalizer env)
(display "freeing env")
(%free-env (env:c-struct env)))
(define env-lock (make-lock))
(define current-process-env #f)
(define $current-env #f)
(define (install-env)
(set! current-process-env
(make-threads-env (environ-env->alist)))
(set! $current-env (make-fluid current-process-env))
(%align-env (env:c-struct (current-env))))
(define (make-threads-env alist)
(make-environ (alist->envvec alist) alist))
(define (current-env) (fluid $current-env))
(define (align-env!)
(let ((current-env-val (current-env)))
(if (not (eq? current-env-val current-process-env))
(begin (%align-env (env:c-struct current-env-val))
(set! current-process-env current-env-val)))))
(define (with-env-aligned* thunk)
(dynamic-wind (lambda ()
(with-lock env-lock
align-env!))
thunk values))
(define (with-total-env* alist thunk)
(let-fluid $current-env (make-threads-env alist) thunk))
(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)))
(let-fluid $current-env (make-threads-env new-env) thunk)))
;(define (lp) (display (getenv "BLA")) (sleep 2000) (lp))
(define (env->alist)
(with-env-aligned*
(lambda ()
(environ-env->alist))))
(define (alist->env alist)
(with-env-aligned*
(lambda ()
(let ((env (current-env)))
(envvec-alist->env alist)
(set-env:alist env alist)))))
(define (delete-env name)
(let ((env (current-env)))
(set-env:alist env (alist-delete name (env:alist env))))
(envvec-delete-env name))
(define (setenv name value)
(with-env-aligned*
(lambda ()
(if value
(begin
(envvec-setenv name value)
(let ((env (current-env)))
(set-env:alist env (alist-update name value (env:alist env)))))
(delete-env name)))))
(define (getenv name)
(with-env-aligned*
(lambda ()
(let* ((here (assoc name (env:alist (current-env))))
(here (if here (cdr here) here)))
(if (not (equal? here (envvec-getenv name)))
(error "not equal" here (envvec-getenv name))
here)))))
;;; 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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; working directory per thread
;;; this reflects the cwd of the process
(define-record cache
cwd)
(define-record-resumer type/cache
(lambda (cache)
(set-cache:cwd cache (process-cwd)))) ; set the cache to an impossible filename.
(define *unix-cwd*
(make-cache (process-cwd))) ; Initialise the cache to an impossible filename.
(define (unix-cwd)
(cache:cwd *unix-cwd*))
(define cwd-lock (make-lock))
;;; Actually do the syscall and update the cache
;;; assumes the cwd lock obtained
(define (chdir-and-cache dir)
(process-chdir dir)
(set-cache:cwd *unix-cwd* (process-cwd)))
;;; 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
;;; 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))))
;;; The thread-specific CWD: A fluid
(define-record state
cwd)
(define-record-resumer type/state
(lambda (state)
(set-state:cwd state (make-fluid (process-cwd)))))
(define $cwd (make-state (make-fluid (process-cwd))))
(define (cwd) (fluid (state:cwd $cwd)))
(define (set-cwd! dir) (set-fluid! (state:cwd $cwd) dir))
(define (let-cwd dir thunk)
(let-fluid (state:cwd $cwd) dir thunk))
(define (with-cwd* dir thunk)
(let ((changed-dir #f))
(with-lock cwd-lock
(lambda ()
(align-cwd!)
(chdir-and-cache dir)
(set! changed-dir (unix-cwd))))
(let-cwd changed-dir thunk)))
;; Align the Unix CWD with the scsh CWD.
;; Since another thread could disalign, this call and
;; any ensuing syscall that relies upon it should
;; be "glued together" with the cwd lock.
(define (align-cwd!)
(let ((dir (cwd)))
(if (not (string=? dir (unix-cwd)))
(chdir-and-cache dir))))
(define (chdir dir)
(with-lock cwd-lock
(lambda ()
(align-cwd!)
(chdir-and-cache dir)
(set-cwd! (unix-cwd)))))
;;; 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 cwd, do
;;; the syscall, turn them back on.
(define (with-cwd-aligned* thunk)
(dynamic-wind (lambda ()
(with-lock cwd-lock
align-cwd!))
thunk
values))
;;; example syscall
;;; (define (exported-delete-file fname)
;;;; (with-cwd-aligned (really-delete-file fname)))
;;; umask
(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-cwd-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 ()
(%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 ()
(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)
(((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))