prelude.scm (24085B)
1 ; scheme1 prelude. catm'd in front of the user .scm before invoking the 2 ; scheme1 binary (see scripts/boot-run-scheme1.sh). Defines the R7RS 3 ; surface that's expressible over scheme1's existing primitives -- 4 ; equivalence aliases, list helpers, characters as fixnum bytes, 5 ; strings as NUL-terminated bytevectors -- plus the shell.scm process- 6 ; management and file-I/O layer (port record + buffered reads/writes). 7 ; 8 ; Items that depend on primitives scheme1 doesn't yet have (the 9 ; vector-* family) stay here as commented placeholders for re-enabling 10 ; once those primitives land. See docs/SCHEME1-R7RS-TODO.md. 11 12 ;; --- Arithmetic helpers (derivable from <, =, -) -------------------- 13 (define (<= x y) (if (< y x) #f #t)) 14 (define (>= x y) (if (< x y) #f #t)) 15 16 (define (negative? x) (< x 0)) 17 (define (positive? x) (> x 0)) 18 19 ;; scheme1 has only one numeric and one byte-string repr today, so these 20 ;; predicates are exact aliases. They exist so callers can spell intent. 21 (define number? integer?) 22 (define bytevector? string?) 23 24 (define (abs x) (if (< x 0) (- 0 x) x)) 25 26 (define (min a b) (if (< a b) a b)) 27 (define (max a b) (if (< a b) b a)) 28 29 ;; modulo has the sign of the divisor; remainder has the sign of the 30 ;; dividend. They differ exactly when r is nonzero and r and b have 31 ;; opposite signs -- in that case adjust by adding b. 32 (define (modulo a b) 33 (let ((r (remainder a b))) 34 (if (zero? r) 35 0 36 (if (eq? (negative? r) (negative? b)) 37 r 38 (+ r b))))) 39 40 ;; --- R7RS equivalence / equality predicates ------------------------ 41 ;; eqv? collapses to eq? for our value set: fixnums are immediate- 42 ;; tagged, symbols are interned, and pairs/strings/closures use 43 ;; pointer identity. 44 (define eqv? eq?) 45 46 (define (%all-eq? a xs) 47 (if (null? xs) #t 48 (if (eq? (car xs) a) (%all-eq? a (cdr xs)) #f))) 49 50 (define (boolean=? a b . rest) (and (eq? a b) (%all-eq? a rest))) 51 (define (symbol=? a b . rest) (and (eq? a b) (%all-eq? a rest))) 52 53 ;; --- c*r compositions ---------------------------------------------- 54 (define (caar x) (car (car x))) 55 (define (cadr x) (car (cdr x))) 56 (define (cdar x) (cdr (car x))) 57 (define (cddr x) (cdr (cdr x))) 58 59 (define (caaar x) (car (caar x))) 60 (define (caadr x) (car (cadr x))) 61 (define (cadar x) (car (cdar x))) 62 (define (caddr x) (car (cddr x))) 63 (define (cdaar x) (cdr (caar x))) 64 (define (cdadr x) (cdr (cadr x))) 65 (define (cddar x) (cdr (cdar x))) 66 (define (cdddr x) (cdr (cddr x))) 67 68 (define (caaaar x) (car (caaar x))) 69 (define (caaadr x) (car (caadr x))) 70 (define (caadar x) (car (cadar x))) 71 (define (caaddr x) (car (caddr x))) 72 (define (cadaar x) (car (cdaar x))) 73 (define (cadadr x) (car (cdadr x))) 74 (define (caddar x) (car (cddar x))) 75 (define (cadddr x) (car (cdddr x))) 76 (define (cdaaar x) (cdr (caaar x))) 77 (define (cdaadr x) (cdr (caadr x))) 78 (define (cdadar x) (cdr (cadar x))) 79 (define (cdaddr x) (cdr (caddr x))) 80 (define (cddaar x) (cdr (cdaar x))) 81 (define (cddadr x) (cdr (cdadr x))) 82 (define (cdddar x) (cdr (cddar x))) 83 (define (cddddr x) (cdr (cdddr x))) 84 85 ;; --- List helpers -------------------------------------------------- 86 (define (list . xs) xs) 87 88 (define (list? x) 89 (if (null? x) 90 #t 91 (if (pair? x) (list? (cdr x)) #f))) 92 93 (define (append-pair a b) 94 (if (null? a) b (cons (car a) (append-pair (cdr a) b)))) 95 96 (define (append . lists) 97 (cond ((null? lists) (quote ())) 98 ((null? (cdr lists)) (car lists)) 99 (else (append-pair (car lists) (apply append (cdr lists)))))) 100 101 (define (make-list n . fill) 102 (let ((v (if (null? fill) #f (car fill)))) 103 (let loop ((i 0) (acc (quote ()))) 104 (if (= i n) acc (loop (+ i 1) (cons v acc)))))) 105 106 (define (list-tail xs k) 107 (if (zero? k) xs (list-tail (cdr xs) (- k 1)))) 108 109 (define (list-set! xs k v) 110 (if (zero? k) (set-car! xs v) (list-set! (cdr xs) (- k 1) v))) 111 112 (define (list-copy xs) 113 (if (pair? xs) 114 (cons (car xs) (list-copy (cdr xs))) 115 xs)) 116 117 (define (memq x xs) 118 (if (null? xs) #f 119 (if (eq? (car xs) x) xs (memq x (cdr xs))))) 120 (define memv memq) 121 (define (member x xs) 122 (if (null? xs) #f 123 (if (equal? (car xs) x) xs (member x (cdr xs))))) 124 125 (define assv assq) 126 127 ;; --- map / filter / fold / for-each -------------------------------- 128 ;; map and for-each accept N parallel lists per R7RS; iteration stops 129 ;; at the shortest list. The %any-null?/%list-cars/%list-cdrs helpers 130 ;; back the multi-list path. 131 (define (%any-null? xss) 132 (if (null? xss) #f 133 (if (null? (car xss)) #t (%any-null? (cdr xss))))) 134 (define (%list-cars xss) 135 (if (null? xss) (quote ()) 136 (cons (car (car xss)) (%list-cars (cdr xss))))) 137 (define (%list-cdrs xss) 138 (if (null? xss) (quote ()) 139 (cons (cdr (car xss)) (%list-cdrs (cdr xss))))) 140 141 (define (map f xs . rest) 142 (if (null? rest) 143 (let m ((xs xs)) 144 (if (null? xs) (quote ()) 145 (cons (f (car xs)) (m (cdr xs))))) 146 (let m ((xss (cons xs rest))) 147 (if (%any-null? xss) (quote ()) 148 (cons (apply f (%list-cars xss)) 149 (m (%list-cdrs xss))))))) 150 151 (define (filter p xs) 152 (if (null? xs) 153 (quote ()) 154 (if (p (car xs)) 155 (cons (car xs) (filter p (cdr xs))) 156 (filter p (cdr xs))))) 157 158 (define (fold f acc xs) 159 (if (null? xs) 160 acc 161 (fold f (f acc (car xs)) (cdr xs)))) 162 163 (define (for-each f xs . rest) 164 (if (null? rest) 165 (let m ((xs xs)) 166 (if (null? xs) (quote ()) 167 (begin (f (car xs)) (m (cdr xs))))) 168 (let m ((xss (cons xs rest))) 169 (if (%any-null? xss) (quote ()) 170 (begin (apply f (%list-cars xss)) 171 (m (%list-cdrs xss))))))) 172 173 ;; --- R7RS character procedures (ASCII over fixnum bytes) ----------- 174 ;; Chars are plain fixnums; char? is a 0..255 range check rather than 175 ;; a disjoint type. char->integer / integer->char are the identity. 176 (define (char? x) 177 (if (integer? x) 178 (if (< x 0) #f (< x 256)) 179 #f)) 180 181 (define (char->integer c) c) 182 (define (integer->char n) n) 183 184 (define (char-upper-case? c) (and (>= c 65) (<= c 90))) 185 (define (char-lower-case? c) (and (>= c 97) (<= c 122))) 186 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) 187 (define (char-numeric? c) (and (>= c 48) (<= c 57))) 188 (define (char-whitespace? c) 189 (or (= c 32) (= c 9) (= c 10) (= c 11) (= c 12) (= c 13))) 190 191 (define (digit-value c) (if (char-numeric? c) (- c 48) #f)) 192 193 (define (char-upcase c) (if (char-lower-case? c) (- c 32) c)) 194 (define (char-downcase c) (if (char-upper-case? c) (+ c 32) c)) 195 (define char-foldcase char-downcase) 196 197 (define (%chain-rel rel a b rest) 198 (if (rel a b) 199 (if (null? rest) #t (%chain-rel rel b (car rest) (cdr rest))) 200 #f)) 201 202 (define (char=? a b . rest) (%chain-rel = a b rest)) 203 (define (char<? a b . rest) (%chain-rel < a b rest)) 204 (define (char>? a b . rest) (%chain-rel > a b rest)) 205 (define (char<=? a b . rest) (%chain-rel <= a b rest)) 206 (define (char>=? a b . rest) (%chain-rel >= a b rest)) 207 208 ;; --- R7RS string procedures (over NUL-terminated bytevectors) ------ 209 ;; A scheme1 "string" is a bytevector whose first NUL byte marks the 210 ;; logical end. Constructors allocate (n+1) bytes and store 0 at index 211 ;; n. string-ref / string-set! are thin aliases over the bytevector 212 ;; primitives; bounds against string-length aren't enforced (the user 213 ;; can clobber the NUL terminator). 214 (define (make-string n . fill) 215 (let ((c (if (null? fill) 32 (car fill)))) 216 (let ((bv (make-bytevector (+ n 1) c))) 217 (bytevector-u8-set! bv n 0) 218 bv))) 219 220 (define (string . cs) 221 (let* ((n (length cs)) 222 (bv (make-bytevector (+ n 1) 0))) 223 (let loop ((xs cs) (i 0)) 224 (if (null? xs) bv 225 (begin 226 (bytevector-u8-set! bv i (car xs)) 227 (loop (cdr xs) (+ i 1))))))) 228 229 (define string-ref bytevector-u8-ref) 230 (define string-set! bytevector-u8-set!) 231 232 (define (substring s start end) 233 (let* ((n (- end start)) 234 (out (make-bytevector (+ n 1) 0))) 235 (bytevector-copy! out 0 s start end) 236 out)) 237 238 (define (string-append . ss) 239 (let ((total (let sum ((xs ss) (n 0)) 240 (if (null? xs) n 241 (sum (cdr xs) (+ n (string-length (car xs)))))))) 242 (let ((out (make-bytevector (+ total 1) 0))) 243 (let loop ((xs ss) (off 0)) 244 (if (null? xs) out 245 (let ((len (string-length (car xs)))) 246 (bytevector-copy! out off (car xs) 0 len) 247 (loop (cdr xs) (+ off len)))))))) 248 249 (define (string-copy s . args) 250 (let* ((start (if (null? args) 0 (car args))) 251 (rs (if (null? args) (quote ()) (cdr args))) 252 (end (if (null? rs) (string-length s) (car rs)))) 253 (substring s start end))) 254 255 (define (string-copy! dst at src . args) 256 (let* ((start (if (null? args) 0 (car args))) 257 (rs (if (null? args) (quote ()) (cdr args))) 258 (end (if (null? rs) (string-length src) (car rs)))) 259 (bytevector-copy! dst at src start end))) 260 261 (define (string-fill! s ch . args) 262 (let* ((start (if (null? args) 0 (car args))) 263 (rs (if (null? args) (quote ()) (cdr args))) 264 (end (if (null? rs) (string-length s) (car rs)))) 265 (let loop ((i start)) 266 (if (>= i end) s 267 (begin (bytevector-u8-set! s i ch) (loop (+ i 1))))))) 268 269 (define (string->list s . args) 270 (let* ((start (if (null? args) 0 (car args))) 271 (rs (if (null? args) (quote ()) (cdr args))) 272 (end (if (null? rs) (string-length s) (car rs)))) 273 (let loop ((i (- end 1)) (acc (quote ()))) 274 (if (< i start) acc 275 (loop (- i 1) (cons (bytevector-u8-ref s i) acc)))))) 276 277 (define (list->string cs) (apply string cs)) 278 279 (define (%string-cmp a b) 280 (let ((alen (string-length a)) 281 (blen (string-length b))) 282 (let loop ((i 0)) 283 (cond ((and (= i alen) (= i blen)) 0) 284 ((= i alen) -1) 285 ((= i blen) 1) 286 (else 287 (let ((d (- (bytevector-u8-ref a i) (bytevector-u8-ref b i)))) 288 (if (zero? d) (loop (+ i 1)) d))))))) 289 290 (define (%string-ci-cmp a b) 291 (let ((alen (string-length a)) 292 (blen (string-length b))) 293 (let loop ((i 0)) 294 (cond ((and (= i alen) (= i blen)) 0) 295 ((= i alen) -1) 296 ((= i blen) 1) 297 (else 298 (let ((d (- (char-foldcase (bytevector-u8-ref a i)) 299 (char-foldcase (bytevector-u8-ref b i))))) 300 (if (zero? d) (loop (+ i 1)) d))))))) 301 302 (define (%chain-cmp cmp rel a b rest) 303 (if (rel (cmp a b) 0) 304 (if (null? rest) #t (%chain-cmp cmp rel b (car rest) (cdr rest))) 305 #f)) 306 307 (define (string=? a b . rest) (%chain-cmp %string-cmp = a b rest)) 308 (define (string<? a b . rest) (%chain-cmp %string-cmp < a b rest)) 309 (define (string>? a b . rest) (%chain-cmp %string-cmp > a b rest)) 310 (define (string<=? a b . rest) (%chain-cmp %string-cmp <= a b rest)) 311 (define (string>=? a b . rest) (%chain-cmp %string-cmp >= a b rest)) 312 313 (define (string-ci=? a b . rest) (%chain-cmp %string-ci-cmp = a b rest)) 314 (define (string-ci<? a b . rest) (%chain-cmp %string-ci-cmp < a b rest)) 315 (define (string-ci>? a b . rest) (%chain-cmp %string-ci-cmp > a b rest)) 316 (define (string-ci<=? a b . rest) (%chain-cmp %string-ci-cmp <= a b rest)) 317 (define (string-ci>=? a b . rest) (%chain-cmp %string-ci-cmp >= a b rest)) 318 319 (define (string-upcase s) 320 (let* ((n (string-length s)) 321 (out (make-bytevector (+ n 1) 0))) 322 (let loop ((i 0)) 323 (if (= i n) out 324 (begin 325 (bytevector-u8-set! out i (char-upcase (bytevector-u8-ref s i))) 326 (loop (+ i 1))))))) 327 328 (define (string-downcase s) 329 (let* ((n (string-length s)) 330 (out (make-bytevector (+ n 1) 0))) 331 (let loop ((i 0)) 332 (if (= i n) out 333 (begin 334 (bytevector-u8-set! out i (char-downcase (bytevector-u8-ref s i))) 335 (loop (+ i 1))))))) 336 337 (define string-foldcase string-downcase) 338 339 (define (string-map f s) 340 (let* ((n (string-length s)) 341 (out (make-bytevector (+ n 1) 0))) 342 (let loop ((i 0)) 343 (if (= i n) out 344 (begin 345 (bytevector-u8-set! out i (f (bytevector-u8-ref s i))) 346 (loop (+ i 1))))))) 347 348 (define (string-for-each f s) 349 (let ((n (string-length s))) 350 (let loop ((i 0)) 351 (if (= i n) (quote ()) 352 (begin (f (bytevector-u8-ref s i)) (loop (+ i 1))))))) 353 354 ;; --- R7RS bytevector constructor ----------------------------------- 355 (define (bytevector . bytes) 356 (let* ((n (length bytes)) 357 (bv (make-bytevector n 0))) 358 (let loop ((xs bytes) (i 0)) 359 (if (null? xs) bv 360 (begin 361 (bytevector-u8-set! bv i (car xs)) 362 (loop (cdr xs) (+ i 1))))))) 363 364 ;; --- Generic deep-copy --------------------------------------------- 365 ;; Structural clone of pair / bytevector / record graphs in the 366 ;; currently-selected heap. Preserves eq? identity across shared 367 ;; substructure and tolerates cycles via an eager stand-in registered 368 ;; before recursion. 369 ;; 370 ;; The ctx is a one-cell box around an (orig . copy) alist; lookups 371 ;; key off pointer identity (assq) so two structurally-equal but 372 ;; physically-distinct objects are treated separately. Cells leak into 373 ;; whichever heap is current when ctx is created — typically main 374 ;; during cc.scm's parse-decl-or-fn promotion. 375 ;; 376 ;; Strict positive-list dispatch: pair / bytevector / record. Anything 377 ;; else that masquerades as heap-allocated (closures, prims, MV-packs) 378 ;; surfaces as an error rather than silently dangling. 379 (define (make-deep-copy-context) (cons '() #f)) 380 381 (define (%dcc-lookup ctx obj) 382 (let ((p (assq obj (car ctx)))) 383 (if p (cdr p) #f))) 384 385 (define (%dcc-register! ctx obj copy) 386 (set-car! ctx (cons (cons obj copy) (car ctx))) 387 copy) 388 389 (define (deep-copy ctx obj) 390 (cond 391 ((symbol? obj) obj) 392 ((heap-in-current? obj) obj) 393 ((pair? obj) 394 (let ((c (%dcc-lookup ctx obj))) 395 (cond 396 (c c) 397 (else 398 (let ((p (cons #f #f))) 399 (%dcc-register! ctx obj p) 400 (set-car! p (deep-copy ctx (car obj))) 401 (set-cdr! p (deep-copy ctx (cdr obj))) 402 p))))) 403 ((bytevector? obj) 404 (let ((c (%dcc-lookup ctx obj))) 405 (cond 406 (c c) 407 (else 408 (%dcc-register! ctx obj 409 (bytevector-copy obj 0 (bytevector-length obj))))))) 410 ((record? obj) 411 (let ((c (%dcc-lookup ctx obj))) 412 (cond 413 (c c) 414 (else 415 (let* ((td (record-td obj)) 416 (n (td-nfields td)) 417 (s (make-record/td td))) 418 (%dcc-register! ctx obj s) 419 (let fill ((i 0)) 420 (cond ((= i n) s) 421 (else 422 (record-set! s i (deep-copy ctx (record-ref obj i))) 423 (fill (+ i 1)))))))))) 424 ((procedure? obj) 425 (error "deep-copy: cannot copy procedure" obj)) 426 (else obj))) 427 428 ;; --- Heap arena wrappers ------------------------------------------- 429 ;; Two-pattern API on top of the raw heap-mark / heap-rewind! / scratch 430 ;; primitives. Most callers should reach for these instead of driving 431 ;; the primitives directly. See tests/scheme1/093-heap-mark-rewind.scm 432 ;; and tests/scheme1/115-two-heap.scm for the underlying contract. 433 434 ;; Pattern 1 — mark/rewind. Run thunk inside a heap-mark/rewind arena 435 ;; on the current heap. All heap allocations performed by thunk are 436 ;; reclaimed on return; thunk's return value MUST be either an immediate 437 ;; (fixnum, boolean, symbol, '()) or a cell allocated by the caller 438 ;; *before* call-with-heap-rewind ran. The classic A→B→C shape pre- 439 ;; allocates an `out` cell, calls this with a thunk that mutates `out`, 440 ;; and returns `out` to its own caller. 441 (define (call-with-heap-rewind thunk) 442 (let ((mark (heap-mark))) 443 (let ((r (thunk))) 444 (heap-rewind! mark) 445 r))) 446 447 ;; Pattern 2a — scratch + deep-copy of a single root. Run thunk with 448 ;; the scratch heap selected, switch back to main, deep-copy thunk's 449 ;; result into main, reset scratch, return the main-heap copy. Use for 450 ;; the common case of "build a graph in scratch, hand the caller a 451 ;; main-heap clone, reclaim scratch". 452 (define (call-with-scratch-deep-copy thunk) 453 (use-scratch-heap!) 454 (let ((s (thunk))) 455 (use-main-heap!) 456 (let ((m (deep-copy (make-deep-copy-context) s))) 457 (reset-scratch-heap!) 458 m))) 459 460 ;; Pattern 2b — scratch + multi-root promote. Lower-level cycle: select 461 ;; scratch, run (in-scratch), select main, run (promote), reset scratch. 462 ;; The (promote) thunk is responsible for deep-copying every survivor 463 ;; root from scratch into main (typically across several caller-owned 464 ;; slots, sharing a single deep-copy context). Returns unspec; survivors 465 ;; must reach the caller via slots that promote rewrites in place. 466 (define (call-with-scratch-cycle in-scratch promote) 467 (use-scratch-heap!) 468 (in-scratch) 469 (use-main-heap!) 470 (promote) 471 (reset-scratch-heap!)) 472 473 ;; --- Vector <-> list -- need make-vector / vector-ref / vector-set! / 474 ;; vector-length, none of which are yet primitives. ------------------ 475 ; (define (vector->list-helper v i acc) 476 ; (if (< i 0) 477 ; acc 478 ; (vector->list-helper v (- i 1) (cons (vector-ref v i) acc)))) 479 ; 480 ; (define (vector->list v) 481 ; (vector->list-helper v (- (vector-length v) 1) (quote ()))) 482 ; 483 ; (define (list->vector-helper v xs i) 484 ; (if (null? xs) 485 ; v 486 ; (begin 487 ; (vector-set! v i (car xs)) 488 ; (list->vector-helper v (cdr xs) (+ i 1))))) 489 ; 490 ; (define (list->vector xs) 491 ; (list->vector-helper (make-vector (length xs) 0) xs 0)) 492 493 ;; --- shell.scm port: process-management wrappers built on top of the 494 ;; syscall primitives. sys-wait is a Scheme adapter over sys-waitid 495 ;; that returns a wait4-style raw wstatus so decode-wait-status can 496 ;; stay unchanged. -------------------------------------------------- 497 (define (sys-wait pid) 498 (let ((info (make-bytevector 128 0))) 499 (let ((r (sys-waitid 1 pid info 4))) 500 (if (car r) 501 (let ((code (bytevector-u8-ref info 8)) 502 (status (bytevector-u8-ref info 24))) 503 (if (= code 1) 504 (cons #t (arithmetic-shift status 8)) 505 (cons #t (bit-and status #x7f)))) 506 r)))) 507 508 (define (decode-wait-status s) 509 (let ((termsig (bit-and s #x7f))) 510 (if (zero? termsig) 511 (bit-and (arithmetic-shift s -8) #xff) 512 (+ 128 termsig)))) 513 514 (define (wait pid) 515 (let ((r (sys-wait pid))) 516 (if (car r) 517 (cons #t (decode-wait-status (cdr r))) 518 r))) 519 520 (define (exit . rest) 521 (sys-exit (if (null? rest) 0 (car rest)))) 522 523 (define (argv) (sys-argv)) 524 (define (command-line) (sys-argv)) 525 526 (define (spawn prog . args) 527 (let ((r (sys-clone))) 528 (cond 529 ((not (car r)) r) 530 ((zero? (cdr r)) 531 (sys-execve prog (cons prog args)) 532 (sys-exit 127)) 533 (else r)))) 534 535 (define (run prog . args) 536 (let ((r (apply spawn prog args))) 537 (if (car r) (wait (cdr r)) r))) 538 539 ;; --- shell.scm file-I/O constants ---------------------------------- 540 (define BUFSIZE 4096) 541 (define AT_FDCWD -100) 542 (define O_RDONLY 0) 543 (define O_WRONLY 1) 544 (define O_CREAT #x40) ; 0o100 545 (define O_TRUNC #x200) ; 0o1000 546 (define O_APPEND #x400) ; 0o2000 547 (define MODE_644 #x1a4) ; 0o644 548 (define NL-BYTE 10) 549 (define NL-BV (make-bytevector 1 10)) 550 551 (define (file-exists? path) 552 (let ((r (sys-openat AT_FDCWD path O_RDONLY 0))) 553 (cond ((car r) (sys-close (cdr r)) #t) 554 (else #f)))) 555 556 ;; --- shell.scm port record + handles ------------------------------- 557 (define-record-type port 558 (%port fd buf pos end) 559 port? 560 (fd port-fd) 561 (buf port-buf) 562 (pos port-pos port-pos-set!) 563 (end port-end port-end-set!)) 564 565 (define stdin (%port 0 (make-bytevector BUFSIZE) 0 0)) 566 (define stdout (%port 1 #f 0 0)) 567 (define stderr (%port 2 #f 0 0)) 568 569 ;; --- shell.scm port open/close ------------------------------------- 570 (define (open-input path) 571 (let ((r (sys-openat AT_FDCWD path O_RDONLY 0))) 572 (if (car r) 573 (cons #t (%port (cdr r) (make-bytevector BUFSIZE) 0 0)) 574 r))) 575 576 (define (open-output path) 577 (let ((r (sys-openat AT_FDCWD path 578 (bit-or O_WRONLY O_CREAT O_TRUNC) MODE_644))) 579 (if (car r) (cons #t (%port (cdr r) #f 0 0)) r))) 580 581 (define (open-append path) 582 (let ((r (sys-openat AT_FDCWD path 583 (bit-or O_WRONLY O_CREAT O_APPEND) MODE_644))) 584 (if (car r) (cons #t (%port (cdr r) #f 0 0)) r))) 585 586 (define (close p) (sys-close (port-fd p))) 587 588 ;; --- shell.scm reads ----------------------------------------------- 589 (define (refill! p) 590 (let ((r (sys-read (port-fd p) (port-buf p) 0 BUFSIZE))) 591 (cond 592 ((not (car r)) r) 593 (else (port-pos-set! p 0) 594 (port-end-set! p (cdr r)) 595 r)))) 596 597 (define (read-bytes p n) 598 (let ((out (make-bytevector n))) 599 (let loop ((i 0)) 600 (cond 601 ((= i n) (cons #t out)) 602 ((< (port-pos p) (port-end p)) 603 (let* ((avail (- (port-end p) (port-pos p))) 604 (take (if (< avail (- n i)) avail (- n i)))) 605 (bytevector-copy! out i (port-buf p) (port-pos p) take) 606 (port-pos-set! p (+ (port-pos p) take)) 607 (loop (+ i take)))) 608 (else 609 (let ((r (refill! p))) 610 (cond 611 ((not (car r)) r) 612 ((zero? (cdr r)) 613 (cons #t (if (zero? i) eof (bytevector-copy out 0 i)))) 614 (else (loop i))))))))) 615 616 (define (read-line p) 617 (let loop ((acc (quote ()))) 618 (cond 619 ((< (port-pos p) (port-end p)) 620 (let* ((buf (port-buf p)) 621 (start (port-pos p)) 622 (end (port-end p))) 623 (let scan ((i start)) 624 (cond 625 ((= i end) 626 (port-pos-set! p i) 627 (loop (cons (bytevector-copy buf start i) acc))) 628 ((= (bytevector-u8-ref buf i) NL-BYTE) 629 (port-pos-set! p (+ i 1)) 630 (cons #t (bv-concat-reverse 631 (cons (bytevector-copy buf start i) acc)))) 632 (else (scan (+ i 1))))))) 633 (else 634 (let ((r (refill! p))) 635 (cond 636 ((not (car r)) r) 637 ((zero? (cdr r)) 638 (cons #t (if (null? acc) eof (bv-concat-reverse acc)))) 639 (else (loop acc)))))))) 640 641 (define (read-all p) 642 (let loop ((acc (quote ()))) 643 (cond 644 ((< (port-pos p) (port-end p)) 645 (let ((chunk (bytevector-copy (port-buf p) 646 (port-pos p) (port-end p)))) 647 (port-pos-set! p (port-end p)) 648 (loop (cons chunk acc)))) 649 (else 650 (let ((r (refill! p))) 651 (cond 652 ((not (car r)) r) 653 ((zero? (cdr r)) (cons #t (bv-concat-reverse acc))) 654 (else (loop acc)))))))) 655 656 (define (bv-concat-reverse chunks) 657 (let* ((xs (reverse chunks)) 658 (total (let sum ((ys xs) (n 0)) 659 (if (null? ys) n 660 (sum (cdr ys) (+ n (bytevector-length (car ys))))))) 661 (out (make-bytevector total))) 662 (let loop ((ys xs) (i 0)) 663 (if (null? ys) 664 out 665 (let ((len (bytevector-length (car ys)))) 666 (bytevector-copy! out i (car ys) 0 len) 667 (loop (cdr ys) (+ i len))))))) 668 669 ;; --- shell.scm writes (unbuffered; handle partial writes) ---------- 670 ;; sys-write takes an offset, so the partial-write fallback advances 671 ;; the offset into the same bv instead of copying a tail. 672 (define (write-bytes p bv) 673 (let ((len (bytevector-length bv))) 674 (let loop ((off 0)) 675 (if (= off len) 676 (cons #t len) 677 (let ((r (sys-write (port-fd p) bv off (- len off)))) 678 (cond 679 ((not (car r)) r) 680 (else (loop (+ off (cdr r)))))))))) 681 682 ;; write-string assumes its input is a NUL-terminated bv (a "string") 683 ;; and uses string-length, not bytevector-length, to bound the write. 684 (define (write-string p s) 685 (let ((len (string-length s))) 686 (let loop ((off 0)) 687 (if (= off len) 688 (cons #t len) 689 (let ((r (sys-write (port-fd p) s off (- len off)))) 690 (cond 691 ((not (car r)) r) 692 (else (loop (+ off (cdr r)))))))))) 693 694 (define (write-line p s) 695 (let ((r (write-string p s))) 696 (if (car r) (write-bytes p NL-BV) r)))