commit efbfccaedff611ddde6f3d4c6d3cf2f68e9f09b6
parent efa02b4ed5866ee6796438feed0f562d465281de
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Sat, 25 Apr 2026 13:24:08 -0700
scheme1: lift prelude to scheme1/prelude.scm, catm at run time
scheme1/prelude.scm now holds the list helpers and the full shell.scm
port (process management + buffered file I/O). scripts/boot-run-scheme1.sh
runs in the container, catm's prelude.scm in front of the user .scm,
and execs the scheme1 binary on the combined file. run-tests.sh's
scheme1 suite invokes the helper instead of the binary directly. Items
that need primitives scheme1 doesn't have yet (>, vector-*, string-*)
stay as commented placeholders.
Diffstat:
3 files changed, 375 insertions(+), 4 deletions(-)
diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm
@@ -0,0 +1,343 @@
+; scheme1 prelude. catm'd in front of the user .scm before invoking the
+; scheme1 binary (see scripts/boot-run-scheme1.sh). Defines list helpers,
+; the shell.scm process-management wrappers, and the shell.scm file-I/O
+; layer (port record + buffered reads/writes).
+;
+; Items that depend on primitives scheme1 doesn't yet have (>, the
+; vector-* family, the string-* family) stay here as commented
+; placeholders for re-enabling once those primitives land.
+
+;; --- Boolean / logical ----------------------------------------------
+; not is a primitive (prim_not_entry); redefining would shadow it.
+; (define (not x) (if x #f #t))
+
+;; --- Arithmetic helpers (derivable from <, =, -) --------------------
+(define (<= x y) (if (< y x) #f #t))
+(define (>= x y) (if (< x y) #f #t))
+
+; zero? is a primitive (prim_zeroq_entry).
+; (define (zero? x) (= x 0))
+
+(define (negative? x) (< x 0))
+
+; positive? needs `>`, which is not yet a primitive.
+; (define (positive? x) (> x 0))
+
+(define (abs x) (if (< x 0) (- 0 x) x))
+
+;; --- Common c*r compositions ---------------------------------------
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caddr x) (car (cdr (cdr x))))
+
+;; --- List helpers (derivable from cons/car/cdr/null?/pair?/eq?) -----
+(define (list . xs) xs)
+
+(define (list? x)
+ (if (null? x)
+ #t
+ (if (pair? x) (list? (cdr x)) #f)))
+
+(define (length xs)
+ (let loop ((xs xs) (n 0))
+ (if (null? xs) n (loop (cdr xs) (+ n 1)))))
+
+(define (reverse xs)
+ (let loop ((xs xs) (acc (quote ())))
+ (if (null? xs) acc (loop (cdr xs) (cons (car xs) acc)))))
+
+(define (append-pair a b)
+ (if (null? a) b (cons (car a) (append-pair (cdr a) b))))
+
+(define (append . lists)
+ (cond ((null? lists) (quote ()))
+ ((null? (cdr lists)) (car lists))
+ (else (append-pair (car lists) (apply append (cdr lists))))))
+
+(define (list-ref xs n)
+ (if (= n 0) (car xs) (list-ref (cdr xs) (- n 1))))
+
+(define (assoc key alist)
+ (if (null? alist)
+ #f
+ (if (eq? (car (car alist)) key)
+ (car alist)
+ (assoc key (cdr alist)))))
+
+(define (member x xs)
+ (if (null? xs)
+ #f
+ (if (eq? (car xs) x)
+ xs
+ (member x (cdr xs)))))
+
+;; --- map / filter / fold / for-each ---------------------------------
+(define (map f xs)
+ (if (null? xs) (quote ()) (cons (f (car xs)) (map f (cdr xs)))))
+
+(define (filter p xs)
+ (if (null? xs)
+ (quote ())
+ (if (p (car xs))
+ (cons (car xs) (filter p (cdr xs)))
+ (filter p (cdr xs)))))
+
+(define (fold f acc xs)
+ (if (null? xs)
+ acc
+ (fold f (f acc (car xs)) (cdr xs))))
+
+(define (for-each f xs)
+ (if (null? xs) (quote ()) (begin (f (car xs)) (for-each f (cdr xs)))))
+
+;; --- Vector <-> list -- need make-vector / vector-ref / vector-set! /
+;; vector-length, none of which are yet primitives. ------------------
+; (define (vector->list-helper v i acc)
+; (if (< i 0)
+; acc
+; (vector->list-helper v (- i 1) (cons (vector-ref v i) acc))))
+;
+; (define (vector->list v)
+; (vector->list-helper v (- (vector-length v) 1) (quote ())))
+;
+; (define (list->vector-helper v xs i)
+; (if (null? xs)
+; v
+; (begin
+; (vector-set! v i (car xs))
+; (list->vector-helper v (cdr xs) (+ i 1)))))
+;
+; (define (list->vector xs)
+; (list->vector-helper (make-vector (length xs) 0) xs 0))
+
+;; --- Structural equality -- needs string?/vector? plus their ref /
+;; length, none of which are yet primitives. ------------------------
+; (define (equal?-string a b i n)
+; (if (= i n)
+; #t
+; (if (= (string-ref a i) (string-ref b i))
+; (equal?-string a b (+ i 1) n)
+; #f)))
+;
+; (define (equal?-vector a b i n)
+; (if (= i n)
+; #t
+; (if (equal? (vector-ref a i) (vector-ref b i))
+; (equal?-vector a b (+ i 1) n)
+; #f)))
+;
+; (define (equal? a b)
+; (if (eq? a b)
+; #t
+; (if (pair? a)
+; (if (pair? b)
+; (if (equal? (car a) (car b))
+; (equal? (cdr a) (cdr b))
+; #f)
+; #f)
+; (if (string? a)
+; (if (string? b)
+; (if (= (string-length a) (string-length b))
+; (equal?-string a b 0 (string-length a))
+; #f)
+; #f)
+; (if (vector? a)
+; (if (vector? b)
+; (if (= (vector-length a) (vector-length b))
+; (equal?-vector a b 0 (vector-length a))
+; #f)
+; #f)
+; #f)))))
+
+;; --- shell.scm port: process-management wrappers built on top of the
+;; syscall primitives. sys-wait is a Scheme adapter over sys-waitid
+;; that returns a wait4-style raw wstatus so decode-wait-status can
+;; stay unchanged. --------------------------------------------------
+(define (sys-wait pid)
+ (let ((info (make-bytevector 128 0)))
+ (let ((r (sys-waitid 1 pid info 4)))
+ (if (car r)
+ (let ((code (bytevector-u8-ref info 8))
+ (status (bytevector-u8-ref info 24)))
+ (if (= code 1)
+ (cons #t (arithmetic-shift status 8))
+ (cons #t (bit-and status #x7f))))
+ r))))
+
+(define (decode-wait-status s)
+ (let ((termsig (bit-and s #x7f)))
+ (if (zero? termsig)
+ (bit-and (arithmetic-shift s -8) #xff)
+ (+ 128 termsig))))
+
+(define (wait pid)
+ (let ((r (sys-wait pid)))
+ (if (car r)
+ (cons #t (decode-wait-status (cdr r)))
+ r)))
+
+(define (exit . rest)
+ (sys-exit (if (null? rest) 0 (car rest))))
+
+(define (argv) (sys-argv))
+
+(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 (run prog . args)
+ (let ((r (apply spawn prog args)))
+ (if (car r) (wait (cdr r)) r)))
+
+;; --- shell.scm file-I/O constants ----------------------------------
+(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))
+
+;; --- shell.scm port record + handles -------------------------------
+(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))
+
+;; --- shell.scm port open/close -------------------------------------
+(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)))
+
+;; bit-or is 2-arg only in scheme1 today, so the 3-flag combinations
+;; are written as nested 2-arg calls.
+(define (open-output path)
+ (let ((r (sys-openat AT_FDCWD path
+ (bit-or O_WRONLY (bit-or 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 (bit-or 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)))
+
+;; --- shell.scm 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 (quote ())))
+ (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 (quote ())))
+ (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)))))))
+
+;; --- shell.scm 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)))
diff --git a/scripts/boot-run-scheme1.sh b/scripts/boot-run-scheme1.sh
@@ -0,0 +1,26 @@
+#!/bin/sh
+## boot-run-scheme1.sh — in-container wrapper that runs the scheme1
+## binary on USER_SRC with scheme1/prelude.scm catm'd in front. Caller
+## (Make / the test runner) ensures build/$ARCH/{scheme1,tools/catm}
+## and scheme1/prelude.scm exist before invoking.
+##
+## Pipeline:
+## catm /tmp/combined.scm scheme1/prelude.scm <user_src>
+## build/$ARCH/scheme1 /tmp/combined.scm
+##
+## Env: ARCH=aarch64|amd64|riscv64
+## Usage: boot-run-scheme1.sh <user_src>
+
+set -eu
+
+: "${ARCH:?ARCH must be set}"
+[ "$#" -eq 1 ] || { echo "usage: ARCH=<arch> $0 <user_src>" >&2; exit 2; }
+
+USER_SRC=$1
+TOOLS=build/$ARCH/tools
+SCHEME1=build/$ARCH/scheme1
+PRELUDE=scheme1/prelude.scm
+COMBINED=/tmp/scheme1-combined.scm
+
+"$TOOLS/catm" "$COMBINED" "$PRELUDE" "$USER_SRC"
+exec "$SCHEME1" "$COMBINED"
diff --git a/scripts/run-tests.sh b/scripts/run-tests.sh
@@ -211,9 +211,10 @@ run_p1_suite() {
## --- scheme1 suite ------------------------------------------------------
##
## Caller (Make) ensures build/<arch>/scheme1 already exists. The runner
-## just invokes that binary against each .scm fixture, capturing stdout
-## and the exit status. stdout is diffed against <name>.expected (defaults
-## to empty if absent); the exit status is diffed against
+## invokes scripts/boot-run-scheme1.sh inside the container, which catm's
+## scheme1/prelude.scm in front of the .scm fixture before handing the
+## combined file to the binary. stdout is diffed against <name>.expected
+## (defaults to empty if absent); the exit status is diffed against
## <name>.expected-exit (defaults to 0 if absent).
run_scheme1_suite() {
@@ -254,7 +255,8 @@ run_scheme1_suite() {
fi
tmp_stdout=$(mktemp)
- if run_in_container "$arch" "./$bin" "$fixture" >"$tmp_stdout" 2>&1; then
+ if run_in_container "$arch" sh scripts/boot-run-scheme1.sh "$fixture" \
+ >"$tmp_stdout" 2>&1; then
actual_exit=0
else
actual_exit=$?
