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