commit 592d347926f1abf565a5cd11a360a18a3a645432
parent 2dfba4fcce1a94138f06d44d816896ca76f89065
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Thu, 23 Apr 2026 20:09:14 -0700
shell.scm
Diffstat:
| A | lisp/shell.scm | | | 201 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 201 insertions(+), 0 deletions(-)
diff --git a/lisp/shell.scm b/lisp/shell.scm
@@ -0,0 +1,201 @@
+;; Shell-style Scheme library: processes and file I/O.
+;;
+;; Primitives required from the runtime:
+;; (sys-exit code)
+;; (sys-clone) → (#t . pid) parent, (#t . 0) child,
+;; (#f . errno) on failure
+;; (sys-execve path argv) → only returns (#f . errno) on failure;
+;; parent env is inherited by the child
+;; (sys-wait pid) → (ok . raw-wstatus)
+;; (sys-openat dirfd path flags mode) → (ok . fd)
+;; (sys-close fd) → (ok . _)
+;; (sys-read fd buf count) → (ok . nread), fills buf[0..nread]
+;; (sys-write fd buf count) → (ok . nwritten), writes buf[0..count]
+;; (sys-argv) → list of bytevectors (argv[0..]);
+;; cannot fail, not wrapped in (ok . val)
+;;
+;; All wrappers that touch syscalls return a pair (ok . val):
+;; ok = #t → val is the result
+;; ok = #f → val is an errno
+
+;; ============================================================
+;; processes
+;; ============================================================
+
+(define (spawn prog . args)
+ (let ((r (sys-clone)))
+ (cond
+ ((not (car r)) r)
+ ((zero? (cdr r))
+ (sys-execve prog (cons prog args))
+ (sys-exit 127))
+ (else r))))
+
+(define (wait pid)
+ (let ((r (sys-wait pid)))
+ (if (car r)
+ (cons #t (decode-wait-status (cdr r)))
+ r)))
+
+(define (run prog . args)
+ (let ((r (apply spawn prog args)))
+ (if (car r) (wait (cdr r)) r)))
+
+(define (exit . rest)
+ (sys-exit (if (null? rest) 0 (car rest))))
+
+(define (argv) (sys-argv))
+
+;; POSIX wstatus → shell-style code (128+sig for signal termination).
+(define (decode-wait-status s)
+ (let ((termsig (bit-and s #x7f)))
+ (if (zero? termsig)
+ (bit-and (arithmetic-shift s -8) #xff)
+ (+ 128 termsig))))
+
+;; ============================================================
+;; file I/O
+;; ============================================================
+
+(define BUFSIZE 4096)
+(define AT_FDCWD -100)
+(define O_RDONLY 0)
+(define O_WRONLY 1)
+(define O_CREAT #x40) ; 0o100
+(define O_TRUNC #x200) ; 0o1000
+(define O_APPEND #x400) ; 0o2000
+(define MODE_644 #x1a4) ; 0o644
+(define NL-BYTE 10)
+(define NL-BV (make-bytevector 1 10))
+
+(define-record-type port
+ (%port fd buf pos end)
+ port?
+ (fd port-fd)
+ (buf port-buf)
+ (pos port-pos port-pos-set!)
+ (end port-end port-end-set!))
+
+(define stdin (%port 0 (make-bytevector BUFSIZE) 0 0))
+(define stdout (%port 1 #f 0 0))
+(define stderr (%port 2 #f 0 0))
+
+(define (open-input path)
+ (let ((r (sys-openat AT_FDCWD path O_RDONLY 0)))
+ (if (car r)
+ (cons #t (%port (cdr r) (make-bytevector BUFSIZE) 0 0))
+ r)))
+
+(define (open-output path)
+ (let ((r (sys-openat AT_FDCWD path
+ (bit-or O_WRONLY O_CREAT O_TRUNC) MODE_644)))
+ (if (car r) (cons #t (%port (cdr r) #f 0 0)) r)))
+
+(define (open-append path)
+ (let ((r (sys-openat AT_FDCWD path
+ (bit-or O_WRONLY O_CREAT O_APPEND) MODE_644)))
+ (if (car r) (cons #t (%port (cdr r) #f 0 0)) r)))
+
+(define (close p) (sys-close (port-fd p)))
+
+;; ----- reads -----
+
+(define (refill! p)
+ (let ((r (sys-read (port-fd p) (port-buf p) BUFSIZE)))
+ (cond
+ ((not (car r)) r)
+ (else (port-pos-set! p 0)
+ (port-end-set! p (cdr r))
+ r))))
+
+(define (read-bytes p n)
+ (let ((out (make-bytevector n)))
+ (let loop ((i 0))
+ (cond
+ ((= i n) (cons #t out))
+ ((< (port-pos p) (port-end p))
+ (let* ((avail (- (port-end p) (port-pos p)))
+ (take (if (< avail (- n i)) avail (- n i))))
+ (bytevector-copy! out i (port-buf p) (port-pos p) take)
+ (port-pos-set! p (+ (port-pos p) take))
+ (loop (+ i take))))
+ (else
+ (let ((r (refill! p)))
+ (cond
+ ((not (car r)) r)
+ ((zero? (cdr r))
+ (cons #t (if (zero? i) (eof-object) (bytevector-copy out 0 i))))
+ (else (loop i)))))))))
+
+(define (read-line p)
+ (let loop ((acc '()))
+ (cond
+ ((< (port-pos p) (port-end p))
+ (let* ((buf (port-buf p))
+ (start (port-pos p))
+ (end (port-end p)))
+ (let scan ((i start))
+ (cond
+ ((= i end)
+ (port-pos-set! p i)
+ (loop (cons (bytevector-copy buf start i) acc)))
+ ((= (bytevector-u8-ref buf i) NL-BYTE)
+ (port-pos-set! p (+ i 1))
+ (cons #t (bv-concat-reverse
+ (cons (bytevector-copy buf start i) acc))))
+ (else (scan (+ i 1)))))))
+ (else
+ (let ((r (refill! p)))
+ (cond
+ ((not (car r)) r)
+ ((zero? (cdr r))
+ (cons #t (if (null? acc) (eof-object) (bv-concat-reverse acc))))
+ (else (loop acc))))))))
+
+(define (read-all p)
+ (let loop ((acc '()))
+ (cond
+ ((< (port-pos p) (port-end p))
+ (let ((chunk (bytevector-copy (port-buf p)
+ (port-pos p) (port-end p))))
+ (port-pos-set! p (port-end p))
+ (loop (cons chunk acc))))
+ (else
+ (let ((r (refill! p)))
+ (cond
+ ((not (car r)) r)
+ ((zero? (cdr r)) (cons #t (bv-concat-reverse acc)))
+ (else (loop acc))))))))
+
+(define (bv-concat-reverse chunks)
+ (let* ((xs (reverse chunks))
+ (total (let sum ((ys xs) (n 0))
+ (if (null? ys) n
+ (sum (cdr ys) (+ n (bytevector-length (car ys)))))))
+ (out (make-bytevector total)))
+ (let loop ((ys xs) (i 0))
+ (if (null? ys)
+ out
+ (let ((len (bytevector-length (car ys))))
+ (bytevector-copy! out i (car ys) 0 len)
+ (loop (cdr ys) (+ i len)))))))
+
+;; ----- writes (unbuffered; handle partial writes) -----
+
+(define (write-bytes p bv)
+ (let loop ((bv bv) (total 0))
+ (let ((len (bytevector-length bv)))
+ (if (zero? len)
+ (cons #t total)
+ (let ((r (sys-write (port-fd p) bv len)))
+ (cond
+ ((not (car r)) r)
+ ((= (cdr r) len) (cons #t (+ total len)))
+ (else (loop (bytevector-copy bv (cdr r) len)
+ (+ total (cdr r))))))))))
+
+(define write-string write-bytes)
+
+(define (write-line p s)
+ (let ((r (write-bytes p s)))
+ (if (car r) (write-bytes p NL-BV) r)))
