shell.scm (6574B)
1 ;; Shell-style Scheme library: processes and file I/O. 2 ;; 3 ;; Primitives required from the runtime: 4 ;; (sys-exit code) 5 ;; (sys-clone) → (#t . pid) parent, (#t . 0) child, 6 ;; (#f . errno) on failure 7 ;; (sys-execve path argv) → only returns (#f . errno) on failure; 8 ;; parent env is inherited by the child 9 ;; (sys-wait pid) → (ok . raw-wstatus) 10 ;; (sys-openat dirfd path flags mode) → (ok . fd) 11 ;; (sys-close fd) → (ok . _) 12 ;; (sys-read fd buf count) → (ok . nread), fills buf[0..nread] 13 ;; (sys-write fd buf count) → (ok . nwritten), writes buf[0..count] 14 ;; (sys-argv) → list of bytevectors (argv[0..]); 15 ;; cannot fail, not wrapped in (ok . val) 16 ;; 17 ;; All wrappers that touch syscalls return a pair (ok . val): 18 ;; ok = #t → val is the result 19 ;; ok = #f → val is an errno 20 21 ;; ============================================================ 22 ;; processes 23 ;; ============================================================ 24 25 (define (spawn prog . args) 26 (let ((r (sys-clone))) 27 (cond 28 ((not (car r)) r) 29 ((zero? (cdr r)) 30 (sys-execve prog (cons prog args)) 31 (sys-exit 127)) 32 (else r)))) 33 34 (define (wait pid) 35 (let ((r (sys-wait pid))) 36 (if (car r) 37 (cons #t (decode-wait-status (cdr r))) 38 r))) 39 40 (define (run prog . args) 41 (let ((r (apply spawn prog args))) 42 (if (car r) (wait (cdr r)) r))) 43 44 (define (exit . rest) 45 (sys-exit (if (null? rest) 0 (car rest)))) 46 47 (define (argv) (sys-argv)) 48 49 ;; POSIX wstatus → shell-style code (128+sig for signal termination). 50 (define (decode-wait-status s) 51 (let ((termsig (bit-and s #x7f))) 52 (if (zero? termsig) 53 (bit-and (arithmetic-shift s -8) #xff) 54 (+ 128 termsig)))) 55 56 ;; ============================================================ 57 ;; file I/O 58 ;; ============================================================ 59 60 (define BUFSIZE 4096) 61 (define AT_FDCWD -100) 62 (define O_RDONLY 0) 63 (define O_WRONLY 1) 64 (define O_CREAT #x40) ; 0o100 65 (define O_TRUNC #x200) ; 0o1000 66 (define O_APPEND #x400) ; 0o2000 67 (define MODE_644 #x1a4) ; 0o644 68 (define NL-BYTE 10) 69 (define NL-BV (make-bytevector 1 10)) 70 71 (define-record-type port 72 (%port fd buf pos end) 73 port? 74 (fd port-fd) 75 (buf port-buf) 76 (pos port-pos port-pos-set!) 77 (end port-end port-end-set!)) 78 79 (define stdin (%port 0 (make-bytevector BUFSIZE) 0 0)) 80 (define stdout (%port 1 #f 0 0)) 81 (define stderr (%port 2 #f 0 0)) 82 83 (define (open-input path) 84 (let ((r (sys-openat AT_FDCWD path O_RDONLY 0))) 85 (if (car r) 86 (cons #t (%port (cdr r) (make-bytevector BUFSIZE) 0 0)) 87 r))) 88 89 (define (open-output path) 90 (let ((r (sys-openat AT_FDCWD path 91 (bit-or O_WRONLY O_CREAT O_TRUNC) MODE_644))) 92 (if (car r) (cons #t (%port (cdr r) #f 0 0)) r))) 93 94 (define (open-append path) 95 (let ((r (sys-openat AT_FDCWD path 96 (bit-or O_WRONLY O_CREAT O_APPEND) MODE_644))) 97 (if (car r) (cons #t (%port (cdr r) #f 0 0)) r))) 98 99 (define (close p) (sys-close (port-fd p))) 100 101 ;; ----- reads ----- 102 103 (define (refill! p) 104 (let ((r (sys-read (port-fd p) (port-buf p) BUFSIZE))) 105 (cond 106 ((not (car r)) r) 107 (else (port-pos-set! p 0) 108 (port-end-set! p (cdr r)) 109 r)))) 110 111 (define (read-bytes p n) 112 (let ((out (make-bytevector n))) 113 (let loop ((i 0)) 114 (cond 115 ((= i n) (cons #t out)) 116 ((< (port-pos p) (port-end p)) 117 (let* ((avail (- (port-end p) (port-pos p))) 118 (take (if (< avail (- n i)) avail (- n i)))) 119 (bytevector-copy! out i (port-buf p) (port-pos p) take) 120 (port-pos-set! p (+ (port-pos p) take)) 121 (loop (+ i take)))) 122 (else 123 (let ((r (refill! p))) 124 (cond 125 ((not (car r)) r) 126 ((zero? (cdr r)) 127 (cons #t (if (zero? i) (eof-object) (bytevector-copy out 0 i)))) 128 (else (loop i))))))))) 129 130 (define (read-line p) 131 (let loop ((acc '())) 132 (cond 133 ((< (port-pos p) (port-end p)) 134 (let* ((buf (port-buf p)) 135 (start (port-pos p)) 136 (end (port-end p))) 137 (let scan ((i start)) 138 (cond 139 ((= i end) 140 (port-pos-set! p i) 141 (loop (cons (bytevector-copy buf start i) acc))) 142 ((= (bytevector-u8-ref buf i) NL-BYTE) 143 (port-pos-set! p (+ i 1)) 144 (cons #t (bv-concat-reverse 145 (cons (bytevector-copy buf start i) acc)))) 146 (else (scan (+ i 1))))))) 147 (else 148 (let ((r (refill! p))) 149 (cond 150 ((not (car r)) r) 151 ((zero? (cdr r)) 152 (cons #t (if (null? acc) (eof-object) (bv-concat-reverse acc)))) 153 (else (loop acc)))))))) 154 155 (define (read-all p) 156 (let loop ((acc '())) 157 (cond 158 ((< (port-pos p) (port-end p)) 159 (let ((chunk (bytevector-copy (port-buf p) 160 (port-pos p) (port-end p)))) 161 (port-pos-set! p (port-end p)) 162 (loop (cons chunk acc)))) 163 (else 164 (let ((r (refill! p))) 165 (cond 166 ((not (car r)) r) 167 ((zero? (cdr r)) (cons #t (bv-concat-reverse acc))) 168 (else (loop acc)))))))) 169 170 (define (bv-concat-reverse chunks) 171 (let* ((xs (reverse chunks)) 172 (total (let sum ((ys xs) (n 0)) 173 (if (null? ys) n 174 (sum (cdr ys) (+ n (bytevector-length (car ys))))))) 175 (out (make-bytevector total))) 176 (let loop ((ys xs) (i 0)) 177 (if (null? ys) 178 out 179 (let ((len (bytevector-length (car ys)))) 180 (bytevector-copy! out i (car ys) 0 len) 181 (loop (cdr ys) (+ i len))))))) 182 183 ;; ----- writes (unbuffered; handle partial writes) ----- 184 185 (define (write-bytes p bv) 186 (let loop ((bv bv) (total 0)) 187 (let ((len (bytevector-length bv))) 188 (if (zero? len) 189 (cons #t total) 190 (let ((r (sys-write (port-fd p) bv len))) 191 (cond 192 ((not (car r)) r) 193 ((= (cdr r) len) (cons #t (+ total len))) 194 (else (loop (bytevector-copy bv (cdr r) len) 195 (+ total (cdr r)))))))))) 196 197 (define write-string write-bytes) 198 199 (define (write-line p s) 200 (let ((r (write-bytes p s))) 201 (if (car r) (write-bytes p NL-BV) r)))