commit e73c0249193a5103c80ad7ad6db49e52a87b6acc parent da780a8705037ecf57363fb1147d7432e258bfc7 Author: Ryan Sepassi <rsepassi@gmail.com> Date: Sun, 19 Jul 2026 14:26:22 -0700 scheme1: implement R7RS-micro profile Separate characters, strings, and bytevectors; enforce checked exact integers and the specified reader, binding, record, and output behavior. Migrate the prelude, compiler, bootstrap drivers, documentation, and conformance fixtures to the micro+boot2 boundary. Diffstat:
235 files changed, 2313 insertions(+), 965 deletions(-)
diff --git a/bootprep/assets/boot3-run.scm b/bootprep/assets/boot3-run.scm @@ -6,33 +6,33 @@ (if (and (car r) (= 0 (cdr r))) r (begin - (write-string stderr "boot3: step failed: ") - (write-string stderr tag) - (write-string stderr "\n") - (exit 1)))) + (fd-write-string/result stderr "boot3: step failed: ") + (fd-write-string/result stderr tag) + (fd-write-string/result stderr "\n") + (sys-exit 1)))) -(write-string stdout "boot3: catm cc-bundle\n") +(fd-write-string/result stdout "boot3: catm cc-bundle\n") (must (run "in/catm" "out/cc-bundled.scm" "in/prelude.scm" "in/cc.scm" "in/main.scm") "catm cc-bundle") -(write-string stdout "boot3: scheme1 libc\n") +(fd-write-string/result stdout "boot3: scheme1 libc\n") (must (run "in/scheme1" "out/cc-bundled.scm" "--lib=libc__" "in/libc.flat.c" "out/libc.P1pp") "scheme1 libc") -(write-string stdout "boot3: scheme1 tcc\n") +(fd-write-string/result stdout "boot3: scheme1 tcc\n") (must (run "in/scheme1" "out/cc-bundled.scm" "--lib=tcc__" "in/tcc.flat.c" "out/tcc.flat.P1pp") "scheme1 tcc") -(write-string stdout "boot3: catm combined.M1pp\n") +(fd-write-string/result stdout "boot3: catm combined.M1pp\n") (must (run "in/catm" "out/combined.M1pp" "in/backend.M1pp" "in/frontend.M1pp" "in/libp1pp.P1pp" "in/entry-libc.P1pp" "out/libc.P1pp" "out/tcc.flat.P1pp" "in/elf-end.P1pp") "catm combined.M1pp") -(write-string stdout "boot3: M1pp\n") +(fd-write-string/result stdout "boot3: M1pp\n") (must (run "in/M1pp" "out/combined.M1pp" "out/expanded.hex2pp") "M1pp") -(write-string stdout "boot3: catm linked.hex2pp\n") +(fd-write-string/result stdout "boot3: catm linked.hex2pp\n") (must (run "in/catm" "out/linked.hex2pp" "in/ELF.hex2" "out/expanded.hex2pp") "catm linked.hex2pp") -(write-string stdout "boot3: hex2pp\n") +(fd-write-string/result stdout "boot3: hex2pp\n") (must (run "in/hex2pp" "-B" "0x600000" "out/linked.hex2pp" "out/tcc0") "hex2pp") -(exit 0) +(sys-exit 0) diff --git a/bootprep/boot4-gen-runscm.sh b/bootprep/boot4-gen-runscm.sh @@ -105,12 +105,12 @@ cat <<'PROLOGUE' (if (and (car r) (= 0 (cdr r))) r (begin - (write-string stderr "boot4: step failed: ") - (write-string stderr tag) - (write-string stderr "\n") - (exit 1)))) + (fd-write-string/result stderr "boot4: step failed: ") + (fd-write-string/result stderr tag) + (fd-write-string/result stderr "\n") + (sys-exit 1)))) -(write-string stdout "boot4: stage C (tcc0 -> tcc1)\n") +(fd-write-string/result stdout "boot4: stage C (tcc0 -> tcc1)\n") PROLOGUE # Stage C: tcc0 builds helpers + archive, links tcc1 — same link line as @@ -121,7 +121,7 @@ emit_link_tcc in/tcc0 tcc0 "s1-" tcc1 cat <<EOF -(write-string stdout "boot4: stage D (tcc1 -> tcc2)\n") +(fd-write-string/result stdout "boot4: stage D (tcc1 -> tcc2)\n") EOF # Stage D: tcc1 rebuilds helpers + archive, links tcc2. tcc1 == tcc2 is @@ -133,9 +133,9 @@ emit_link_tcc out/tcc1 tcc1 "s2-" tcc2 cat <<EOF -(write-string stdout "boot4: linking hello\n") +(fd-write-string/result stdout "boot4: linking hello\n") (must (run "out/tcc1" "-nostdlib" $LINK_TTEXT "out/s2-crt1.o" "in/hello.c" "out/s2-libc.a" "out/s2-libtcc1.a" "out/s2-libc.a" "-o" "out/hello") "tcc1 -> hello") -(write-string stdout "boot4: ALL-OK\n") -(exit 0) +(fd-write-string/result stdout "boot4: ALL-OK\n") +(sys-exit 0) EOF } > "$OUT" diff --git a/bootprep/boot5-gen-runscm.sh b/bootprep/boot5-gen-runscm.sh @@ -78,12 +78,12 @@ cat <<'PROLOGUE' (if (and (car r) (= 0 (cdr r))) r (begin - (write-string stderr "boot5: step failed: ") - (write-string stderr tag) - (write-string stderr "\n") - (exit 1)))) + (fd-write-string/result stderr "boot5: step failed: ") + (fd-write-string/result stderr tag) + (fd-write-string/result stderr "\n") + (sys-exit 1)))) -(write-string stdout "boot5: stage A (compile sources)\n") +(fd-write-string/result stdout "boot5: stage A (compile sources)\n") PROLOGUE # Stage A: per-source compile. Each line of build-srcs.txt is a path @@ -102,7 +102,7 @@ awk -v CFLAGS_C="$CFLAGS_C_QUOTED" -v CFLAGS_ASM="$CFLAGS_ASM_QUOTED" -v CIN="$C cat <<EOF -(write-string stdout "boot5: stage B (CRT)\n") +(fd-write-string/result stdout "boot5: stage B (CRT)\n") ;; Position-independent + non-PIC CRT helpers. -fPIC objects are needed ;; for shared-binding tools, even though our hello is fully static. (must (run "in/tcc" $CRTFLAGS_C_QUOTED "-fPIC" "-c" "$CIN/crt/Scrt1.c" "-o" "$COUT/crt/Scrt1.o") "Scrt1.o") @@ -126,7 +126,7 @@ fi # full list inline. The list is enormous (~1500 paths × ~40 chars = # ~60 KB on a single line) but the prelude reader handles it fine. { - printf '\n(write-string stdout "boot5: stage C (libc.a)\\n")\n' + printf '\n(fd-write-string/result stdout "boot5: stage C (libc.a)\\n")\n' printf '(must (run "in/tcc" "-ar" "rcs" "out/libc.a"' awk -v COUT="$COUT" '{ obj = $0 @@ -143,13 +143,13 @@ cat <<EOF (must (run "in/catm" "out/crti.o" "$COUT/crt/crti.o") "crti.o publish") (must (run "in/catm" "out/crtn.o" "$COUT/crt/crtn.o") "crtn.o publish") -(write-string stdout "boot5: stage D (link hello)\n") +(fd-write-string/result stdout "boot5: stage D (link hello)\n") ;; -Lout pulls libc.a (just built); -Lin pulls libtcc1.a (input). (must (run "in/tcc" "-static" "-nostdinc" "-nostdlib" "-Iin/tcc-include" $LINK_TTEXT "-I$CIN/include" "-I$CIN/arch/$MUSL_ARCH" "-I$CIN/arch/generic" "-I$CIN/obj/include" "out/crt1.o" "in/hello.c" "-Lout" "-lc" "-Lin" "-ltcc1" "-Lout" "-lc" "-o" "out/hello") "link hello") -(write-string stdout "boot5: ALL-OK\n") -(exit 0) +(fd-write-string/result stdout "boot5: ALL-OK\n") +(sys-exit 0) EOF } > "$OUT" diff --git a/bootprep/boot6-gen-runscm.sh b/bootprep/boot6-gen-runscm.sh @@ -69,28 +69,28 @@ cat > "$OUT" <<EOF (if (and (car r) (= 0 (cdr r))) r (begin - (write-string stderr "boot6: step failed: ") - (write-string stderr tag) - (write-string stderr "\n") - (exit 1)))) + (fd-write-string/result stderr "boot6: step failed: ") + (fd-write-string/result stderr tag) + (fd-write-string/result stderr "\n") + (sys-exit 1)))) -(write-string stdout "boot6: tcc2 -c kernel.S\n") +(fd-write-string/result stdout "boot6: tcc2 -c kernel.S\n") (must (run "in/tcc" $KCFLAGS "-c" "-o" "out/kernel-asm.o" "in/kernel.S") "kernel.S -> kernel-asm.o") -(write-string stdout "boot6: tcc2 -c kernel.c\n") +(fd-write-string/result stdout "boot6: tcc2 -c kernel.c\n") (must (run "in/tcc" $KCFLAGS "-Iin" "-c" "-o" "out/kernel.o" "in/kernel.c") "kernel.c -> kernel.o") -(write-string stdout "boot6: tcc2 -c mmu.c\n") +(fd-write-string/result stdout "boot6: tcc2 -c mmu.c\n") (must (run "in/tcc" $KCFLAGS "-Iin" "-c" "-o" "out/mmu.o" "in/mmu.c") "mmu.c -> mmu.o") -(write-string stdout "boot6: tcc2 -c mem.c\n") +(fd-write-string/result stdout "boot6: tcc2 -c mem.c\n") (must (run "in/tcc" $KCFLAGS "-c" "-o" "out/mem.o" "in/mem.c") "mem.c -> mem.o") -(write-string stdout "boot6: tcc2 link $OUT_FILE\n") +(fd-write-string/result stdout "boot6: tcc2 link $OUT_FILE\n") (must (run "in/tcc" "-nostdlib" "-static" "-Wl,-Ttext=$TTEXT" $LINK_OFORMAT @@ -98,6 +98,6 @@ cat > "$OUT" <<EOF "out/kernel-asm.o" "out/kernel.o" "out/mmu.o" "out/mem.o") "link $OUT_FILE") -(write-string stdout "boot6: ALL-OK\n") -(exit 0) +(fd-write-string/result stdout "boot6: ALL-OK\n") +(sys-exit 0) EOF diff --git a/cc/cc.scm b/cc/cc.scm @@ -1,9 +1,11 @@ ;; cc/util.scm — leaf helpers. Depends only on the scheme1 prelude. ;; -------------------------------------------------------------------- -;; bytevector helpers (scheme1 strings ARE bytevectors) +;; byte-oriented helpers. R7RS strings and bytevectors are disjoint; +;; micro+boot2's bytes? / bytes=? and bytevector operations provide the +;; explicit bridge used by this byte-oriented compiler. ;; -------------------------------------------------------------------- -(define (bv= a b) (bytevector=? a b)) +(define (bv= a b) (bytes=? a b)) (define (bv-prefix? p s) ;; Is s a bv that starts with the bytes of p? @@ -44,24 +46,33 @@ (let ((n (string->number bv radix))) (if n (values #t n) (values #f #f)))) -(define (fixnum->bv n radix) (number->string n radix)) +(define (fixnum->bv n radix) + (bytevector-append (number->string n radix))) ;; -------------------------------------------------------------------- ;; lists / alists ;; -------------------------------------------------------------------- -(define (alist-ref key al) (let ((p (assoc key al))) (and p (cdr p)))) +(define (key=? a b) + (if (and (bytes? a) (bytes? b)) (bytes=? a b) (equal? a b))) + +(define (assoc/key key al) + (cond ((null? al) #f) + ((key=? key (car (car al))) (car al)) + (else (assoc/key key (cdr al))))) + +(define (alist-ref key al) (let ((p (assoc/key key al))) (and p (cdr p)))) (define (alist-ref/eq key al) (let ((p (assq key al))) (and p (cdr p)))) (define (alist-set key val al) (cons (cons key val) al)) (define (alist-update key f al) - ;; Functional update by equal? key. If found, replace its value with + ;; Functional update by byte-aware key equality. If found, replace its value with ;; (f old-val). If not found, prepend (cons key (f #f)) so callers ;; can use this as upsert-with-default. (let loop ((xs al) (acc '())) (cond ((null? xs) (cons (cons key (f #f)) (reverse acc))) - ((equal? (car (car xs)) key) + ((key=? (car (car xs)) key) (append (reverse acc) (cons (cons key (f (cdr (car xs)))) (cdr xs)))) @@ -877,26 +888,50 @@ ((if (< b 97) #f (if (< 102 b) #f #t)) (+ (- b 97) 10)) (else 0))) +;; C integer tokens may contain a full 64-bit bit pattern, wider than +;; boot2's signed 61-bit Scheme exact-integer range. Accumulate through two +;; u32 limbs so the Scheme arithmetic itself remains representable, then +;; pack the low 61 bits into the historical signed carrier used by cc.scm. +;; This keeps fixed-width C literal handling separate from Scheme's checked +;; exact arithmetic instead of depending on host/tag wraparound. +(define %c-int-limb-base 4294967296) + +(define (%c-int-pack hi lo) + (let ((h (bit-and hi #x1fffffff))) + (if (= 0 (bit-and h #x10000000)) + (+ (* h %c-int-limb-base) lo) + (+ (* (- h #x20000000) %c-int-limb-base) lo)))) + (define (%accum-int-while pred src pos line col base) (let ((n (bytevector-length src))) - (let loop ((pos pos) (line line) (col col) (val 0) (cnt 0)) + (let loop ((pos pos) (line line) (col col) (hi 0) (lo 0) (cnt 0)) (cond - ((>= pos n) (list val cnt pos line col)) + ((>= pos n) (list (%c-int-pack hi lo) cnt pos line col)) (else (let ((b (bytevector-u8-ref src pos))) (cond ((%fast-byte? b) (if (pred b) - (loop (+ pos 1) line (+ col 1) - (+ (* val base) (%digit-val-byte b)) (+ cnt 1)) - (list val cnt pos line col))) + (let* ((wide-lo (+ (* lo base) (%digit-val-byte b))) + (next-lo (bit-and wide-lo #xffffffff)) + (carry (arithmetic-shift wide-lo -32)) + (wide-hi (+ (* hi base) carry)) + (next-hi (bit-and wide-hi #xffffffff))) + (loop (+ pos 1) line (+ col 1) + next-hi next-lo (+ cnt 1))) + (list (%c-int-pack hi lo) cnt pos line col))) (else (let* ((p (%lex-peek src pos line col)) (b2 (%pk-byte p))) (if (and b2 (pred b2)) - (loop (%pk-pos p) (%pk-line p) (%pk-col p) - (+ (* val base) (%digit-val-byte b2)) (+ cnt 1)) - (list val cnt pos line col))))))))))) + (let* ((wide-lo (+ (* lo base) (%digit-val-byte b2))) + (next-lo (bit-and wide-lo #xffffffff)) + (carry (arithmetic-shift wide-lo -32)) + (wide-hi (+ (* hi base) carry)) + (next-hi (bit-and wide-hi #xffffffff))) + (loop (%pk-pos p) (%pk-line p) (%pk-col p) + next-hi next-lo (+ cnt 1))) + (list (%c-int-pack hi lo) cnt pos line col))))))))))) (define (%accum-octal-bounded src pos line col k) ;; Up to k octal digits. Returns (val count npos nline ncol). @@ -1889,7 +1924,8 @@ (iter->list (make-pp-iter (make-list-iter toks) initial-defines))) ;; --- directive dispatch --- -;; pmatch-based on the directive name bv. bv literals match by equal?. +;; pmatch-based on the directive name bytes. Byte literals use the explicit +;; mixed string/bytevector rule from micro+boot2. ;; Directive name can arrive as IDENT (most cases) or KW (`if` and `else` ;; are C keywords promoted by lex; their KW symbol values map back to bv ;; via symbol->string). @@ -2539,7 +2575,7 @@ (define (%cg-emit-many cg bvs) (for-each (lambda (b) (%cg-emit cg b)) bvs)) -(define (%n n) (number->string n 10)) +(define (%n n) (fixnum->bv n 10)) ;; Per-fn metadata (name, ret-slot, ret-type, switch-case lists, ...) ;; lives on cg-fn-meta, reset at every cg-fn-begin/v. @@ -2595,7 +2631,7 @@ ((eq? (sym-storage sm) 'static) (%cg-mangle-global (sym-name sm))) (else (sym-name sm)))) -(define (%cg-reg->bv r) (symbol->string r)) +(define (%cg-reg->bv r) (bytevector-append (symbol->string r))) (define (%cg-emit-li cg reg n) (%cg-emit-many cg (list "%li(" (%cg-reg->bv reg) ", " (%n n) ")\n"))) @@ -4126,7 +4162,7 @@ ;; 4B zero pad). (define (%cg-init-piece->bv piece) (cond - ((bytevector? piece) + ((bytes? piece) (bv-cat (%cg-bv->hex-lines piece #f))) ((and (pair? piece) (eq? (car piece) 'label-ref)) (bv-cat (list "&" (cdr piece) " %(0)\n"))) @@ -4676,7 +4712,7 @@ ((or (eq? k 'i64) (eq? k 'u64)) (cond ((eq? k 'u64) ;; Mask to 64 bits without losing sign on negative values. - (bit-and value #xffffffffffffffff)) + value) (else value))) ((%ctype-unsigned? ct) (bit-and value mask)) (else @@ -5669,7 +5705,7 @@ ;; should already have validated the field exists). (define (%init-drop-thru-field fields fname) (cond ((null? fields) '()) - ((equal? (car (car fields)) fname) (cdr fields)) + ((bytes=? (car (car fields)) fname) (cdr fields)) (else (%init-drop-thru-field (cdr fields) fname)))) ;; #t when TY is an array of i8/u8 — a char[] a string literal may @@ -5913,7 +5949,7 @@ ;; Output width of one piece (cf. %cg-init-piece->bv): a bv emits ;; one byte per element; a (label-ref . _) emits an 8-byte slot. (cond - ((bytevector? p) (bytevector-length p)) + ((bytes? p) (bytevector-length p)) ((and (pair? p) (eq? (car p) 'label-ref)) 8) (else (die #f "init: unknown piece" p)))) @@ -6159,7 +6195,7 @@ (define (%bv-in-list? bv xs) (cond ((null? xs) #f) - ((equal? bv (car xs)) #t) + ((bytes=? bv (car xs)) #t) (else (%bv-in-list? bv (cdr xs))))) ;; Does any leaf-name of `f` (a struct/union field tuple, possibly with @@ -6182,9 +6218,8 @@ (else #f))))))) (define (%emit-zero-field ps base-off f) - ;; Note: scheme1's `+` is binary-only — `(+ a b c)` returns (+ a b) - ;; and silently drops the rest. Compute absolute byte offsets via - ;; nested binary +. + ;; Keep the absolute byte-offset expression explicit: base + field offset, + ;; then add the byte index used by the zero-fill loop. (let* ((fty (car (cdr f))) (foff (car (cddr f))) (fsize (ctype-size fty)) diff --git a/docs/R7RS-micro.md b/docs/R7RS-micro.md @@ -168,8 +168,9 @@ Micro recognizes: Binary, octal, explicit decimal, exactness, inexactness, rational, decimal point, exponent, and complex-number syntax are outside the profile. -The supported exact-integer range is implementation-defined. Boot2 uses one -tagged machine word and therefore has a target-dependent fixed range. +The supported exact-integer range is implementation-defined. On every boot2 +target it is `-2^60` through `2^60-1`, inclusive, using one tagged 64-bit +machine word. ### Characters @@ -932,5 +933,8 @@ target requires these changes, in order: 8. Split or clearly label the portable micro prelude and boot2 extension prelude. -Until those changes land, this document describes the intended profile rather -than asserting that the current interpreter implements it completely. +The repository's `scheme1` interpreter, prelude, compiler, bootstrap drivers, +and conformance fixtures implement this migration. Future changes should keep +the micro and boot2 layers visibly separated and preserve the negative tests +for rejected syntax, call shapes, radices, constructor forms, and exact-range +overflow. diff --git a/docs/SCHEME1.md b/docs/SCHEME1.md @@ -1,15 +1,15 @@ # scheme1 -Minimal Scheme subset implemented by `scheme1/scheme1.P1pp`. A loose -subset of R7RS-small. The interpreter reads s-expressions from +Minimal Scheme subset implemented by `scheme1/scheme1.P1pp`. It implements +the micro+boot2 profile defined in [R7RS-micro.md](R7RS-micro.md). The +interpreter reads s-expressions from `argv[1]`, evaluates them top-to-bottom in a single global env, and exits. `tests/boot-run-scheme1.sh` invokes `scheme1` with `prelude.scm` catted in front of the user file. The prelude (`scheme1/prelude.scm`) -defines the R7RS surface that is expressible over the runtime -primitives — equivalence aliases, list/char/string helpers, and the -`shell.scm` process / file-I/O layer. +defines the portable micro helpers first, followed by a visibly labelled +boot2 compiler/process/file-I/O layer. ## Lexical syntax @@ -19,19 +19,20 @@ primitives — equivalence aliases, list/char/string helpers, and the bare `+` or `-` is a symbol. A lone `.` between list elements is the dotted-pair separator, not a symbol. - **Booleans**: `#t`, `#f`. -- **Integers**: decimal (`42`, `-7`, `+3`) and hex (`#xff`, `#x-1a`). - Word-size — 32-bit on 32-bit targets, 64-bit on 64-bit targets. - No `#o`, no `#b`, no floats / rationals / bignums. +- **Integers**: decimal (`42`, `-7`, `+3`) and lowercase-prefix hex + (`#xff`, `#x-1a`). Values range from `-2^60` through `2^60-1` on the + boot2 targets. Out-of-range literals and results fail explicitly. No + `#X`, `#o`, `#b`, floats, rationals, or bignums. - **Strings**: `"…"`. Escapes: `\n \t \r \\ \"` and inline-hex `\xNN;` - (1+ hex digits, value 0..255, terminated by `;`). A string is a - bytevector; indexing is by u8. + (1+ hex digits, value 0..255, terminated by `;`). Strings have an + explicit logical length, admit embedded nulls, and are disjoint from + bytevectors. - **Characters**: `#\a` through `#\~` for printable ASCII, plus `#\space` (32), `#\newline` (10), `#\tab` (9), `#\return` (13), - `#\null` (0), and `#\xNN` for any byte. A character literal *is* a - fixnum byte — there is no distinct character type. `(= #\a 97)` is - `#t`. + `#\null` (0), and `#\xNN` for any byte. Characters are disjoint from + exact integers; use `char->integer` and `integer->char` to convert. - **Bytevector literal**: `#u8(b1 b2 ...)`. Each element must be a - fixnum 0..255 (range unchecked). + exact integer in 0..255 (range checked). - **Symbols**: bare. Globally interned — two symbols that print the same are `eq?`. - **Pairs / lists**: `(a b c)`, `(a . b)`, `'()` for the empty list. @@ -48,9 +49,11 @@ The runtime knows exactly: | Type | Notes | |----------------|--------------------------------------------------------------| | boolean | `#t`, `#f` | -| integer | word-size; 32- or 64-bit per target | +| integer | tagged exact integer in `[-2^60, 2^60-1]` | +| character | byte-repertoire character; disjoint from integer | | symbol | globally interned; `eq?`-comparable | -| string / bv | same type (`HDR.BV`); contiguous u8 buffer | +| string | mutable, explicit-length character sequence (`HDR.STRING`) | +| bytevector | mutable u8 sequence (`HDR.BV`), disjoint from string | | pair | cons cell | | empty list | `'()`, disjoint from pair | | procedure | closure or primitive | @@ -81,8 +84,8 @@ Procedures and binding: - `(let-values (((formals init) ...) body ...)`, `(let*-values …)`. `formals` is bound via the same matching as `lambda` parameters: list, dotted-tail, or bare symbol. -- `(set! name value)`. Walks the lexical env; on miss, rebinds the - global slot. +- `(set! name value)`. Walks the lexical env and then existing global + bindings. Assignment to an unbound name is an error. Conditionals and sequencing: @@ -90,7 +93,8 @@ Conditionals and sequencing: `(if test then)` returns the unspecified value when `test` is `#f`. - `(cond (test body ...) ... (else body ...))`. A clause may also be `(test => proc-expr)` — when truthy, calls `proc-expr` on the test - value. + value. A successful `(test)` clause returns the test value, and `else` + must be final. - `(when test body ...)` — body runs when test is truthy, else unspecified. - `(case key (datum-list body ...) ... (else body ...))` — datums @@ -106,8 +110,10 @@ Quote, records, matching: - `(quote datum)` / `'datum`. - `(define-record-type name (ctor f1 ...) pred (field accessor [mutator]) ...)` Creates a disjoint type. Binds `ctor`, `pred`, and each `accessor` / - optional `mutator` at top level. Records are `equal?` iff TDs are - `eq?` and all fields are `equal?`. + optional `mutator` at top level. The constructor list must contain every + field exactly once in declaration order, and constructor calls require + exactly that many arguments. Records are `equal?` iff TDs are `eq?` and + all fields are `equal?`. - `(pmatch expr clause ...)` — pattern matcher. Clause forms: ``` @@ -121,7 +127,7 @@ Quote, records, matching: | Pattern | Matches | |----------------------|--------------------------------------------------| | `()` | the empty list | - | `<literal>` | fixnum / bv / immediate by `equal?` | + | `<literal>` | ordinary literal by `equal?`; bytes by `bytes=?` | | `<symbol>` | that exact symbol (*not* a binder) | | `,<ident>` | anything; binds to `<ident>` | | `,_` | anything; no binding (wildcard) | @@ -140,7 +146,8 @@ these. **Equality / predicates** `eq?`, `equal?`, `not`, `null?`, `pair?`, `boolean?`, `integer?`, -`symbol?`, `string?` (≡ `bytevector?`), `procedure?`, `zero?`, `eof?`. +`char?`, `symbol?`, `string?`, `bytevector?`, `bytes?`, `procedure?`, +`zero?`, `eof?`. `bytes?` is the explicit boot2 string/bytevector bridge. **Pairs** `cons`, `car`, `cdr`, `set-car!`, `set-cdr!`, `length`, `list-ref`, @@ -148,7 +155,7 @@ these. `assoc` compares keys by `equal?`; both return the matching alist pair or `#f`. `reverse` returns a fresh reversed list. -**Integers** (word-size; overflow / divide-by-zero are UB) +**Integers** (tagged exact range; overflow and divide-by-zero fail explicitly) `+ - *`, `quotient`, `remainder`, `=`, `<`, `>`, `bit-and`, `bit-or`, `bit-xor`, `bit-not`, `arithmetic-shift`. Arities: `+ * bit-and bit-or bit-xor` accept 0+ args (identities `0 1 -1 0 0`); `-` accepts @@ -161,19 +168,24 @@ of the dividend. `make-bytevector`, `bytevector-length`, `bytevector-u8-ref`, `bytevector-u8-set!`, `bytevector-copy` (3-arg `src start end` → fresh bv), `bytevector-copy!` (`dst dst-start src src-start -src-end`), `bytevector-append` (variadic), `bytevector=?`, -`string-length` (strlen of the data buffer up to the first NUL). +src-end`), `bytevector-append` (variadic), `bytevector=?`, `bytes=?`, +`make-string`, `string-length`, `string-ref`, `string-set!`. +The bytevector operations named by R7RS-micro's boot2 bridge accept strings +as byte sources/destinations but still produce bytevectors where applicable. +Copies have memmove semantics for overlapping ranges. **Symbols / numbers as text** `string->symbol`, `symbol->string`, `number->string` (decimal by default; lowercase hex when the optional radix arg is `16`, with a -leading `-` for negatives; any other radix value falls back to -decimal), `string->number` (decimal by default; hex when radix is +leading `-` for negatives; other radices are rejected), `string->number` +(decimal by default; hex when radix is `16`, accepting upper- or lowercase digits and an optional leading `+`/`-`; returns `#f` on parse failure). **I/O and error** -`display`, `write`, `format`, `error`. `format` understands `~a` +`display`, `write`, `format`, `error`. `write` emits reader-compatible +characters, strings, and bytevectors; string escaping preserves embedded +nulls. `format` understands `~a` (display), `~s` (write), `~d` (decimal fixnum), `~x` (lowercase hex fixnum, signed: leading `-` for negatives), `~%` (newline), `~~` (literal tilde); unknown directives pass through verbatim. `error` @@ -215,10 +227,9 @@ an allocation cannot be satisfied without reclaiming garbage. See `error` is the only structured error path. Everything else — `(car '())`, out-of-range `bytevector-u8-ref`, `(quotient 1 0)`, -mutating immutable state, integer overflow, unknown-form `pmatch` -fallthrough — is **primitive failure**: the runtime aborts with a -short message on stderr. Callers should not rely on any particular -outcome. +mutating immutable state, integer overflow, or unknown-form `pmatch` +fallthrough — is **primitive failure**: the runtime aborts with a short +message on stderr. It never silently wraps an exact Scheme result. There is no `raise` / `guard` / handlers, no `call/cc`, no exceptions. Wrap-and-return through `(ok . val)` pairs (the syscall @@ -229,8 +240,7 @@ convention) when failure needs to be observable. `scheme1/prelude.scm` is bundled in front of every user program by `tests/boot-run-scheme1.sh`. It adds: -- **R7RS aliases**: `eqv?` ≡ `eq?`, `number?` ≡ `integer?`, - `bytevector?` ≡ `string?`. +- **R7RS aliases**: `eqv?` ≡ `eq?`, `number?` ≡ `integer?`. - **Arithmetic**: `<=`, `>=`, `negative?`, `positive?`, `abs`, `min`, `max`, `modulo`. - **Equivalence chains**: `boolean=?`, `symbol=?`. @@ -239,12 +249,12 @@ convention) when failure needs to be observable. of primitive `assq`), `map`, `for-each`, `filter`, `fold`, plus the full `c[ad]+r` family up to four levels. Primitive list helpers available before the prelude are listed above. -- **Characters as fixnums**: `char?`, `char->integer`, - `integer->char` (identity), `char-upper-case?`, `char-lower-case?`, +- **Characters**: primitive `char?`, `char->integer`, and `integer->char`, + plus `char-upper-case?`, `char-lower-case?`, `char-alphabetic?`, `char-numeric?`, `char-whitespace?`, `digit-value`, `char-upcase`, `char-downcase`, `char-foldcase`, `char=?`, `char<?`, `char>?`, `char<=?`, `char>=?`. -- **Strings as NUL-terminated bytevectors**: `make-string`, `string`, +- **Explicit-length strings**: `make-string`, `string`, `string-ref`, `string-set!`, `substring`, `string-append`, `string-copy`, `string-copy!`, `string-fill!`, `string->list`, `list->string`, `string-upcase`, `string-downcase`, @@ -252,17 +262,17 @@ convention) when failure needs to be observable. `string=?` / `string<?` / `string>?` / `string<=?` / `string>=?` (and `-ci` variants). - **Bytevectors**: `bytevector` constructor. -- **`shell.scm`** — process and file I/O layer: - - `argv`, `command-line`, `exit`, `spawn`, `run`, `wait`, +- **Boot2 process and file I/O layer**: + - `argv`, `sys-exit`, `spawn`, `run`, `wait`, `decode-wait-status`. - - `port` record (via `define-record-type`) with a 4 KiB read buffer. - `stdin` / `stdout` / `stderr` are pre-built ports on fds 0 / 1 / 2. + - `fd-port` record with a 4 KiB read buffer and predicate `fd-port?`. + `stdin` / `stdout` / `stderr` are pre-built fd handles. - `open-input`, `open-output`, `open-append`, `close`, `file-exists?`. - - Buffered reads: `read-bytes`, `read-line`, `read-all`. Each + - Buffered reads: `read-bytes`, `fd-read-line/result`, `read-all`. Each returns either `(#t . value)` (where `value` may be `eof`) or `(#f . errno)` from the underlying syscall. - - Unbuffered writes: `write-bytes`, `write-string`, `write-line`. + - Unbuffered writes: `write-bytes`, `fd-write-string/result`, `write-line`. Writes loop until the requested length is delivered or a syscall error surfaces. - **Constants**: `BUFSIZE`, `AT_FDCWD`, `O_RDONLY`, `O_WRONLY`, diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm @@ -1,13 +1,16 @@ ; scheme1 prelude. catm'd in front of the user .scm before invoking the -; scheme1 binary (see tests/boot-run-scheme1.sh). Defines the R7RS -; surface that's expressible over scheme1's existing primitives -- -; equivalence aliases, list helpers, characters as fixnum bytes, -; strings as NUL-terminated bytevectors -- plus the shell.scm process- -; management and file-I/O layer (port record + buffered reads/writes). +; scheme1 binary (see tests/boot-run-scheme1.sh). ; -; Items that depend on primitives scheme1 doesn't yet have (the -; vector-* family) stay here as commented placeholders for re-enabling -; once those primitives land. See docs/SCHEME1-R7RS-TODO.md. +; The file is deliberately divided into two visibly labelled layers: +; MICRO / R7RS-COMPATIBLE -- portable procedures derived from primitives. +; BOOT2 EXTENSIONS -- byte bridges, compiler helpers, syscalls, +; fd handles, process helpers, and introspection. +; A micro program uses only the first layer and the core runtime bindings +; specified by docs/R7RS-micro.md. + +;; ==================================================================== +;; MICRO / R7RS-COMPATIBLE PRELUDE +;; ==================================================================== ;; --- Arithmetic helpers (derivable from <, =, -) -------------------- (define (<= x y) (if (< y x) #f #t)) @@ -16,10 +19,8 @@ (define (negative? x) (< x 0)) (define (positive? x) (> x 0)) -;; scheme1 has only one numeric and one byte-string repr today, so these -;; predicates are exact aliases. They exist so callers can spell intent. +;; Micro has one numeric category, so number? and integer? coincide. (define number? integer?) -(define bytevector? string?) (define (abs x) (if (< x 0) (- 0 x) x)) @@ -148,18 +149,6 @@ (cons (apply f (%list-cars xss)) (m (%list-cdrs xss))))))) -(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 . rest) (if (null? rest) (let m ((xs xs)) @@ -170,28 +159,29 @@ (begin (apply f (%list-cars xss)) (m (%list-cdrs xss))))))) -;; --- R7RS character procedures (ASCII over fixnum bytes) ----------- -;; Chars are plain fixnums; char? is a 0..255 range check rather than -;; a disjoint type. char->integer / integer->char are the identity. -(define (char? x) - (if (integer? x) - (if (< x 0) #f (< x 256)) - #f)) - -(define (char->integer c) c) -(define (integer->char n) n) +;; --- R7RS character procedures (ASCII-compatible byte repertoire) -- +;; char?, char->integer, and integer->char are runtime primitives because +;; characters have a representation disjoint from exact integers. +(define (%char-between? c lo hi) + (let ((n (char->integer c))) (and (>= n lo) (<= n hi)))) -(define (char-upper-case? c) (and (>= c 65) (<= c 90))) -(define (char-lower-case? c) (and (>= c 97) (<= c 122))) +(define (char-upper-case? c) (%char-between? c 65 90)) +(define (char-lower-case? c) (%char-between? c 97 122)) (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) -(define (char-numeric? c) (and (>= c 48) (<= c 57))) +(define (char-numeric? c) (%char-between? c 48 57)) (define (char-whitespace? c) - (or (= c 32) (= c 9) (= c 10) (= c 11) (= c 12) (= c 13))) - -(define (digit-value c) (if (char-numeric? c) (- c 48) #f)) - -(define (char-upcase c) (if (char-lower-case? c) (- c 32) c)) -(define (char-downcase c) (if (char-upper-case? c) (+ c 32) c)) + (let ((n (char->integer c))) + (or (= n 32) (= n 9) (= n 10) (= n 11) (= n 12) (= n 13)))) + +(define (digit-value c) + (if (char-numeric? c) (- (char->integer c) 48) #f)) + +(define (char-upcase c) + (if (char-lower-case? c) + (integer->char (- (char->integer c) 32)) c)) +(define (char-downcase c) + (if (char-upper-case? c) + (integer->char (+ (char->integer c) 32)) c)) (define char-foldcase char-downcase) (define (%chain-rel rel a b rest) @@ -199,39 +189,30 @@ (if (null? rest) #t (%chain-rel rel b (car rest) (cdr rest))) #f)) -(define (char=? a b . rest) (%chain-rel = a b rest)) -(define (char<? a b . rest) (%chain-rel < a b rest)) -(define (char>? a b . rest) (%chain-rel > a b rest)) -(define (char<=? a b . rest) (%chain-rel <= a b rest)) -(define (char>=? a b . rest) (%chain-rel >= a b rest)) - -;; --- R7RS string procedures (over NUL-terminated bytevectors) ------ -;; A scheme1 "string" is a bytevector whose first NUL byte marks the -;; logical end. Constructors allocate (n+1) bytes and store 0 at index -;; n. string-ref / string-set! are thin aliases over the bytevector -;; primitives; bounds against string-length aren't enforced (the user -;; can clobber the NUL terminator). -(define (make-string n . fill) - (let ((c (if (null? fill) 32 (car fill)))) - (let ((bv (make-bytevector (+ n 1) c))) - (bytevector-u8-set! bv n 0) - bv))) - +(define (%char-rel rel a b) + (rel (char->integer a) (char->integer b))) +(define (char=? a b . rest) (%chain-rel (lambda (x y) (%char-rel = x y)) a b rest)) +(define (char<? a b . rest) (%chain-rel (lambda (x y) (%char-rel < x y)) a b rest)) +(define (char>? a b . rest) (%chain-rel (lambda (x y) (%char-rel > x y)) a b rest)) +(define (char<=? a b . rest) (%chain-rel (lambda (x y) (%char-rel <= x y)) a b rest)) +(define (char>=? a b . rest) (%chain-rel (lambda (x y) (%char-rel >= x y)) a b rest)) + +;; --- R7RS string procedures ---------------------------------------- +;; make-string, string-length, string-ref, and string-set! are primitives. +;; Strings have explicit logical lengths, are mutable, and are disjoint from +;; bytevectors; embedded #\null characters do not truncate them. (define (string . cs) (let* ((n (length cs)) - (bv (make-bytevector (+ n 1) 0))) + (s (make-string n #\null))) (let loop ((xs cs) (i 0)) - (if (null? xs) bv + (if (null? xs) s (begin - (bytevector-u8-set! bv i (car xs)) + (string-set! s i (car xs)) (loop (cdr xs) (+ i 1))))))) -(define string-ref bytevector-u8-ref) -(define string-set! bytevector-u8-set!) - (define (substring s start end) (let* ((n (- end start)) - (out (make-bytevector (+ n 1) 0))) + (out (make-string n #\null))) (bytevector-copy! out 0 s start end) out)) @@ -239,7 +220,7 @@ (let ((total (let sum ((xs ss) (n 0)) (if (null? xs) n (sum (cdr xs) (+ n (string-length (car xs)))))))) - (let ((out (make-bytevector (+ total 1) 0))) + (let ((out (make-string total #\null))) (let loop ((xs ss) (off 0)) (if (null? xs) out (let ((len (string-length (car xs)))) @@ -264,7 +245,7 @@ (end (if (null? rs) (string-length s) (car rs)))) (let loop ((i start)) (if (>= i end) s - (begin (bytevector-u8-set! s i ch) (loop (+ i 1))))))) + (begin (string-set! s i ch) (loop (+ i 1))))))) (define (string->list s . args) (let* ((start (if (null? args) 0 (car args))) @@ -272,7 +253,7 @@ (end (if (null? rs) (string-length s) (car rs)))) (let loop ((i (- end 1)) (acc (quote ()))) (if (< i start) acc - (loop (- i 1) (cons (bytevector-u8-ref s i) acc)))))) + (loop (- i 1) (cons (string-ref s i) acc)))))) (define (list->string cs) (apply string cs)) @@ -284,7 +265,8 @@ ((= i alen) -1) ((= i blen) 1) (else - (let ((d (- (bytevector-u8-ref a i) (bytevector-u8-ref b i)))) + (let ((d (- (char->integer (string-ref a i)) + (char->integer (string-ref b i))))) (if (zero? d) (loop (+ i 1)) d))))))) (define (%string-ci-cmp a b) @@ -295,8 +277,8 @@ ((= i alen) -1) ((= i blen) 1) (else - (let ((d (- (char-foldcase (bytevector-u8-ref a i)) - (char-foldcase (bytevector-u8-ref b i))))) + (let ((d (- (char->integer (char-foldcase (string-ref a i))) + (char->integer (char-foldcase (string-ref b i)))))) (if (zero? d) (loop (+ i 1)) d))))))) (define (%chain-cmp cmp rel a b rest) @@ -318,38 +300,38 @@ (define (string-upcase s) (let* ((n (string-length s)) - (out (make-bytevector (+ n 1) 0))) + (out (make-string n #\null))) (let loop ((i 0)) (if (= i n) out (begin - (bytevector-u8-set! out i (char-upcase (bytevector-u8-ref s i))) + (string-set! out i (char-upcase (string-ref s i))) (loop (+ i 1))))))) (define (string-downcase s) (let* ((n (string-length s)) - (out (make-bytevector (+ n 1) 0))) + (out (make-string n #\null))) (let loop ((i 0)) (if (= i n) out (begin - (bytevector-u8-set! out i (char-downcase (bytevector-u8-ref s i))) + (string-set! out i (char-downcase (string-ref s i))) (loop (+ i 1))))))) (define string-foldcase string-downcase) (define (string-map f s) (let* ((n (string-length s)) - (out (make-bytevector (+ n 1) 0))) + (out (make-string n #\null))) (let loop ((i 0)) (if (= i n) out (begin - (bytevector-u8-set! out i (f (bytevector-u8-ref s i))) + (string-set! out i (f (string-ref s i))) (loop (+ i 1))))))) (define (string-for-each f s) (let ((n (string-length s))) (let loop ((i 0)) (if (= i n) (quote ()) - (begin (f (bytevector-u8-ref s i)) (loop (+ i 1))))))) + (begin (f (string-ref s i)) (loop (+ i 1))))))) ;; --- R7RS bytevector constructor ----------------------------------- (define (bytevector . bytes) @@ -361,8 +343,26 @@ (bytevector-u8-set! bv i (car xs)) (loop (cdr xs) (+ i 1))))))) +;; ==================================================================== +;; BOOT2 EXTENSION PRELUDE +;; ==================================================================== + +;; --- Compiler utility procedures ----------------------------------- +(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)))) + ;; --- Generic deep-copy --------------------------------------------- -;; Structural clone of pair / bytevector / record graphs. Preserves eq? +;; Structural clone of pair / string / bytevector / record graphs. +;; Preserves eq? ;; identity across shared substructure and tolerates cycles via an eager ;; stand-in registered before recursion. ;; @@ -370,7 +370,7 @@ ;; key off pointer identity (assq) so two structurally-equal but ;; physically-distinct objects are treated separately. ;; -;; Strict positive-list dispatch: pair / bytevector / record. Anything +;; Strict positive-list dispatch: pair / string / bytevector / record. Anything ;; else that masquerades as heap-allocated (closures, prims, MV-packs) ;; surfaces as an error rather than silently dangling. (define (make-deep-copy-context) (cons '() #f)) @@ -396,6 +396,12 @@ (set-car! p (deep-copy ctx (car obj))) (set-cdr! p (deep-copy ctx (cdr obj))) p))))) + ((string? obj) + (let ((c (%dcc-lookup ctx obj))) + (cond + (c c) + (else + (%dcc-register! ctx obj (string-copy obj)))))) ((bytevector? obj) (let ((c (%dcc-lookup ctx obj))) (cond @@ -468,11 +474,7 @@ (cons #t (decode-wait-status (cdr r))) r))) -(define (exit . rest) - (sys-exit (if (null? rest) 0 (car rest)))) - (define (argv) (sys-argv)) -(define (command-line) (sys-argv)) ;; scheme1 supports two process-creation paths: ;; - sys-spawn: one atomic syscall (no userspace gap between fork and @@ -525,45 +527,45 @@ (cond ((car r) (sys-close (cdr r)) #t) (else #f)))) -;; --- shell.scm port record + handles ------------------------------- -(define-record-type port - (%port fd buf pos end) - port? +;; --- fd-port record + handles -------------------------------------- +(define-record-type fd-port + (%fd-port fd buf pos end) + fd-port? (fd port-fd) - (buf port-buf) - (pos port-pos port-pos-set!) - (end port-end port-end-set!)) + (buf fd-port-buf) + (pos fd-port-pos fd-port-pos-set!) + (end fd-port-end fd-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 stdin (%fd-port 0 (make-bytevector BUFSIZE) 0 0)) +(define stdout (%fd-port 1 #f 0 0)) +(define stderr (%fd-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)) + (cons #t (%fd-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))) + (if (car r) (cons #t (%fd-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))) + (if (car r) (cons #t (%fd-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) 0 BUFSIZE))) + (let ((r (sys-read (port-fd p) (fd-port-buf p) 0 BUFSIZE))) (cond ((not (car r)) r) - (else (port-pos-set! p 0) - (port-end-set! p (cdr r)) + (else (fd-port-pos-set! p 0) + (fd-port-end-set! p (cdr r)) r)))) (define (read-bytes p n) @@ -571,11 +573,12 @@ (let loop ((i 0)) (cond ((= i n) (cons #t out)) - ((< (port-pos p) (port-end p)) - (let* ((avail (- (port-end p) (port-pos p))) + ((< (fd-port-pos p) (fd-port-end p)) + (let* ((avail (- (fd-port-end p) (fd-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)) + (bytevector-copy! out i (fd-port-buf p) (fd-port-pos p) + (+ (fd-port-pos p) take)) + (fd-port-pos-set! p (+ (fd-port-pos p) take)) (loop (+ i take)))) (else (let ((r (refill! p))) @@ -585,20 +588,20 @@ (cons #t (if (zero? i) eof (bytevector-copy out 0 i)))) (else (loop i))))))))) -(define (read-line p) +(define (fd-read-line/result 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))) + ((< (fd-port-pos p) (fd-port-end p)) + (let* ((buf (fd-port-buf p)) + (start (fd-port-pos p)) + (end (fd-port-end p))) (let scan ((i start)) (cond ((= i end) - (port-pos-set! p i) + (fd-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)) + (fd-port-pos-set! p (+ i 1)) (cons #t (bv-concat-reverse (cons (bytevector-copy buf start i) acc)))) (else (scan (+ i 1))))))) @@ -613,10 +616,10 @@ (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)) + ((< (fd-port-pos p) (fd-port-end p)) + (let ((chunk (bytevector-copy (fd-port-buf p) + (fd-port-pos p) (fd-port-end p)))) + (fd-port-pos-set! p (fd-port-end p)) (loop (cons chunk acc)))) (else (let ((r (refill! p))) @@ -651,10 +654,10 @@ ((not (car r)) r) (else (loop (+ off (cdr r)))))))))) -;; write-string assumes its input is a NUL-terminated bv (a "string") -;; and uses string-length, not bytevector-length, to bound the write. -(define (write-string p s) - (let ((len (string-length s))) +;; Byte-oriented fd writer: accepts a string or bytevector and uses its +;; explicit byte length, including embedded NUL bytes. +(define (fd-write-string/result p s) + (let ((len (bytevector-length s))) (let loop ((off 0)) (if (= off len) (cons #t len) @@ -664,5 +667,5 @@ (else (loop (+ off (cdr r)))))))))) (define (write-line p s) - (let ((r (write-string p s))) + (let ((r (fd-write-string/result p s))) (if (car r) (write-bytes p NL-BV) r))) diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp @@ -11,9 +11,9 @@ # Constants # ========================================================================= -%enum TAG { FIXNUM PAIR SYM HEAP IMM } +%enum TAG { FIXNUM PAIR SYM HEAP IMM CHAR } %enum IMM { FALSE TRUE NIL UNSPEC UNBOUND EOF } -%enum HDR { BV CLOSURE PRIM TD REC MV } +%enum HDR { BV STRING CLOSURE PRIM TD REC MV } %enum GCKIND { FREE PAIR HEAP RAW } # Each managed block begins with two machine words. The first word is @@ -56,6 +56,8 @@ %macro tagof(rd, rs) %andi(rd, rs, 7) %endm %macro mkfix(rd, rs) %shli(rd, rs, 3) %endm %macro untag_fix(rd, rs) %sari(rd, rs, 3) %endm +%macro mkchar(rd, rs) %shli(rd, rs, 3) %ori(rd, rd, %TAG.CHAR) %endm +%macro untag_char(rd, rs) %shri(rd, rs, 3) %endm %macro untag_sym(rd, rs) %sari(rd, rs, 3) %endm %macro car(rd, rs) %ld(rd, rs, -1) %endm %macro cdr(rd, rs) %ld(rd, rs, 7) %endm @@ -128,6 +130,21 @@ %bceq(ch_reg, -13, target, scratch) ; CR %endm +# Branch to `target` if `ch_reg` is an R7RS token delimiter. Some of the +# delimited constructs are deliberately unsupported by micro, but they still +# terminate an adjacent token so the reader rejects them at their own start. +%macro is_token_delimiter_branch(scratch, ch_reg, target) + %is_ws_branch(scratch, ch_reg, target) + %bceq(ch_reg, -40, target, scratch) ; '(' + %bceq(ch_reg, -41, target, scratch) ; ')' + %bceq(ch_reg, -59, target, scratch) ; ';' + %bceq(ch_reg, -34, target, scratch) ; '"' + %bceq(ch_reg, -124, target, scratch) ; '|' + %bceq(ch_reg, -39, target, scratch) ; '\'' + %bceq(ch_reg, -96, target, scratch) ; '`' + %bceq(ch_reg, -44, target, scratch) ; ',' +%endm + # Branch to `target` if lo_neg <= c < lo_neg+count (unsigned). Both # scratch and count_scratch are clobbered. %macro brange(c, lo_neg, count, scratch, count_scratch, target) @@ -424,8 +441,101 @@ %ret .endscope +# parse_exact_dec(buf=a0, len=a1) -> (raw value=a0, consumed=a1). +# Accepts an optional leading '-' (callers strip '+'). The accumulator is +# checked before every multiply/add, so even an arbitrarily long token cannot +# wrap the host word and re-enter the tagged exact-integer range. +%fn2(parse_exact_dec, {start cursor end digits accum negative quotient remainder}, { + %stl(a0, start) + %stl(a0, cursor) + %add(t0, a0, a1) + %stl(t0, end) + %li(t0, 0) + %stl(t0, accum) + %stl(t0, negative) + + # Optional minus sign. + %ldl(t0, cursor) + %ldl(t1, end) + %beq(t0, t1, &.after_sign) + %lb(t2, t0, 0) + %addi(t2, t2, -45) + %bnez(t2, &.after_sign) + %li(t2, 1) + %stl(t2, negative) + %addi(t0, t0, 1) + %stl(t0, cursor) + + :.after_sign + %ldl(t0, cursor) + %stl(t0, digits) + + # magnitude limit = 2^60-1, plus one for the negative endpoint. + %li(t0, -1) + %shri(t0, t0, 4) + %ldl(t1, negative) + %beqz(t1, &.have_limit) + %addi(t0, t0, 1) + :.have_limit + %li(t1, 10) + %div(t2, t0, t1) + %stl(t2, quotient) + %rem(t2, t0, t1) + %stl(t2, remainder) + + :.loop + %ldl(t0, cursor) + %ldl(t1, end) + %beq(t0, t1, &.done) + %lb(a0, t0, 0) + %addi(a0, a0, -48) + %bltz(a0, &.done) + %li(t2, 9) + %bltu(t2, a0, &.done) + + # accum * 10 + digit <= limit, checked without overflowing. + %ldl(t0, accum) + %ldl(t1, quotient) + %bltu(t1, t0, &.overflow) + %bne(t0, t1, &.accumulate) + %ldl(t2, remainder) + %bltu(t2, a0, &.overflow) + :.accumulate + %li(t1, 10) + %mul(t0, t0, t1) + %add(t0, t0, a0) + %stl(t0, accum) + %ldl(t0, cursor) + %addi(t0, t0, 1) + %stl(t0, cursor) + %b(&.loop) + + :.done + %ldl(t0, cursor) + %ldl(t1, digits) + %beq(t0, t1, &.no_digits) + %ldl(a0, accum) + %ldl(t1, negative) + %beqz(t1, &.return) + %li(t1, 0) + %sub(a0, t1, a0) + :.return + %ldl(a1, cursor) + %ldl(t0, start) + %sub(a1, a1, t0) + %eret + + :.no_digits + %li(a0, 0) + %li(a1, 0) + %eret + + :.overflow + %die(msg_integer_overflow) +}) + # parse_one() -> tagged value in a0 -%fn(parse_one, 0, { +%fn2(parse_one, {number_len number_neg}, { %call(&skip_ws) %bnez(a0, &.eof) @@ -438,6 +548,8 @@ %bceq(a0, -39, &.quote, a1) %bceq(a0, -44, &.comma, a1) %bceq(a0, -34, &.string, a1) + %bceq(a0, -96, &.unsupported, a1) ; backquote + %bceq(a0, -124, &.unsupported, a1) ; vertical-bar identifier %tail(&parse_atom) @@ -467,29 +579,38 @@ %bceq(a0, -116, &.true_lit, a1) ; 't' %bceq(a0, -102, &.false_lit, a1) ; 'f' %bceq(a0, -120, &.hex_lit, a1) ; 'x' - %bceq(a0, -88, &.hex_lit, a1) ; 'X' %bceq(a0, -92, &.char_lit, a1) ; '\\' %bceq(a0, -117, &.u8_lit, a1) ; 'u' %die(msg_bad_hash) :.true_lit - %li(a0, %imm_val(%IMM.TRUE)) - %eret + %li(a2, %imm_val(%IMM.TRUE)) + %b(&.boolean_lit) :.false_lit - %li(a0, %imm_val(%IMM.FALSE)) + %li(a2, %imm_val(%IMM.FALSE)) + + :.boolean_lit + # A boolean token ends after its one-letter spelling. Without this + # check `#true` would silently become two adjacent top-level datums. + %ld_global(t0, &readbuf_pos) + %ld_global(t1, &readbuf_len) + %beq(t0, t1, &.boolean_done) + %readbuf_byte(t2, t0) + %is_token_delimiter_branch(a3, t2, &.boolean_done) + %die(msg_bad_hash) + :.boolean_done + %mov(a0, a2) %eret :.hex_lit - # t0 sits at the first hex digit; t1 = readbuf_len. Scan to ws/paren/EOF, - # then parse_hex over the slice (with optional leading '-'). + # t0 sits at the first hex digit; t1 = readbuf_len. Scan to a token + # delimiter, then parse_hex over the slice with an optional sign. %mov(a3, t0) :.hex_scan %beq(t0, t1, &.hex_end) %readbuf_byte(a0, t0) - %is_ws_branch(a1, a0, &.hex_end) - %bceq(a0, -40, &.hex_end, a1) - %bceq(a0, -41, &.hex_end, a1) + %is_token_delimiter_branch(a1, a0, &.hex_end) %addi(t0, t0, 1) %b(&.hex_scan) :.hex_end @@ -498,19 +619,64 @@ %ld_global(a0, &readbuf_buf_ptr) %add(a0, a0, a3) %sub(a1, t0, a3) + %beqz(a1, &.number_bad) + %li(t0, 0) + %stl(t0, number_neg) %lb(t2, a0, 0) %addi(t2, t2, -45) ; '-' %beqz(t2, &.hex_neg) - %call(&parse_hex) - %mkfix(a0, a0) - %eret + %lb(t2, a0, 0) + %addi(t2, t2, -43) ; '+' + %beqz(t2, &.hex_pos_sign) + %b(&.hex_parse) :.hex_neg + %li(t0, 1) + %stl(t0, number_neg) + :.hex_pos_sign + %addi(a0, a0, 1) + %addi(a1, a1, -1) + %beqz(a1, &.number_bad) + :.hex_parse + # Strip redundant leading zeroes so a long but representable spelling + # is accepted without allowing parse_hex's machine-word accumulator to + # wrap. At most sixteen significant hexadecimal digits remain. + :.hex_trim_zero + %lb(t1, a0, 0) + %addi(t1, t1, -48) + %bnez(t1, &.hex_count_check) + %li(t0, 1) + %beq(a1, t0, &.hex_count_check) %addi(a0, a0, 1) %addi(a1, a1, -1) + %b(&.hex_trim_zero) + :.hex_count_check + %li(t0, 17) + %bltu(a1, t0, &.hex_parse_go) + %b(&.integer_overflow) + :.hex_parse_go + %stl(a1, number_len) %call(&parse_hex) + %ldl(t0, number_len) + %bne(a1, t0, &.number_bad) + # Compare the unsigned magnitude before applying the sign. Positive + # values allow 2^60-1; the one extra magnitude 2^60 is valid only for + # the negative endpoint. + %li(t0, -1) + %shri(t0, t0, 4) + %ldl(t1, number_neg) + %beqz(t1, &.hex_limit_ready) + %addi(t0, t0, 1) + :.hex_limit_ready + %bltu(t0, a0, &.integer_overflow) + %ldl(t0, number_neg) + %beqz(t0, &.hex_tag) %li(t0, 0) %sub(a0, t0, a0) - %mkfix(a0, a0) + :.hex_tag + %mov(t0, a0) + %mkfix(a0, t0) + %untag_fix(t1, a0) + %bne(t0, t1, &.integer_overflow) %eret :.quote @@ -544,7 +710,7 @@ :.char_lit # Cursor is already past '#\\'; parse_char scans the body and returns - # a tagged fixnum (the u8 char value). + # a disjoint tagged character. %tail(&parse_char) :.u8_lit @@ -564,6 +730,15 @@ :.u8_bad %die(msg_bad_hash) + :.number_bad + %die(msg_bad_number) + + :.integer_overflow + %die(msg_integer_overflow) + + :.unsupported + %die(msg_unsupported_syntax) + :.eof %die(msg_unexp_eof) }) @@ -647,9 +822,8 @@ }) # parse_u8_body() -> tagged HDR.BV in a0. Cursor sits past '#u8(' on -# entry. Reads elements via parse_list (each must be a fixnum byte 0..255; -# range is unchecked, matching make-bytevector's lax stance) and packs -# them into a fresh bytevector. +# entry. Reads elements via parse_list; every element must be a fixnum byte +# in 0..255, then packs them into a fresh bytevector. # # Locals: # list parsed element list (cursor during fill pass) @@ -668,13 +842,24 @@ :.loop %if_nil(t1, a0, &.done) %car(t1, a0) + %tagof(t2, t1) + %bine(t2, %TAG.FIXNUM, &.bad, a1) %untag_fix(t1, t1) + %bltz(t1, &.bad) + %li(t2, 256) + %bltu(t1, t2, &.store) + %b(&.bad) + :.store %sb(t1, t0, 0) %addi(t0, t0, 1) %cdr(a0, a0) %b(&.loop) :.done %ldl(a0, result) + %gceret + + :.bad + %die(msg_bad_byte) }) # is_ident_byte(c=a0) -> a1 (1 if c is a valid identifier byte, else 0). @@ -734,9 +919,7 @@ %beq(t1, t2, &.end) %readbuf_byte(a0, t1) - %is_ws_branch(a1, a0, &.end) - %bceq(a0, -40, &.end, a1) ; '(' - %bceq(a0, -41, &.end, a1) ; ')' + %is_token_delimiter_branch(a1, a0, &.end) %addi(t1, t1, 1) %b(&.scan) @@ -810,28 +993,33 @@ %addi(a1, a1, -1) :.no_plus %stl(a1, cursor) ; save adjusted len (cursor slot is free on int path) - %call(&parse_dec) ; P1pp: -> (raw_val=a0, consumed=a1) + %call(&parse_exact_dec) ; -> (raw_val=a0, consumed=a1) %ldl(t0, cursor) %bne(a1, t0, &.int_bad) ; partial parse -> bad - %mkfix(a0, a0) + %mov(t0, a0) + %mkfix(a0, t0) + %untag_fix(t1, a0) + %bne(t0, t1, &.int_overflow) %eret :.int_bad %die(msg_bad_number) + :.int_overflow + %die(msg_integer_overflow) }) -# parse_string() -> tagged bytevector in a0. Cursor sits past the +# parse_string() -> tagged string in a0. Cursor sits past the # opening '"' (consumed by parse_one). Two-pass: pass 1 walks the body, # counting decoded bytes in a0 and locating the closing '"'; pass 2 -# allocates the bv and decodes into its data buffer. Each named escape +# allocates the string and decodes into its data buffer. Each named escape # (\n \t \r \\ \") yields one byte; an inline-hex escape \xHEX; (1+ # hex digits, value 0..255, terminated by ';') also yields one byte. # # Locals: # start cursor (first content byte) # end cursor (closing '"' position) -# bv wrapper (saved across the data fill loop) +# bv string wrapper (saved across the data fill loop) # spill slot (write ptr saved across parse_hex in \x escape) -%fn2(parse_string, {start end bv spill}, { +%fn2(parse_string, {start end bv spill hex_len}, { %ld_global(t1, &readbuf_pos) %stl(t1, start) @@ -877,7 +1065,7 @@ :.scan_done %stl(t1, end) - %call(&str_alloc) + %call(&string_alloc) %stl(a0, bv) # Pass 2: decode into the freshly allocated data buffer. @@ -920,27 +1108,44 @@ %b(&.fill) :.esc_hex - # Skip past 'x'. parse_hex consumes hex digits; demand at least one, - # value <= 255, and an immediate ';' terminator. parse_hex clobbers - # t0/t1/t2 and a2/a3, so spill the cursor (t1) and write ptr (a3) - # across the call. sp+0 is free once pass 1 finishes. + # Skip past 'x', locate the immediate ';', and normalize leading zeroes. + # A byte has at most two significant hex digits; capping before parse_hex + # prevents a huge escape from wrapping the host word back into 0..255. %addi(t1, t1, 1) ; t1 -> first hex digit - %stl(t1, start) %stl(a3, spill) + %mov(t0, t1) + :.esc_hex_scan + %beq(t0, t2, &.hex_bad) + %readbuf_byte(a1, t0) + %bceq(a1, -59, &.esc_hex_found, a2) + %addi(t0, t0, 1) + %b(&.esc_hex_scan) + :.esc_hex_found + %stl(t0, start) ; semicolon cursor + %sub(a1, t0, t1) ; digit count + %beqz(a1, &.hex_bad) + :.esc_hex_trim + %li(a2, 1) + %beq(a1, a2, &.esc_hex_count) + %readbuf_byte(a0, t1) + %bcne(a0, -48, &.esc_hex_count, a2) + %addi(t1, t1, 1) + %addi(a1, a1, -1) + %b(&.esc_hex_trim) + :.esc_hex_count + %li(a2, 3) + %bltu(a1, a2, &.esc_hex_parse) + %b(&.hex_bad) + :.esc_hex_parse + %stl(a1, hex_len) %ld_global(t0, &readbuf_buf_ptr) %add(a0, t0, t1) ; ptr to first hex digit - %sub(a1, t2, t1) ; max len (bytes left in body) %call(&parse_hex) ; -> (a0=value, a1=consumed) - %beqz(a1, &.hex_bad) - %li(t0, 255) - %bltu(t0, a0, &.hex_bad) - %ldl(t1, start) - %add(t1, t1, a1) ; t1 = position of expected ';' - %ldl(t2, end) - %beq(t1, t2, &.hex_bad) - %readbuf_byte(t0, t1) - %bcne(t0, -59, &.hex_bad, t0) ; ';' + %ldl(t0, hex_len) + %bne(a1, t0, &.hex_bad) + %ldl(t1, start) ; semicolon cursor %addi(t1, t1, 1) ; consume ';' + %ldl(t2, end) ; parse_hex clobbered the body end %ldl(a3, spill) %sb(a0, a3, 0) %addi(a3, a3, 1) @@ -969,11 +1174,11 @@ %call(&memcmp) %bnez(a0, &.bad) %li(a0, value) - %mkfix(a0, a0) + %mkchar(a0, a0) %eret %endm -# parse_char() -> tagged fixnum (the u8 char value) in a0. Cursor sits +# parse_char() -> tagged character (the u8 value) in a0. Cursor sits # past '#\\' (consumed by parse_one's hash dispatch). Always consumes # at least one byte; then continues until ws/paren/EOF. Single-byte # bodies yield that byte; multi-byte bodies dispatch to hex (#\xNN) or @@ -997,9 +1202,7 @@ :.scan %beq(t1, t2, &.scan_done) %readbuf_byte(a0, t1) - %is_ws_branch(a1, a0, &.scan_done) - %bceq(a0, -40, &.scan_done, a1) ; '(' - %bceq(a0, -41, &.scan_done, a1) ; ')' + %is_token_delimiter_branch(a1, a0, &.scan_done) %addi(t1, t1, 1) %b(&.scan) @@ -1033,14 +1236,37 @@ %ld_global(t2, &readbuf_buf_ptr) %add(t2, t2, t0) %lb(a0, t2, 0) - %mkfix(a0, a0) + %mkchar(a0, a0) %eret :.hex_form %addi(a0, t2, 1) %addi(a1, a2, -1) + # Strip leading zeroes and reject more than two significant digits + # before calling the machine-word parser. + :.hex_trim + %li(t0, 1) + %beq(a1, t0, &.hex_count) + %lb(t1, a0, 0) + %addi(t1, t1, -48) + %bnez(t1, &.hex_count) + %addi(a0, a0, 1) + %addi(a1, a1, -1) + %b(&.hex_trim) + :.hex_count + %li(t0, 3) + %bltu(a1, t0, &.hex_parse) + %b(&.bad) + :.hex_parse + %stl(a1, start) %call(&parse_hex) - %mkfix(a0, a0) + %ldl(t0, start) + %bne(a1, t0, &.bad) + %li(t0, 256) + %bltu(a0, t0, &.hex_ok) + %b(&.bad) + :.hex_ok + %mkchar(a0, a0) %eret :.try_tab @@ -1465,10 +1691,8 @@ # eval_setbang(rest=a0, env=a1) -> UNSPEC (a0). # rest = (sym value-expr). Evaluates value-expr in env, then walks the # env alist looking for a binding cell whose car is the target sym; -# on hit, mutates the cell's cdr (offset 7, same as set-cdr!). On miss, -# falls back to the global slot via sym_set_global -- the shape used -# by define for top-level rebind. Spec: behavior on a truly unbound -# name follows the primitive-failure policy. +# on hit, mutates the cell's cdr (offset 7, same as set-cdr!). On a lexical +# miss it may update an existing global binding, but it must not create one. # # Locals: # rest (sym . (value-expr . ())) @@ -1508,29 +1732,56 @@ %gceret :.miss - # Miss: rebind global. + # Miss: require an existing global binding before replacing it. + %ldl(t0, rest) + %car(a0, t0) + %untag_sym(a0, a0) + %call(&sym_global) + %bieq(a0, %imm_val(%IMM.UNBOUND), &.unbound, t0) %ldl(a0, saved) %ldl(t0, rest) %car(t0, t0) %set_global(t0, a0) %li(a0, %imm_val(%IMM.UNSPEC)) + %gceret + + :.unbound + %die(msg_unbound_set) }) # eval_cond(clauses=a0, env=a1) -> value (a0). # Clause shapes: (else body...), (test body...), (test => proc-expr). # else / => are literal symbols matched by pointer equality. The => -# arrow is only recognized in non-else clauses; an empty body after a -# truthy test returns UNSPEC (spec policy: malformed-form UB). +# arrow is only recognized in non-else clauses. A successful one-expression +# clause returns its test value, and `else` must be final. # # Locals: # clauses (advances) # env -# test value (live across the => eval/cons calls) +# test validation cursor, then value (live across the => eval/cons calls) # proc (live across the => cons call) %gcfn2(eval_cond, {clauses env test proc}, 15, 0, { %stl(a0, clauses) %stl(a1, env) + # Validate the placement of `else` before evaluating any test. Otherwise + # an earlier true clause could make a syntactically invalid later `else` + # silently unreachable. + %stl(a0, test) + :.validate + %ldl(t0, test) + %if_nil(t1, t0, &.loop) + %car(t1, t0) ; clause + %car(t2, t1) ; test expression + %ld_global(a0, &sym_else) + %bne(t2, a0, &.validate_next) + %cdr(t0, t0) + %if_nil(t1, t0, &.loop) + %die(msg_cond_else_not_final) + :.validate_next + %advance_walk(test) + %b(&.validate) + :.loop %ldl(t0, clauses) %if_nil(t1, t0, &.no_match) @@ -1547,13 +1798,13 @@ %li(t0, %imm_val(%IMM.FALSE)) %beq(a0, t0, &.next) - # Truthy. Spill test value and inspect cdr(clause): empty -> UNSPEC, + # Truthy. Spill test value and inspect cdr(clause): empty -> test value, # car == => -> arrow path, else regular body. %stl(a0, test) %ldl(t0, clauses) %car(t0, t0) %cdr(t0, t0) - %if_nil(t1, t0, &.no_match) + %if_nil(t1, t0, &.test_only) %car(t1, t0) %ld_global(t2, &sym_arrow) %beq(t1, t2, &.arrow) @@ -1575,8 +1826,17 @@ %ldl(a0, proc) %gctail(&apply) + :.test_only + %ldl(a0, test) + %gceret + :.else_clause %ldl(t0, clauses) + %cdr(t0, t0) + %if_nil(t1, t0, &.else_final) + %die(msg_cond_else_not_final) + :.else_final + %ldl(t0, clauses) %car(t0, t0) %cdr(a0, t0) %ldl(a1, env) @@ -2356,8 +2616,8 @@ # - pair (otherwise): subj must be a pair; recurse on car, then cdr. # - atomic (fixnum, sym, immediate, identical heap pointer): raw # word equality. -# - HEAP-tagged HDR.BV: structural byte-for-byte equality via -# bv_equal_check; only when both pat and subj are HDR.BV. +# - HEAP-tagged HDR.BV / HDR.STRING: structural byte-for-byte equality +# via bv_equal_check, including mixed string/bytevector matches. # # Locals: # pat @@ -2378,14 +2638,23 @@ # heap pointer. %beq(a0, a1, &.ok) - # HDR.BV equality. + # Byte-literal equality. pmatch intentionally widens this one literal + # rule so a string pattern can match a bytevector token and vice versa. %bine(t0, %TAG.HEAP, &.no, t1) %hdr_type(t1, a0) - %bine(t1, %HDR.BV, &.no, t2) + %li(t2, %HDR.BV) + %beq(t1, t2, &.pat_bytes) + %li(t2, %HDR.STRING) + %bne(t1, t2, &.no) + :.pat_bytes %tagof(t1, a1) %bine(t1, %TAG.HEAP, &.no, t2) %hdr_type(t1, a1) - %bine(t1, %HDR.BV, &.no, t2) + %li(t2, %HDR.BV) + %beq(t1, t2, &.subj_bytes) + %li(t2, %HDR.STRING) + %bne(t1, t2, &.no) + :.subj_bytes %call(&bv_equal_check) %bieq(a0, %imm_val(%IMM.TRUE), &.ok, t0) %b(&.no) @@ -2703,9 +2972,14 @@ %beq(t1, t2, &.pair) %li(t2, %TAG.SYM) %beq(t1, t2, &.rest_bind) - %b(&.done) + %if_nil(t2, t0, &.fixed_done) + %b(&.arity_error) :.pair + # A fixed parameter requires a corresponding argument. + %ldl(t0, args) + %tagof(t1, t0) + %bine(t1, %TAG.PAIR, &.arity_error, t2) # binding = cons(car(params), car(args)) %ldl(t0, params) %car(a0, t0) @@ -2731,9 +3005,20 @@ %ldl(a1, env) %call(&cons) %stl(a0, env) + %b(&.done) + + :.fixed_done + # Fixed arity also rejects surplus arguments. + %ldl(t0, args) + %if_nil(t1, t0, &.done) + %b(&.arity_error) :.done %ldl(a0, env) + %gceret + + :.arity_error + %die(msg_arity) }) # eval_body(body=a0, env=a1) -> value of last form (a0). @@ -3013,6 +3298,8 @@ %andi(t1, t1, 255) %li(t2, %HDR.BV) %beq(t1, t2, &.bv) + %li(t2, %HDR.STRING) + %beq(t1, t2, &.bv) %li(t2, %HDR.CLOSURE) %beq(t1, t2, &.closure) %li(t2, %HDR.PRIM) @@ -3743,9 +4030,7 @@ %ret .endscope -# (string? x) -- #t iff x is a HEAP-tagged HDR.BV. Bytevectors back the -# string type until characters get a distinct repr; this prim is also -# the bytevector? predicate. +# (string? x) -- #t iff x is a HEAP-tagged HDR.STRING. :prim_stringq_entry .scope %car(t0, a0) @@ -3754,8 +4039,43 @@ %li(t2, %TAG.HEAP) %bne(t1, t2, &.end) %hdr_type(t1, t0) + %li(t2, %HDR.STRING) + %bne(t1, t2, &.end) + %li(a0, %imm_val(%IMM.TRUE)) + :.end + %ret +.endscope + +# (bytevector? x) -- #t iff x is a HEAP-tagged HDR.BV. +:prim_bytevectorq_entry +.scope + %car(t0, a0) + %li(a0, %imm_val(%IMM.FALSE)) + %tagof(t1, t0) + %li(t2, %TAG.HEAP) + %bne(t1, t2, &.end) + %hdr_type(t1, t0) + %li(t2, %HDR.BV) + %bne(t1, t2, &.end) + %li(a0, %imm_val(%IMM.TRUE)) + :.end + %ret +.endscope + +# (bytes? x) -- boot2 bridge predicate: string or bytevector. +:prim_bytesq_entry +.scope + %car(t0, a0) + %li(a0, %imm_val(%IMM.FALSE)) + %tagof(t1, t0) + %li(t2, %TAG.HEAP) + %bne(t1, t2, &.end) + %hdr_type(t1, t0) %li(t2, %HDR.BV) + %beq(t1, t2, &.true) + %li(t2, %HDR.STRING) %bne(t1, t2, &.end) + :.true %li(a0, %imm_val(%IMM.TRUE)) :.end %ret @@ -3963,8 +4283,8 @@ %shri(a1, a1, 8) ; length %b(&intern) -# (symbol->string sym) -- fresh bv copy of the symtab name. sym_name -# returns (ptr, len); str_alloc gives us a NUL-terminated wrapper; +# (symbol->string sym) -- fresh string copy of the symtab name. sym_name +# returns (ptr, len); string_alloc gives us a length-bearing wrapper; # memcpy fills the data. Frame holds the (ptr, len) pair across # str_alloc and the resulting bv across memcpy. @@ -3975,7 +4295,7 @@ %stl(a0, ptr) %stl(a1, len) %mov(a0, a1) - %call(&str_alloc) ; tagged bv in a0 + %call(&string_alloc) ; tagged string in a0 %stl(a0, bv) %ldl(a1, ptr) ; src ptr %ldl(a2, len) ; len @@ -3985,10 +4305,8 @@ %ldl(a0, bv) }) -# (number->string n [radix]) -- fresh bv with the integer's text form. -# Radix 16 selects str_puthex (lowercase, leading '-' for negatives); -# any other radix (or omitted) selects decimal. str_alloc(0) gives an -# empty NUL-terminated wrapper that the str_put* helper grows in place. +# (number->string n [radix]) -- fresh string with the integer's text form. +# Radices other than the micro-supported 10 and 16 fail closed. %fn2(prim_number_to_string_entry, {value radix}, { %car(t0, a0) @@ -4010,17 +4328,27 @@ %ldl(a1, value) %ldl(t0, radix) %bieq(t0, 16, &.hex, t1) - %tail(&str_putint) + %bine(t0, 10, &.bad_radix, t1) + %call(&str_putint) + %b(&.finish) :.hex - %tail(&str_puthex) + %call(&str_puthex) + :.finish + # str_put* builds a NUL-bearing bytevector; retag only the heap header, + # preserving its logical length, data pointer, and capacity. + %heap_ld(t0, a0, %BV.hdr) + %ori(t0, t0, %HDR.STRING) + %heap_st(t0, a0, %BV.hdr) + %eret + :.bad_radix + %die(msg_bad_radix) }) # (string->number bv [radix]) -- decimal goes through parse_dec; radix # 16 strips an optional leading '-' and calls parse_hex over the # remainder, demanding it consume every byte. Returns #f on -# non-bytevector input, empty string, lone "-", or any non-recognized -# byte. Other radices are not pinned by LISP.md and currently fall -# through to the decimal path. +# non-byte input, empty string, lone sign, or any non-recognized byte. +# Radices other than 10 and 16 fail closed. %fn2(prim_string_to_number_entry, {args ptr len sign}, { %stl(a0, args) @@ -4028,7 +4356,11 @@ %tagof(t0, t2) %bine(t0, %TAG.HEAP, &.fail, t1) %hdr_type(t0, t2) - %bine(t0, %HDR.BV, &.fail, t1) + %li(t1, %HDR.BV) + %beq(t0, t1, &.bytes_ok) + %li(t1, %HDR.STRING) + %bne(t0, t1, &.fail) + :.bytes_ok %heap_ld(t0, t2, %BV.data) %heap_ld(t1, t2, %BV.hdr) @@ -4043,6 +4375,7 @@ %car(t1, t0) %sari(t1, t1, 3) %bieq(t1, 16, &.hex, t2) + %bine(t1, 10, &.bad_radix, t2) :.dec %ldl(a0, ptr) @@ -4055,10 +4388,13 @@ %beqz(a1, &.fail) :.dec_no_plus %stl(a1, len) ; save adjusted len - %call(&parse_dec) ; P1pp: -> (raw_val=a0, consumed=a1) + %call(&parse_exact_dec) ; -> (raw_val=a0, consumed=a1) %ldl(t0, len) %bne(a1, t0, &.fail) ; partial parse -> fail - %mkfix(a0, a0) + %mov(t0, a0) + %mkfix(a0, t0) + %untag_fix(t1, a0) + %bne(t0, t1, &.overflow) %b(&.end) :.hex @@ -4087,19 +4423,55 @@ %beqz(t0, &.fail) :.hex_parse + # Normalize leading zeroes and cap significant digits before calling + # the machine-word parser, then enforce the signed tagged range. + :.hex_trim_zero + %ldl(t0, len) + %li(t1, 1) + %beq(t0, t1, &.hex_count_check) + %ldl(t1, ptr) + %lb(t2, t1, 0) + %addi(t2, t2, -48) + %bnez(t2, &.hex_count_check) + %addi(t1, t1, 1) + %stl(t1, ptr) + %addi(t0, t0, -1) + %stl(t0, len) + %b(&.hex_trim_zero) + :.hex_count_check + %li(t1, 17) + %bltu(t0, t1, &.hex_parse_go) + %b(&.overflow) + :.hex_parse_go %ldl(a0, ptr) %ldl(a1, len) %call(&parse_hex) ; -> (a0=value, a1=consumed) %ldl(t0, len) %bne(a1, t0, &.fail) ; demand full consumption + %li(t0, -1) + %shri(t0, t0, 4) + %ldl(t1, sign) + %beqz(t1, &.hex_limit_ready) + %addi(t0, t0, 1) + :.hex_limit_ready + %bltu(t0, a0, &.overflow) %ldl(t0, sign) %beqz(t0, &.hex_pos) %li(t1, 0) %sub(a0, t1, a0) :.hex_pos - %mkfix(a0, a0) + %mov(t0, a0) + %mkfix(a0, t0) + %untag_fix(t1, a0) + %bne(t0, t1, &.overflow) %b(&.end) + :.bad_radix + %die(msg_bad_radix) + + :.overflow + %die(msg_integer_overflow) + :.fail %li(a0, %imm_val(%IMM.FALSE)) :.end @@ -4131,6 +4503,50 @@ %ret .endscope +# Characters are immediate byte values with their own tag, disjoint from +# exact integers. +:prim_charq_entry +.scope + %car(t0, a0) + %tagof(t1, t0) + %li(t2, %TAG.CHAR) + %li(a0, %imm_val(%IMM.FALSE)) + %bne(t1, t2, &.end) + %li(a0, %imm_val(%IMM.TRUE)) + :.end + %ret +.endscope + +:prim_char_to_integer_entry +.scope + %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.CHAR, &.bad, t2) + %untag_char(t0, t0) + %mkfix(a0, t0) + %ret + :.bad + %die(msg_type) +.endscope + +:prim_integer_to_char_entry +.scope + %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.FIXNUM, &.type, t2) + %untag_fix(t0, t0) + %bltz(t0, &.bad) + %li(t1, 256) + %bltu(t0, t1, &.ok) + :.bad + %die(msg_bad_char) + :.type + %die(msg_type) + :.ok + %mkchar(a0, t0) + %ret +.endscope + # (symbol? x) -- #t iff x is TAG.SYM (interned symbol index, not a heap obj). :prim_symbolq_entry .scope @@ -4197,68 +4613,161 @@ %ret .endscope +# checked_mul_raw(x=a0, y=a1) -> raw exact result. Inputs are already in +# the tagged-fixnum range. Products of two values whose magnitudes are below +# 2^30 are provably in range and take a division-free fast path. Larger +# operands use sign-quadrant bounds checks before the machine multiply, so +# host wraparound is never used as a Scheme result. +:checked_mul_raw +.scope + %beqz(a0, &.zero) + %beqz(a1, &.zero) + + # abs(x), abs(y) <= 2^30-1 implies + # abs(x*y) <= (2^30-1)^2 < 2^60. + %li(t0, 1073741823) + %blt(t0, a0, &.full_check) + %blt(t0, a1, &.full_check) + %li(t1, -1073741823) + %blt(a0, t1, &.full_check) + %blt(a1, t1, &.full_check) + %mul(a0, a0, a1) + %ret + + # max = 2^60-1; min = -2^60 on the P1-64 targets. + :.full_check + %li(t0, -1) + %shri(t0, t0, 4) ; max + %addi(t1, t0, 1) + %li(t2, 0) + %sub(t1, t2, t1) ; min + + %bltz(a0, &.x_negative) + %bltz(a1, &.pos_neg) + # x > 0, y > 0: x <= max / y. + %div(t2, t0, a1) + %blt(t2, a0, &.overflow) + %b(&.multiply) + + :.pos_neg + # x > 0, y < 0: y >= min / x. + %div(t2, t1, a0) + %blt(a1, t2, &.overflow) + %b(&.multiply) + + :.x_negative + %bltz(a1, &.neg_neg) + # x < 0, y > 0: x >= min / y. + %div(t2, t1, a1) + %blt(a0, t2, &.overflow) + %b(&.multiply) + + :.neg_neg + # x < 0, y < 0: x >= max / y (both sides are negative). + %div(t2, t0, a1) + %blt(a0, t2, &.overflow) + + :.multiply + %mul(a0, a0, a1) + %ret + + :.zero + %li(a0, 0) + %ret + + :.overflow + %die(msg_integer_overflow) +.endscope + # Variadic arithmetic. (+ ...) folds with identity 0; (* ...) folds with -# identity 1; (- x) is unary negate, (- x y z ...) folds left. +# identity 1; (- x) is unary negate, (- x y z ...) folds left. Every +# intermediate result is checked against the tagged exact-integer range. :prim_plus_entry .scope - %li(t0, 0) ; tagged 0; tag bits stay 0 across %add + %li(t0, 0) ; raw accumulator :.loop %if_nil(t1, a0, &.done) %car(t1, a0) + %untag_fix(t1, t1) %add(t0, t0, t1) + %mkfix(t2, t0) + %untag_fix(a1, t2) + %bne(t0, a1, &.overflow) %cdr(a0, a0) %b(&.loop) :.done - %mov(a0, t0) + %mkfix(a0, t0) %ret + :.overflow + %die(msg_integer_overflow) .endscope # (- x) -> -x; (- x y ...) -> x - y - ... . (-) is undefined behavior # per the primitive-failure policy. :prim_minus_entry .scope - %car(t0, a0) ; seed = first arg (tagged) + %if_nil(t0, a0, &.arity) + %car(t0, a0) + %untag_fix(t0, t0) ; raw seed %cdr(a0, a0) %if_nil(t1, a0, &.neg) :.loop %if_nil(t1, a0, &.done) %car(t1, a0) + %untag_fix(t1, t1) %sub(t0, t0, t1) + %mkfix(t2, t0) + %untag_fix(a1, t2) + %bne(t0, a1, &.overflow) %cdr(a0, a0) %b(&.loop) :.neg %li(t1, 0) ; unary: 0 - seed %sub(t0, t1, t0) + %mkfix(t2, t0) + %untag_fix(a1, t2) + %bne(t0, a1, &.overflow) :.done - %mov(a0, t0) + %mkfix(a0, t0) %ret + :.overflow + %die(msg_integer_overflow) + :.arity + %die(msg_arity) .endscope -# Multiply keeps the accumulator tagged and untags each incoming arg: -# (a<<3) * b == (a*b)<<3, so the loop preserves the fixnum tag. -:prim_mult_entry -.scope - %li(t0, 8) ; tagged 1 = mkfix(1) +# Multiply uses the checked raw helper because a 61-bit by 61-bit product +# can overflow the host word before a post-hoc tag check could observe it. +%fn2(prim_mult_entry, {args acc}, { + %stl(a0, args) + %li(t0, 1) + %stl(t0, acc) :.loop - %if_nil(t1, a0, &.done) - %car(t1, a0) + %ldl(t0, args) + %if_nil(t1, t0, &.done) + %car(t1, t0) %untag_fix(t1, t1) - %mul(t0, t0, t1) - %cdr(a0, a0) + %ldl(a0, acc) + %mov(a1, t1) + %call(&checked_mul_raw) + %stl(a0, acc) + %advance_walk(args) %b(&.loop) :.done - %mov(a0, t0) - %ret -.endscope + %ldl(a0, acc) + %mkfix(a0, a0) +}) # Variadic chained comparisons: (op a b c ...) ⇔ (a op b) ∧ (b op c) ∧ ... # Walks the tail with a single live `prev` register; a0 is reused as the # args cursor and finally as the result. <2 args is undefined behavior. :prim_eq_entry .scope + %if_nil(t0, a0, &.arity) %car(t0, a0) ; prev = first %cdr(a0, a0) + %if_nil(t1, a0, &.arity) :.loop %if_nil(t1, a0, &.true) %car(t1, a0) ; curr @@ -4272,12 +4781,16 @@ :.false %li(a0, %imm_val(%IMM.FALSE)) %ret + :.arity + %die(msg_arity) .endscope :prim_lt_entry .scope + %if_nil(t0, a0, &.arity) %car(t0, a0) %cdr(a0, a0) + %if_nil(t1, a0, &.arity) :.loop %if_nil(t1, a0, &.true) %car(t1, a0) @@ -4291,12 +4804,16 @@ :.true %li(a0, %imm_val(%IMM.TRUE)) %ret + :.arity + %die(msg_arity) .endscope :prim_gt_entry .scope + %if_nil(t0, a0, &.arity) %car(t0, a0) %cdr(a0, a0) + %if_nil(t1, a0, &.arity) :.loop %if_nil(t1, a0, &.true) %car(t1, a0) @@ -4310,23 +4827,61 @@ :.true %li(a0, %imm_val(%IMM.TRUE)) %ret + :.arity + %die(msg_arity) .endscope -# (quotient x y) -- truncating integer division. Both fixnums are tagged -# (real << 3); div(tagged, tagged) yields the raw quotient (the shifts -# cancel), which mkfix retags. UB on y == 0. +# (quotient x y) -- truncating integer division with explicit zero and +# representability checks. :prim_quotient_entry +.scope %args2(t0, t1, a0) - %div(a0, t0, t1) - %mkfix(a0, a0) + %untag_fix(t0, t0) + %untag_fix(t1, t1) + %beqz(t1, &.zero) + # Avoid the architecture-specific signed-divide overflow case before + # issuing the instruction (x86 traps for min / -1). + %li(t2, -1) + %bne(t1, t2, &.divide) + %li(a0, -1) + %shri(a0, a0, 4) + %addi(a0, a0, 1) + %li(a1, 0) + %sub(a0, a1, a0) ; tagged-fixnum minimum, raw + %beq(t0, a0, &.overflow) + :.divide + %div(t0, t0, t1) + %mkfix(a0, t0) + %untag_fix(t1, a0) + %bne(t0, t1, &.overflow) %ret + :.zero + %die(msg_divide_zero) + :.overflow + %die(msg_integer_overflow) +.endscope # (remainder x y) -- truncating remainder, sign of dividend. rem(tagged, # tagged) = 8 * (real_x rem real_y), already in tagged form. :prim_remainder_entry +.scope %args2(t0, t1, a0) + %untag_fix(t0, t0) + %untag_fix(t1, t1) + %beqz(t1, &.zero) + # min % -1 is zero, but the underlying x86 divide instruction traps; + # answer it directly on every target. + %li(t2, -1) + %beq(t1, t2, &.result_zero) %rem(a0, t0, t1) + %mkfix(a0, a0) %ret + :.result_zero + %li(a0, 0) + %ret + :.zero + %die(msg_divide_zero) +.endscope # Variadic bitwise folds. Tagged fixnums have low 3 bits = 0, so AND/OR/ # XOR with another tagged fixnum preserves the tag in the accumulator. @@ -4393,15 +4948,34 @@ %untag_fix(t0, t0) %untag_fix(t1, t1) %bltz(t1, &.right) - %shl(a0, t0, t1) - %mkfix(a0, a0) + %beqz(t0, &.zero) + %li(t2, 61) + %bltu(t1, t2, &.left_do) + %b(&.overflow) + :.left_do + %shl(t2, t0, t1) + %mkfix(a0, t2) + %untag_fix(a1, a0) + %bne(t2, a1, &.overflow) %ret :.right %li(t2, 0) %sub(t1, t2, t1) + %li(t2, 64) + %bltu(t1, t2, &.right_do) + %bltz(t0, &.minus_one) + :.zero + %li(a0, 0) + %ret + :.minus_one + %li(a0, -8) + %ret + :.right_do %sar(a0, t0, t1) %mkfix(a0, a0) %ret + :.overflow + %die(msg_integer_overflow) .endscope # Bytevectors are 24-byte HEAP-tagged wrappers pointing at a separately @@ -4523,11 +5097,21 @@ %gcfn2(prim_make_bytevector_entry, {args fill wrapper}, 5, 0, { %stl(a0, args) + %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.FIXNUM, &.bad_type, t2) + %li(t2, 0) %cdr(t0, a0) %if_nil(t1, t0, &.no_fill) %car(t0, t0) - %sari(t2, t0, 3) + %tagof(t1, t0) + %bine(t1, %TAG.FIXNUM, &.bad_type, t2) + %untag_fix(t2, t0) + %bltz(t2, &.bad_fill) + %li(t1, 256) + %bltu(t2, t1, &.no_fill) + %b(&.bad_fill) :.no_fill %stl(t2, fill) @@ -4557,31 +5141,162 @@ :.bad_len %die(msg_bv_oob) + :.bad_fill + %die(msg_bad_byte) + :.bad_type + %die(msg_type) +}) + +# (make-string len) or (make-string len fill-char). Strings have an explicit +# logical length and a spare NUL after it for the boot2 pathname bridge. +%gcfn2(prim_make_string_entry, {args fill wrapper}, 5, 0, { + %stl(a0, args) + + %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.FIXNUM, &.bad_type, t2) + + %li(t2, 32) ; implementation-selected default: space + %cdr(t0, a0) + %if_nil(t1, t0, &.no_fill) + %car(t0, t0) + %tagof(t1, t0) + %bine(t1, %TAG.CHAR, &.bad_type, t2) + %untag_char(t2, t0) + :.no_fill + %stl(t2, fill) + + %ldl(a0, args) + %car_fix(a0, a0) + %bltz(a0, &.bad_len) + %call(&string_alloc) + %stl(a0, wrapper) + + %ldl(t0, args) + %car_fix(t0, t0) + %ldl(t1, fill) + %ldl(a0, wrapper) + %heap_ld(t2, a0, %BV.data) + %li(a1, 0) + :.fill_loop + %beq(a1, t0, &.fill_done) + %sb(t1, t2, 0) + %addi(t2, t2, 1) + %addi(a1, a1, 1) + %b(&.fill_loop) + :.fill_done + %ldl(a0, wrapper) + %gceret + + :.bad_len + %die(msg_string_oob) + :.bad_type + %die(msg_type) }) :prim_bv_length_entry +.scope %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.HEAP, &.bad, t2) + %hdr_type(t1, t0) + %li(t2, %HDR.BV) + %beq(t1, t2, &.ok) + %li(t2, %HDR.STRING) + %bne(t1, t2, &.bad) + :.ok %heap_ld(t1, t0, %BV.hdr) %shri(a0, t1, 5) %ret + :.bad + %die(msg_type) +.endscope -# (string-length s) -- assumes s is a NUL-terminated bv (a "string"); -# returns strlen(data_ptr). Mirrors bytevector-length but uses the NUL -# terminator instead of the bv header. For a well-formed string built -# via str_alloc / str_putn / etc the two agree; for a raw bytevector -# without a NUL the result is unspecified (strlen may walk past the -# data buffer). -%fn(prim_string_length_entry, 0, { +# (string-length s) -- explicit logical length from the string header. +:prim_string_length_entry +.scope %car(t0, a0) + %tagof(t1, t0) + %bine(t1, %TAG.HEAP, &.bad, t2) + %hdr_type(t1, t0) + %bine(t1, %HDR.STRING, &.bad, t2) + %heap_ld(t1, t0, %BV.hdr) + %shri(a0, t1, 5) + %ret + :.bad + %die(msg_type) +.endscope + +# (string-ref s idx) -> disjoint character. +:prim_string_ref_entry +.scope + %args2(t0, t1, a0) + %tagof(t2, t0) + %bine(t2, %TAG.HEAP, &.type, a1) + %hdr_type(t2, t0) + %bine(t2, %HDR.STRING, &.type, a1) + %tagof(t2, t1) + %bine(t2, %TAG.FIXNUM, &.type, a1) + %sari(t1, t1, 3) + %bltz(t1, &.oob) + %heap_ld(a0, t0, %BV.hdr) + %shri(a0, a0, 8) + %bltu(t1, a0, &.ok) + :.oob + %die(msg_string_oob) + :.ok + %heap_ld(t2, t0, %BV.data) + %add(t2, t2, t1) + %lb(a0, t2, 0) + %mkchar(a0, a0) + %ret + :.type + %die(msg_type) +.endscope + +# (string-set! s idx char) -> unspecified. +:prim_string_set_entry +.scope + %args3(t0, t2, t1, a0) + %tagof(a1, t0) + %bine(a1, %TAG.HEAP, &.type, a2) + %hdr_type(a1, t0) + %bine(a1, %HDR.STRING, &.type, a2) + %tagof(a1, t2) + %bine(a1, %TAG.FIXNUM, &.type, a2) + %tagof(a1, t1) + %bine(a1, %TAG.CHAR, &.type, a2) + %sari(t2, t2, 3) + %untag_char(t1, t1) + %bltz(t2, &.oob) + %heap_ld(a0, t0, %BV.hdr) + %shri(a0, a0, 8) + %bltu(t2, a0, &.ok) + :.oob + %die(msg_string_oob) + :.ok %heap_ld(a0, t0, %BV.data) - %call(&libp1pp__strlen) - %mkfix(a0, a0) - %eret -}) + %add(a0, a0, t2) + %sb(t1, a0, 0) + %li(a0, %imm_val(%IMM.UNSPEC)) + %ret + :.type + %die(msg_type) +.endscope :prim_bv_u8_ref_entry .scope %args2(t0, t1, a0) ; bv, tagged idx + %tagof(t2, t0) + %bine(t2, %TAG.HEAP, &.type, a1) + %hdr_type(t2, t0) + %li(a1, %HDR.BV) + %beq(t2, a1, &.bytes) + %li(a1, %HDR.STRING) + %bne(t2, a1, &.type) + :.bytes + %tagof(t2, t1) + %bine(t2, %TAG.FIXNUM, &.type, a1) %sari(t1, t1, 3) ; raw idx %bltz(t1, &.oob) %heap_ld(a0, t0, %BV.hdr) @@ -4595,13 +5310,32 @@ %lb(a0, t2, 0) %mkfix(a0, a0) %ret + :.type + %die(msg_type) .endscope :prim_bv_u8_set_entry .scope %args3(t0, t2, t1, a0) ; bv, idx, val + %tagof(a1, t0) + %bine(a1, %TAG.HEAP, &.type, a2) + %hdr_type(a1, t0) + %li(a2, %HDR.BV) + %beq(a1, a2, &.bytes) + %li(a2, %HDR.STRING) + %bne(a1, a2, &.type) + :.bytes + %tagof(a1, t2) + %bine(a1, %TAG.FIXNUM, &.type, a2) + %tagof(a1, t1) + %bine(a1, %TAG.FIXNUM, &.type, a2) %sari(t2, t2, 3) ; raw idx %sari(t1, t1, 3) ; raw val + %bltz(t1, &.bad_byte) + %li(a1, 256) + %bltu(t1, a1, &.value_ok) + %b(&.bad_byte) + :.value_ok %bltz(t2, &.oob) %heap_ld(a0, t0, %BV.hdr) %shri(a0, a0, 8) ; length @@ -4614,6 +5348,10 @@ %sb(t1, a0, 0) %li(a0, %imm_val(%IMM.UNSPEC)) %ret + :.bad_byte + %die(msg_bad_byte) + :.type + %die(msg_type) .endscope # (bytevector-copy src start end) -> fresh bv of length end-start. @@ -4736,14 +5474,36 @@ %ldl(a3, src_end) %sub(a3, a3, a2) ; count - :.loop + # memmove semantics: when destination starts inside the source range, + # copy from the end so an overlapping in-place move cannot trample bytes + # that have not been read yet. + %beqz(a3, &.done) + %bltu(a1, t0, &.dst_after_src) + %b(&.forward_loop) + :.dst_after_src + %add(t1, a1, a3) ; source end + %bltu(t0, t1, &.backward_setup) + + :.forward_loop %beqz(a3, &.done) %lb(t1, a1, 0) %sb(t1, t0, 0) %addi(t0, t0, 1) %addi(a1, a1, 1) %addi(a3, a3, -1) - %b(&.loop) + %b(&.forward_loop) + + :.backward_setup + %add(t0, t0, a3) + %add(a1, a1, a3) + :.backward_loop + %beqz(a3, &.done) + %addi(t0, t0, -1) + %addi(a1, a1, -1) + %lb(t1, a1, 0) + %sb(t1, t0, 0) + %addi(a3, a3, -1) + %b(&.backward_loop) :.done %li(a0, %imm_val(%IMM.UNSPEC)) @@ -4788,9 +5548,8 @@ %ret .endscope -# (bytevector=? a b) -- structural equality on bytevectors. Non-bv -# inputs return #f rather than aborting, matching the lax stance the -# other predicates take until LISP.md pins a stricter policy. +# (bytevector=? a b) / (bytes=? a b) -- byte-oriented bridge equality. +# Each operand may be a string or bytevector; other inputs return #f. :prim_bytevector_eq_entry .scope %args2(t0, t1, a0) @@ -4801,9 +5560,16 @@ %bne(t2, a0, &.false) %hdr_type(t2, t0) %li(a0, %HDR.BV) + %beq(t2, a0, &.a_bytes) + %li(a0, %HDR.STRING) %bne(t2, a0, &.false) + :.a_bytes %hdr_type(t2, t1) + %li(a0, %HDR.BV) + %beq(t2, a0, &.both_bytes) + %li(a0, %HDR.STRING) %bne(t2, a0, &.false) + :.both_bytes %mov(a0, t0) %mov(a1, t1) %b(&bv_equal_check) @@ -4813,11 +5579,11 @@ .endscope # equal_recurse(a=a0, b=a1) -> a0 (IMM.TRUE / IMM.FALSE). Identity covers -# fixnums, symbols, immediates, and any case where both arguments are the -# same heap or pair pointer. For non-identical pair pointers we recurse -# into car then cdr; for non-identical heap pointers we structural-equal -# only when both are HDR.BV (closures, prims, records, and TDs are -# identity-only). Tail-calls the cdr-side recursion and the BV check. +# fixnums, characters, symbols, immediates, and any case where both arguments +# are the same heap or pair pointer. For non-identical pair pointers we recurse +# into car then cdr. Same-type bytevectors and strings compare by content; +# records compare structurally; closures, prims, and TDs are identity-only. +# Tail-calls the cdr-side recursion and the byte-sequence/record checks. # # Locals: # a @@ -4857,6 +5623,8 @@ %bne(t2, a0, &.false) ; differing heap classes -> #f %li(a0, %HDR.BV) %beq(t2, a0, &.heap_bv) + %li(a0, %HDR.STRING) + %beq(t2, a0, &.heap_bv) %li(a0, %HDR.REC) %beq(t2, a0, &.heap_rec) %b(&.false) ; CLOSURE/PRIM/TD: identity-only @@ -5066,6 +5834,9 @@ # Count = length(args). %call(&list_length) + %ldl(t0, td) + %heap_ld(t1, t0, %TD.nfields) + %bne(a0, t1, &.bad_arity) %shli(a0, a0, 3) %addi(a0, a0, 16) %li(a1, %HDR.REC) @@ -5088,6 +5859,10 @@ :.fill_done %ldl(a0, record) + %gceret + + :.bad_arity + %die(msg_record_ctor_arity) }) # predicate: prim.data = TD; args = (rec). @@ -5153,7 +5928,44 @@ %stl(a0, rest) %stl(a1, env) - # clauses = cdddr(rest); count them via list_length. + # clauses = cdddr(rest). Before allocating or publishing any bindings, + # validate the restricted micro constructor specification: its field + # list must name every declared field exactly once and in declaration + # order. + %ldl(a0, rest) + %cdr(a0, a0) + %cdr(a0, a0) + %cdr(a0, a0) + %stl(a0, walk) + + # fl_cur = cdr(cadr(rest)) -- constructor field cursor. + %ldl(t0, rest) + %cdr(t0, t0) + %car(t0, t0) + %cdr(t0, t0) + %stl(t0, fl_cur) + + :.validate_ctor + %ldl(t0, fl_cur) + %ldl(t1, walk) + %if_nil(t2, t0, &.ctor_fields_done) + %if_nil(t2, t1, &.bad_ctor_spec) + %car(t2, t0) ; constructor field name + %car(a0, t1) ; declaration clause + %car(a0, a0) ; declared field name + %bne(t2, a0, &.bad_ctor_spec) + %cdr(t0, t0) + %stl(t0, fl_cur) + %cdr(t1, t1) + %stl(t1, walk) + %b(&.validate_ctor) + + :.ctor_fields_done + %if_nil(t2, t1, &.ctor_valid) + %b(&.bad_ctor_spec) + + :.ctor_valid + # Restore the declaration cursor after validation and count fields. %ldl(a0, rest) %cdr(a0, a0) %cdr(a0, a0) @@ -5284,6 +6096,10 @@ :.done %li(a0, %imm_val(%IMM.UNSPEC)) + %gceret + + :.bad_ctor_spec + %die(msg_record_ctor_spec) }) # ========================================================================= @@ -5299,9 +6115,9 @@ # and dispatching ~a (display), ~s (write), ~d (decimal), ~% (newline), # and ~~ (literal '~') against successive args. # -# Mode flag for write_to_bv: 0 = display (bytevectors emit raw), 1 = -# write (bytevectors emit "..." with a leading and trailing double quote; -# escapes are not handled because string literals are not yet supported). +# Mode flag for write_to_bv: 0 = display (strings and bytevectors emit raw), +# 1 = write (strings use an escaped quoted spelling and bytevectors use +# #u8(...)). # # bv_putn / bv_putc / bv_putint append raw bytes to a bv and return the # (same wrapper, possibly-grown) bv. They do NOT maintain a trailing NUL @@ -5418,6 +6234,31 @@ %ldl(a0, bv) }) +# string_alloc(raw_len=a0) -> tagged HDR.STRING. Strings share the +# length/data/capacity layout with bytevectors so boot2's byte bridge and +# syscall wrappers can use one compact set of walkers, but the distinct +# header keeps the Scheme types disjoint. A spare trailing NUL is maintained +# for pathname interoperability; it is not part of the logical length. +%gcfn2(string_alloc, {raw_len string}, 2, 0, { + %stl(a0, raw_len) + %addi(a0, a0, 1) + %call(&bv_alloc) + %stl(a0, string) + + %ldl(t0, raw_len) + %shli(t0, t0, 8) + %ori(t0, t0, %HDR.STRING) + %heap_st(t0, a0, %BV.hdr) + + %heap_ld(t1, a0, %BV.data) + %ldl(t2, raw_len) + %add(t1, t1, t2) + %li(t0, 0) + %sb(t0, t1, 0) + + %ldl(a0, string) +}) + # str_putn(bv=a0, src=a1, n=a2) -> bv (a0). Append n bytes; on return # cap > new_len and data[new_len] == 0. %gcfn2(str_putn, {bv src n}, 1, 2, { @@ -5523,11 +6364,245 @@ %ld(a0, t1, %SYMENT.name_ptr) %ret +# hex_digit_ascii(nibble=a0) -> lowercase ASCII byte. +:hex_digit_ascii +.scope + %li(t0, 10) + %bltu(a0, t0, &.digit) + %addi(a0, a0, 87) ; 10 -> 'a' + %ret + :.digit + %addi(a0, a0, 48) + %ret +.endscope + +# write_string_to_bv(string=a0, bv=a1, mode=a2) -> bv. Display mode emits +# the logical bytes. Write mode emits a reader-compatible quoted spelling +# with the micro escape set, including embedded NUL bytes. +%gcfn2(write_string_to_bv, {string bv index length byte}, 3, 0, { + %stl(a0, string) + %stl(a1, bv) + + %heap_ld(t0, a0, %BV.hdr) + %shri(t0, t0, 8) + %stl(t0, length) + %beqz(a2, &.raw) + + %ldl(a0, bv) + %li(a1, 34) ; opening quote + %call(&str_putc) + %li(t0, 0) + %stl(t0, index) + + :.loop + %ldl(t0, index) + %ldl(t1, length) + %beq(t0, t1, &.close) + %ldl(t1, string) + %heap_ld(t2, t1, %BV.data) + %add(t2, t2, t0) + %lb(t2, t2, 0) + %stl(t2, byte) + + %bieq(t2, 10, &.escape_n, t0) + %bieq(t2, 9, &.escape_t, t0) + %bieq(t2, 13, &.escape_r, t0) + %bieq(t2, 92, &.escape_slash, t0) + %bieq(t2, 34, &.escape_quote, t0) + %li(t0, 32) + %bltu(t2, t0, &.escape_hex) + %li(t0, 127) + %bltu(t2, t0, &.plain) + %b(&.escape_hex) + + :.plain + %ldl(a0, bv) + %mov(a1, t2) + %call(&str_putc) + %b(&.advance) + + :.escape_n + %li(t0, 110) ; 'n' + %b(&.escape_two) + :.escape_t + %li(t0, 116) ; 't' + %b(&.escape_two) + :.escape_r + %li(t0, 114) ; 'r' + %b(&.escape_two) + :.escape_slash + %li(t0, 92) + %b(&.escape_two) + :.escape_quote + %li(t0, 34) + :.escape_two + %stl(t0, byte) + %ldl(a0, bv) + %li(a1, 92) + %call(&str_putc) + %ldl(a0, bv) + %ldl(a1, byte) + %call(&str_putc) + %b(&.advance) + + :.escape_hex + %ldl(a0, bv) + %li(a1, 92) + %call(&str_putc) + %ldl(a0, bv) + %li(a1, 120) ; 'x' + %call(&str_putc) + %ldl(t0, byte) + %shri(a0, t0, 4) + %call(&hex_digit_ascii) + %mov(a1, a0) + %ldl(a0, bv) + %call(&str_putc) + %ldl(t0, byte) + %andi(a0, t0, 15) + %call(&hex_digit_ascii) + %mov(a1, a0) + %ldl(a0, bv) + %call(&str_putc) + %ldl(a0, bv) + %li(a1, 59) ; ';' + %call(&str_putc) + + :.advance + %ldl(t0, index) + %addi(t0, t0, 1) + %stl(t0, index) + %b(&.loop) + + :.close + %ldl(a0, bv) + %li(a1, 34) + %gctail(&str_putc) + + :.raw + %ldl(t0, string) + %heap_ld(a1, t0, %BV.data) + %ldl(a2, length) + %ldl(a0, bv) + %gctail(&str_putn) +}) + +# write_bytevector_to_bv(bytes=a0, bv=a1, mode=a2) -> bv. Display mode +# retains boot2's raw-byte diagnostic convention; write mode uses #u8(...). +%gcfn2(write_bytevector_to_bv, {bytes bv index length}, 3, 0, { + %stl(a0, bytes) + %stl(a1, bv) + %heap_ld(t0, a0, %BV.hdr) + %shri(t0, t0, 8) + %stl(t0, length) + %beqz(a2, &.raw) + + %ldl(a0, bv) + %la(a1, &str_u8_open) + %li(a2, 4) + %call(&str_putn) + %li(t0, 0) + %stl(t0, index) + :.loop + %ldl(t0, index) + %ldl(t1, length) + %beq(t0, t1, &.close) + %beqz(t0, &.value) + %ldl(a0, bv) + %li(a1, 32) + %call(&str_putc) + :.value + %ldl(t0, bytes) + %heap_ld(t1, t0, %BV.data) + %ldl(t0, index) + %add(t1, t1, t0) + %lb(a1, t1, 0) + %ldl(a0, bv) + %call(&str_putint) + %ldl(t0, index) + %addi(t0, t0, 1) + %stl(t0, index) + %b(&.loop) + :.close + %ldl(a0, bv) + %li(a1, 41) + %gctail(&str_putc) + + :.raw + %ldl(t0, bytes) + %heap_ld(a1, t0, %BV.data) + %ldl(a2, length) + %ldl(a0, bv) + %gctail(&str_putn) +}) + +# write_char_to_bv(char=a0, bv=a1, mode=a2) -> bv. Display emits the +# character byte; write emits a micro character literal. +%gcfn2(write_char_to_bv, {bv value}, 1, 0, { + %stl(a1, bv) + %untag_char(t0, a0) + %stl(t0, value) + %beqz(a2, &.display) + + %ldl(a0, bv) + %la(a1, &str_char_open) + %li(a2, 2) + %call(&str_putn) + %ldl(t0, value) + %bieq(t0, 32, &.space, t1) + %bieq(t0, 10, &.newline, t1) + %bieq(t0, 9, &.tab, t1) + %bieq(t0, 13, &.return, t1) + %beqz(t0, &.null) + %li(t1, 32) + %bltu(t0, t1, &.hex) + %li(t1, 127) + %bltu(t0, t1, &.direct) + :.hex + %ldl(a0, bv) + %li(a1, 120) ; 'x' + %call(&str_putc) + %ldl(a0, bv) + %ldl(a1, value) + %gctail(&str_puthex) + :.direct + %ldl(a0, bv) + %mov(a1, t0) + %gctail(&str_putc) + :.space + %la(a1, &name_ch_space) + %li(a2, 5) + %b(&.named) + :.newline + %la(a1, &name_ch_newline) + %li(a2, 7) + %b(&.named) + :.tab + %la(a1, &name_ch_tab) + %li(a2, 3) + %b(&.named) + :.return + %la(a1, &name_ch_return) + %li(a2, 6) + %b(&.named) + :.null + %la(a1, &name_ch_null) + %li(a2, 4) + :.named + %ldl(a0, bv) + %gctail(&str_putn) + + :.display + %ldl(a0, bv) + %mov(a1, t0) + %gctail(&str_putc) +}) + # write_to_bv(val=a0, bv=a1, mode=a2) -> bv (a0). Recursively appends -# val's printed representation to bv. mode = 0 emits bytevectors as raw -# bytes (display); mode = 1 emits them as `"..."` (write). Pairs are -# delegated to write_pair_to_bv so the recursion through PAIR has its -# own frame. +# val's printed representation to bv. Strings and characters use their +# R7RS display/write spellings. Boot2 display keeps bytevectors raw for +# compiler diagnostics, while write emits #u8(...). Pairs are delegated +# to write_pair_to_bv so recursion through PAIR has its own frame. # # Output is treated as a string by callers (display / write / error / # format), so all internal append calls go through the str_* family -- @@ -5543,6 +6618,7 @@ %bieq(t0, %TAG.SYM, &.sym, t1) %bieq(t0, %TAG.HEAP, &.heap, t1) %bieq(t0, %TAG.IMM, &.imm, t1) + %bieq(t0, %TAG.CHAR, &.char, t1) # Fall-through: FIXNUM (the only remaining tag). %ldl(a0, bv) @@ -5565,9 +6641,16 @@ %ldl(a2, mode) %gctail(&write_pair_to_bv) + :.char + %ldl(a0, val) + %ldl(a1, bv) + %ldl(a2, mode) + %gctail(&write_char_to_bv) + :.heap %hdr_type(t0, a0) %bieq(t0, %HDR.BV, &.heap_bv, t1) + %bieq(t0, %HDR.STRING, &.heap_string, t1) %bieq(t0, %HDR.CLOSURE, &.heap_closure, t1) %bieq(t0, %HDR.PRIM, &.heap_prim, t1) %bieq(t0, %HDR.TD, &.heap_td, t1) @@ -5575,27 +6658,16 @@ %b(&.heap_unknown) :.heap_bv - %ldl(t0, mode) - %beqz(t0, &.heap_bv_raw) - # write mode: emit `"`, then the raw bytes, then `"`. - %ldl(a0, bv) - %li(a1, 34) - %call(&str_putc) - %ldl(t0, val) - %heap_ld(a1, t0, %BV.data) - %heap_ld(a2, t0, %BV.hdr) - %shri(a2, a2, 8) - %call(&str_putn) - %li(a1, 34) - %gctail(&str_putc) + %ldl(a0, val) + %ldl(a1, bv) + %ldl(a2, mode) + %gctail(&write_bytevector_to_bv) - :.heap_bv_raw - %ldl(t0, val) - %heap_ld(a1, t0, %BV.data) - %heap_ld(a2, t0, %BV.hdr) - %shri(a2, a2, 8) - %ldl(a0, bv) - %gctail(&str_putn) + :.heap_string + %ldl(a0, val) + %ldl(a1, bv) + %ldl(a2, mode) + %gctail(&write_string_to_bv) :.heap_closure %la(a1, &str_closure) @@ -6449,13 +7521,13 @@ %heap_ld(a0, t0, %TD.name) %ret -# Debug primitives. UNSAFE: peek-u8 dereferences arbitrary addresses. +# Debug primitives. UNSAFE: peek-memory-u8 dereferences arbitrary addresses. # Intended for diagnosing heap-layout bugs from scheme1 user code; not # part of the surface contract. # (tagged-value obj) -> fixnum. Returns the raw byte address of obj # with tag bits masked off, encoded as a tagged fixnum so format / -# display can print it. Pass the result back into peek-u8 to read raw +# display can print it. Pass the result back into peek-memory-u8 to read raw # bytes. For non-pointer values (fixnums, immediates, syms) the masked # value is small but still encodable; the result is meaningful only for # heap-tagged inputs. @@ -6466,10 +7538,10 @@ %mkfix(a0, t0) %ret -# (peek-u8 addr) -> fixnum. Reads one byte at the given raw byte +# (peek-memory-u8 addr) -> fixnum. Reads one byte at the given raw byte # address (tagged fixnum input, untagged inside). UNSAFE: no bounds # check; a wild address segfaults the process. -:prim_peek_u8_entry +:prim_peek_memory_u8_entry %car(t0, a0) %sari(t0, t0, 3) %lb(a0, t0, 0) @@ -6557,6 +7629,8 @@ :name_nullq %cstr8("null?") :name_pairq %cstr8("pair?") :name_stringq %cstr8("string?") +:name_bytevectorq %cstr8("bytevector?") +:name_bytesq %cstr8("bytes?") :name_set_car %cstr8("set-car!") :name_set_cdr %cstr8("set-cdr!") :name_length %cstr8("length") @@ -6571,6 +7645,9 @@ :name_bv_append %cstr8("bytevector-append") :name_booleanq %cstr8("boolean?") :name_integerq %cstr8("integer?") +:name_charq %cstr8("char?") +:name_char_to_integer %cstr8("char->integer") +:name_integer_to_char %cstr8("integer->char") :name_symbolq %cstr8("symbol?") :name_procedureq %cstr8("procedure?") :name_zeroq %cstr8("zero?") @@ -6592,13 +7669,17 @@ :name_arith_shift %cstr8("arithmetic-shift") :name_apply %cstr8("apply") :name_make_bv %cstr8("make-bytevector") +:name_make_string %cstr8("make-string") :name_bv_length %cstr8("bytevector-length") :name_string_length %cstr8("string-length") +:name_string_ref %cstr8("string-ref") +:name_string_set %cstr8("string-set!") :name_bv_u8_ref %cstr8("bytevector-u8-ref") :name_bv_u8_set %cstr8("bytevector-u8-set!") :name_bv_copy %cstr8("bytevector-copy") :name_bv_copy_b %cstr8("bytevector-copy!") :name_bv_eq %cstr8("bytevector=?") +:name_bytes_eq %cstr8("bytes=?") :name_sys_read %cstr8("sys-read") :name_sys_write %cstr8("sys-write") @@ -6627,7 +7708,7 @@ :name_td_nfields %cstr8("td-nfields") :name_td_name %cstr8("td-name") :name_tagged_value %cstr8("tagged-value") -:name_peek_u8 %cstr8("peek-u8") +:name_peek_memory_u8 %cstr8("peek-memory-u8") # Writer string constants. Lengths are hard-coded at the str_putn call # sites (write_to_bv branches). They are emitted through cstr8 so the @@ -6644,6 +7725,8 @@ :str_rec %cstr8("#<record>") :str_unknown %cstr8("#<unknown>") :str_error_prefix %cstr8("scheme1: error: ") +:str_u8_open %cstr8("#u8(") +:str_char_open %cstr8("#\\") # Primitive registration table. Each entry: 8-byte name_ptr (4-byte label # ref + 4 pad), 8-byte name_len, 8-byte entry_label (4 ref + 4 pad). @@ -6655,6 +7738,8 @@ &name_nullq %(0) $(5) &prim_nullq_entry %(0) &name_pairq %(0) $(5) &prim_pairq_entry %(0) &name_stringq %(0) $(7) &prim_stringq_entry %(0) +&name_bytevectorq %(0) $(11) &prim_bytevectorq_entry %(0) +&name_bytesq %(0) $(6) &prim_bytesq_entry %(0) &name_set_car %(0) $(8) &prim_set_car_entry %(0) &name_set_cdr %(0) $(8) &prim_set_cdr_entry %(0) &name_length %(0) $(6) &prim_length_entry %(0) @@ -6669,6 +7754,9 @@ &name_bv_append %(0) $(17) &prim_bv_append_entry %(0) &name_booleanq %(0) $(8) &prim_booleanq_entry %(0) &name_integerq %(0) $(8) &prim_integerq_entry %(0) +&name_charq %(0) $(5) &prim_charq_entry %(0) +&name_char_to_integer %(0) $(13) &prim_char_to_integer_entry %(0) +&name_integer_to_char %(0) $(13) &prim_integer_to_char_entry %(0) &name_symbolq %(0) $(7) &prim_symbolq_entry %(0) &name_procedureq %(0) $(10) &prim_procedureq_entry %(0) &name_zeroq %(0) $(5) &prim_zeroq_entry %(0) @@ -6690,13 +7778,17 @@ &name_arith_shift %(0) $(16) &prim_arith_shift_entry %(0) &name_apply %(0) $(5) &prim_apply_entry %(0) &name_make_bv %(0) $(15) &prim_make_bytevector_entry %(0) +&name_make_string %(0) $(11) &prim_make_string_entry %(0) &name_bv_length %(0) $(17) &prim_bv_length_entry %(0) &name_string_length %(0) $(13) &prim_string_length_entry %(0) +&name_string_ref %(0) $(10) &prim_string_ref_entry %(0) +&name_string_set %(0) $(11) &prim_string_set_entry %(0) &name_bv_u8_ref %(0) $(17) &prim_bv_u8_ref_entry %(0) &name_bv_u8_set %(0) $(18) &prim_bv_u8_set_entry %(0) &name_bv_copy %(0) $(15) &prim_bv_copy_entry %(0) &name_bv_copy_b %(0) $(16) &prim_bv_copy_bang_entry %(0) &name_bv_eq %(0) $(12) &prim_bytevector_eq_entry %(0) +&name_bytes_eq %(0) $(7) &prim_bytevector_eq_entry %(0) &name_sys_read %(0) $(8) &prim_sys_read_entry %(0) &name_sys_write %(0) $(9) &prim_sys_write_entry %(0) &name_sys_close %(0) $(9) &prim_sys_close_entry %(0) @@ -6721,7 +7813,7 @@ &name_td_nfields %(0) $(10) &prim_td_nfields_entry %(0) &name_td_name %(0) $(7) &prim_td_name_entry %(0) &name_tagged_value %(0) $(12) &prim_tagged_value_entry %(0) -&name_peek_u8 %(0) $(7) &prim_peek_u8_entry %(0) +&name_peek_memory_u8 %(0) $(14) &prim_peek_memory_u8_entry %(0) &name_values %(0) $(6) &prim_values_entry %(0) &name_call_with_values %(0) $(16) &prim_call_with_values_entry %(0) :prim_table_end @@ -6737,18 +7829,30 @@ :msg_unexp_eof %cstr8("scheme1: unexpected EOF in form\n") :msg_unterm_list %cstr8("scheme1: unterminated list\n") :msg_unbound %cstr8("scheme1: unbound variable\n") +:msg_unbound_set %cstr8("scheme1: set!: unbound variable\n") :msg_not_proc %cstr8("scheme1: not a procedure\n") +:msg_type %cstr8("scheme1: type error\n") +:msg_arity %cstr8("scheme1: wrong number of arguments\n") :msg_heap_full %cstr8("scheme1: heap exhausted\n") :msg_heap_corrupt %cstr8("scheme1: corrupt managed heap\n") :msg_gc_roots_full %cstr8("scheme1: shadow root stack overflow\n") :msg_readbuf_full %cstr8("scheme1: source buffer overflow\n") :msg_bv_oob %cstr8("scheme1: bytevector index out of range\n") +:msg_string_oob %cstr8("scheme1: string index out of range\n") +:msg_bad_byte %cstr8("scheme1: byte value out of range\n") :msg_unterm_string %cstr8("scheme1: unterminated string literal\n") :msg_bad_escape %cstr8("scheme1: bad string escape\n") :msg_bad_char %cstr8("scheme1: bad #\\ character literal\n") :msg_bad_number %cstr8("scheme1: bad number literal\n") +:msg_bad_radix %cstr8("scheme1: unsupported radix\n") +:msg_integer_overflow %cstr8("scheme1: exact integer overflow\n") +:msg_divide_zero %cstr8("scheme1: division by zero\n") :msg_bad_ident %cstr8("scheme1: bad identifier\n") +:msg_unsupported_syntax %cstr8("scheme1: unsupported reader syntax\n") :msg_internal_define %cstr8("scheme1: internal define is not supported\n") +:msg_cond_else_not_final %cstr8("scheme1: cond: else clause is not final\n") +:msg_record_ctor_spec %cstr8("scheme1: unsupported record constructor specification\n") +:msg_record_ctor_arity %cstr8("scheme1: record constructor arity mismatch\n") :msg_pmatch_no_match %cstr8("scheme1: pmatch: no clause matched\n") :msg_bad_unquote_pattern %cstr8("scheme1: pmatch: malformed ,-pattern\n") diff --git a/tests/cc-cg/009-call.scm b/tests/cc-cg/009-call.scm @@ -7,7 +7,7 @@ (let* ((cg (cg-init)) (triple-fnty (%ctype 'fn 8 8 (cons %t-i32 (cons (list %t-i32) #f)))) - (triple-sym (%sym "triple" 'fn 'extern triple-fnty #f))) + (triple-sym (%sym "triple" 'fn 'extern triple-fnty #f #t))) ;; int triple(int x) { return x + x + x; } (let* ((params (cg-fn-begin cg "triple" (list (cons "x" %t-i32)) diff --git a/tests/cc-cg/010-string.scm b/tests/cc-cg/010-string.scm @@ -12,9 +12,9 @@ (let* ((p-off (cg-alloc-slot cg 8 8)) (q-off (cg-alloc-slot cg 8 8)) (r-off (cg-alloc-slot cg 8 8)) - (p (%sym "p" 'var 'auto cp-ty p-off)) - (q (%sym "q" 'var 'auto cp-ty q-off)) - (r (%sym "r" 'var 'auto cp-ty r-off))) + (p (%sym "p" 'var 'auto cp-ty p-off #t)) + (q (%sym "q" 'var 'auto cp-ty q-off #t)) + (r (%sym "r" 'var 'auto cp-ty r-off #t))) ;; p = "hello" (cg-push-sym cg p) (cg-push-string cg "hello") (cg-assign cg) (cg-pop cg) diff --git a/tests/cc-cg/011-global-var.scm b/tests/cc-cg/011-global-var.scm @@ -2,7 +2,7 @@ ;; then a function that reads it. (let* ((cg (cg-init)) - (g (%sym "g" 'var 'static %t-i32 #f))) + (g (%sym "g" 'var 'static %t-i32 #f #t))) (cg-emit-global cg g #f) (cg-fn-begin cg "main" '() %t-i32) (cg-push-sym cg g) diff --git a/tests/cc-cg/013-call-5args.scm b/tests/cc-cg/013-call-5args.scm @@ -10,7 +10,7 @@ (sum5-fnty (%ctype 'fn 8 8 (cons %t-i32 (cons (list %t-i32 %t-i32 %t-i32 %t-i32 %t-i32) #f)))) - (sum5-sym (%sym "sum5" 'fn 'extern sum5-fnty #f))) + (sum5-sym (%sym "sum5" 'fn 'extern sum5-fnty #f #t))) (let* ((params (cg-fn-begin cg "sum5" (list (cons "a" %t-i32) (cons "b" %t-i32) (cons "c" %t-i32) (cons "d" %t-i32) diff --git a/tests/cc-cg/015-char-roundtrip.scm b/tests/cc-cg/015-char-roundtrip.scm @@ -16,8 +16,8 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 1 1)) (off-b (cg-alloc-slot cg 1 1)) - (sym-a (%sym "a" 'var 'auto %t-u8 off-a)) - (sym-b (%sym "b" 'var 'auto %t-u8 off-b))) + (sym-a (%sym "a" 'var 'auto %t-u8 off-a #t)) + (sym-b (%sym "b" 'var 'auto %t-u8 off-b #t))) ;; a = 0xAA (cg-push-sym cg sym-a) (cg-push-imm cg %t-u8 170) diff --git a/tests/cc-cg/016-short-roundtrip.scm b/tests/cc-cg/016-short-roundtrip.scm @@ -16,8 +16,8 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 2 2)) (off-b (cg-alloc-slot cg 2 2)) - (sym-a (%sym "a" 'var 'auto %t-u16 off-a)) - (sym-b (%sym "b" 'var 'auto %t-u16 off-b))) + (sym-a (%sym "a" 'var 'auto %t-u16 off-a #t)) + (sym-b (%sym "b" 'var 'auto %t-u16 off-b #t))) ;; a = 0xAABB (cg-push-sym cg sym-a) (cg-push-imm cg %t-u16 43707) diff --git a/tests/cc-cg/017-int-roundtrip.scm b/tests/cc-cg/017-int-roundtrip.scm @@ -15,8 +15,8 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 4 4)) (off-b (cg-alloc-slot cg 4 4)) - (sym-a (%sym "a" 'var 'auto %t-u32 off-a)) - (sym-b (%sym "b" 'var 'auto %t-u32 off-b))) + (sym-a (%sym "a" 'var 'auto %t-u32 off-a #t)) + (sym-b (%sym "b" 'var 'auto %t-u32 off-b #t))) ;; a = 0xAABBCCDD (cg-push-sym cg sym-a) (cg-push-imm cg %t-u32 2864434397) diff --git a/tests/cc-cg/020-promote-sign.scm b/tests/cc-cg/020-promote-sign.scm @@ -12,7 +12,7 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 1 1)) - (sym-x (%sym "x" 'var 'auto %t-i8 off-x))) + (sym-x (%sym "x" 'var 'auto %t-i8 off-x #t))) ;; x = -1 (cg-push-sym cg sym-x) (cg-push-imm cg %t-i8 -1) diff --git a/tests/cc-cg/021-preinc.scm b/tests/cc-cg/021-preinc.scm @@ -9,7 +9,7 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x))) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t))) ;; x = 5 (cg-push-sym cg sym-x) (cg-push-imm cg %t-i32 5) diff --git a/tests/cc-cg/022-postinc.scm b/tests/cc-cg/022-postinc.scm @@ -10,8 +10,8 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 4 4)) (off-y (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x)) - (sym-y (%sym "y" 'var 'auto %t-i32 off-y))) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t)) + (sym-y (%sym "y" 'var 'auto %t-i32 off-y #t))) ;; x = 5 (cg-push-sym cg sym-x) (cg-push-imm cg %t-i32 5) diff --git a/tests/cc-cg/023-cmpd-simple.scm b/tests/cc-cg/023-cmpd-simple.scm @@ -5,7 +5,7 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x))) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t))) ;; x = 7 (cg-push-sym cg sym-x) (cg-push-imm cg %t-i32 7) diff --git a/tests/cc-cg/024-cmpd-ptr.scm b/tests/cc-cg/024-cmpd-ptr.scm @@ -5,10 +5,10 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x)) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t)) (off-p (cg-alloc-slot cg 8 8)) (ptr-i32 (%ctype 'ptr 8 8 %t-i32)) - (sym-p (%sym "p" 'var 'auto ptr-i32 off-p))) + (sym-p (%sym "p" 'var 'auto ptr-i32 off-p #t))) ;; x = 7 (cg-push-sym cg sym-x) (cg-push-imm cg %t-i32 7) diff --git a/tests/cc-cg/025-deref-postinc.scm b/tests/cc-cg/025-deref-postinc.scm @@ -16,12 +16,12 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((arr-i32 (%ctype 'arr 12 4 (cons %t-i32 3))) (off-a (cg-alloc-slot cg 12 4)) - (sym-a (%sym "a" 'var 'auto arr-i32 off-a)) + (sym-a (%sym "a" 'var 'auto arr-i32 off-a #t)) (off-p (cg-alloc-slot cg 8 8)) (ptr-i32 (%ctype 'ptr 8 8 %t-i32)) - (sym-p (%sym "p" 'var 'auto ptr-i32 off-p)) + (sym-p (%sym "p" 'var 'auto ptr-i32 off-p #t)) (off-s (cg-alloc-slot cg 4 4)) - (sym-s (%sym "s" 'var 'auto %t-i32 off-s))) + (sym-s (%sym "s" 'var 'auto %t-i32 off-s #t))) ;; a[i] = vals[i] — use &a (cast to ptr-i32) + i + push-deref (let store-elem ((i 0) (vals '(1 2 4))) (cond diff --git a/tests/cc-cg/028-ternary.scm b/tests/cc-cg/028-ternary.scm @@ -9,9 +9,9 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-c (cg-alloc-slot cg 4 4)) - (sym-c (%sym "c" 'var 'auto %t-i32 off-c)) + (sym-c (%sym "c" 'var 'auto %t-i32 off-c #t)) (off-x (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x))) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t))) ;; c = 1 (cg-push-sym cg sym-c) (cg-push-imm cg %t-i32 1) diff --git a/tests/cc-cg/029-land.scm b/tests/cc-cg/029-land.scm @@ -8,9 +8,9 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 4 4)) - (sym-a (%sym "a" 'var 'auto %t-i32 off-a)) + (sym-a (%sym "a" 'var 'auto %t-i32 off-a #t)) (off-b (cg-alloc-slot cg 4 4)) - (sym-b (%sym "b" 'var 'auto %t-i32 off-b))) + (sym-b (%sym "b" 'var 'auto %t-i32 off-b #t))) ;; a = 5; b = 0 (cg-push-sym cg sym-a) (cg-push-imm cg %t-i32 5) diff --git a/tests/cc-cg/030-lor.scm b/tests/cc-cg/030-lor.scm @@ -5,9 +5,9 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 4 4)) - (sym-a (%sym "a" 'var 'auto %t-i32 off-a)) + (sym-a (%sym "a" 'var 'auto %t-i32 off-a #t)) (off-b (cg-alloc-slot cg 4 4)) - (sym-b (%sym "b" 'var 'auto %t-i32 off-b))) + (sym-b (%sym "b" 'var 'auto %t-i32 off-b #t))) (cg-push-sym cg sym-a) (cg-push-imm cg %t-i32 0) (cg-assign cg) (cg-pop cg) diff --git a/tests/cc-cg/036-struct-load.scm b/tests/cc-cg/036-struct-load.scm @@ -18,7 +18,7 @@ (list "b" %t-i32 4)))))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-s (cg-alloc-slot cg 8 4)) - (sym-s (%sym "s" 'var 'auto st-ty off-s))) + (sym-s (%sym "s" 'var 'auto st-ty off-s #t))) ;; s.a = 5 (cg-push-sym cg sym-s) (cg-push-field cg "a") diff --git a/tests/cc-cg/037-struct-store.scm b/tests/cc-cg/037-struct-store.scm @@ -18,7 +18,7 @@ (list "c" %t-u8 2)))))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-b (cg-alloc-slot cg 3 1)) - (sym-b (%sym "b" 'var 'auto st-ty off-b))) + (sym-b (%sym "b" 'var 'auto st-ty off-b #t))) ;; b.a = 3 (cg-push-sym cg sym-b) (cg-push-field cg "a") diff --git a/tests/cc-cg/038-arrow.scm b/tests/cc-cg/038-arrow.scm @@ -21,8 +21,8 @@ (cg-fn-begin cg "main" '() %t-i32) (let* ((off-s (cg-alloc-slot cg 8 4)) (off-p (cg-alloc-slot cg 8 8)) - (sym-s (%sym "s" 'var 'auto st-ty off-s)) - (sym-p (%sym "p" 'var 'auto pt-ty off-p))) + (sym-s (%sym "s" 'var 'auto st-ty off-s #t)) + (sym-p (%sym "p" 'var 'auto pt-ty off-p #t))) ;; p = &s (cg-push-sym cg sym-p) (cg-push-sym cg sym-s) diff --git a/tests/cc-cg/040-array-index.scm b/tests/cc-cg/040-array-index.scm @@ -17,7 +17,7 @@ (arr-ty (%ctype 'arr 12 4 (cons %t-i32 3)))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-a (cg-alloc-slot cg 12 4)) - (sym-a (%sym "a" 'var 'auto arr-ty off-a))) + (sym-a (%sym "a" 'var 'auto arr-ty off-a #t))) ;; a[0] = 1 (cg-push-sym cg sym-a) (cg-load cg) ; arr lval -> ptr rval (decay) diff --git a/tests/cc-cg/049-init-scalar-global.scm b/tests/cc-cg/049-init-scalar-global.scm @@ -5,7 +5,7 @@ ;; Runtime: exits 42. (let* ((cg (cg-init)) - (g (%sym "g" 'var 'static %t-i32 #f)) + (g (%sym "g" 'var 'static %t-i32 #f #t)) ;; structured init: a single 4-byte LE bytevector piece for 42. (bv4 (make-bytevector 4 0)) (_ (bytevector-u8-set! bv4 0 42)) diff --git a/tests/cc-cg/050-init-addr.scm b/tests/cc-cg/050-init-addr.scm @@ -9,11 +9,11 @@ (let* ((cg (cg-init)) ;; int x = 7 - (x (%sym "x" 'var 'static %t-i32 #f)) + (x (%sym "x" 'var 'static %t-i32 #f #t)) (bvx (make-bytevector 4 0)) (_x (bytevector-u8-set! bvx 0 7)) ;; int *p = &x -> structured init: a single label-ref to cc__x - (p (%sym "p" 'var 'static (%ctype 'ptr 8 8 %t-i32) #f))) + (p (%sym "p" 'var 'static (%ctype 'ptr 8 8 %t-i32) #f #t))) (cg-emit-global cg x (list bvx)) (cg-emit-global cg p (list (cons 'label-ref "cc__x"))) (cg-fn-begin cg "main" '() %t-i32) diff --git a/tests/cc-cg/051-init-array-list.scm b/tests/cc-cg/051-init-array-list.scm @@ -5,7 +5,7 @@ (let* ((cg (cg-init)) (elem %t-i32) (aty (%ctype 'arr 12 4 (cons elem 3))) - (a (%sym "a" 'var 'static aty #f)) + (a (%sym "a" 'var 'static aty #f #t)) ;; Three 4-byte LE pieces. (e1 (make-bytevector 4 0)) (_1 (bytevector-u8-set! e1 0 1)) (e2 (make-bytevector 4 0)) (_2 (bytevector-u8-set! e2 0 2)) diff --git a/tests/cc-cg/052-init-array-str.scm b/tests/cc-cg/052-init-array-str.scm @@ -7,7 +7,7 @@ (let* ((cg (cg-init)) (elem %t-i8) (aty (%ctype 'arr 4 1 (cons elem 4))) - (s (%sym "s" 'var 'static aty #f)) + (s (%sym "s" 'var 'static aty #f #t)) (bv (make-bytevector 4 0)) (_a (bytevector-u8-set! bv 0 97)) (_b (bytevector-u8-set! bv 1 98)) diff --git a/tests/cc-cg/053-init-struct-pos.scm b/tests/cc-cg/053-init-struct-pos.scm @@ -13,7 +13,7 @@ (list "S" #t (list (list "a" %t-i32 0) (list "b" %t-i32 4))))) - (s (%sym "s" 'var 'static sty #f)) + (s (%sym "s" 'var 'static sty #f #t)) ;; Init: 3 (4 bytes LE) | 4 (4 bytes LE) (bvA (make-bytevector 4 0)) (_a (bytevector-u8-set! bvA 0 3)) (bvB (make-bytevector 4 0)) (_b (bytevector-u8-set! bvB 0 4))) diff --git a/tests/cc-cg/054-init-struct-desig.scm b/tests/cc-cg/054-init-struct-desig.scm @@ -10,7 +10,7 @@ (list "S" #t (list (list "a" %t-i32 0) (list "b" %t-i32 4))))) - (s (%sym "s" 'var 'static sty #f)) + (s (%sym "s" 'var 'static sty #f #t)) ;; Designated init: zero pad for a, then 7 for b. (pad (make-bytevector 4 0)) (bvB (make-bytevector 4 0)) (_b (bytevector-u8-set! bvB 0 7))) diff --git a/tests/cc-cg/057-block-static.scm b/tests/cc-cg/057-block-static.scm @@ -10,10 +10,11 @@ ;; pre-mangled cc__incr__n directly via the cg API. (let* ((cg (cg-init)) - (n (%sym "n" 'var 'static %t-i32 (string->symbol "cc__incr__n")))) + (n (%sym "n" 'var 'static %t-i32 + (string->symbol "cc__incr__n") #t))) ;; cg-emit-global expects the slot to be a bv (the emitted label name). ;; Build n with a string slot directly. - (let* ((nsym (%sym "n" 'var 'static %t-i32 #f)) + (let* ((nsym (%sym "n" 'var 'static %t-i32 #f #t)) (zero (make-bytevector 4 0))) ;; n is sym-named "n"; cg-mangle-global prefixes with "cc__" → "cc__n". ;; That collides if multiple fns name `n`; the parser side adds the @@ -36,7 +37,7 @@ (cg-fn-begin cg "main" '() %t-i32) (let ((incr-sym (%sym "incr" 'fn 'extern (%ctype 'fn -1 -1 (list %t-i32 '() #f)) - "cc__incr"))) + "cc__incr" #t))) (cg-push-sym cg incr-sym) (cg-call cg 0 #t) (cg-pop cg) (cg-push-sym cg incr-sym) (cg-call cg 0 #t) (cg-pop cg) (cg-push-sym cg incr-sym) (cg-call cg 0 #t) diff --git a/tests/cc-cg/058-fnptr-tab.scm b/tests/cc-cg/058-fnptr-tab.scm @@ -25,7 +25,7 @@ (cg-fn-end cg) ;; tab[2] = { &f1, &f2 } — two label-ref pieces. (let* ((aty (%ctype 'arr 16 8 (cons fnptr 2))) - (tab (%sym "tab" 'var 'static aty #f))) + (tab (%sym "tab" 'var 'static aty #f #t))) (cg-emit-global cg tab (list (cons 'label-ref "f1") (cons 'label-ref "f2"))) ;; int main(void) { return tab[0]() + tab[1]() * 10; } diff --git a/tests/cc-cg/063-do-while.scm b/tests/cc-cg/063-do-while.scm @@ -6,7 +6,7 @@ (let* ((cg (cg-init)) (params (cg-fn-begin cg "main" '() %t-i32)) (x-slot (cg-alloc-slot cg 4 4)) - (x-sym (%sym "x" 'var 'auto %t-i32 x-slot))) + (x-sym (%sym "x" 'var 'auto %t-i32 x-slot #t))) ;; x = 0 (cg-push-sym cg x-sym) (cg-push-imm cg %t-i32 0) diff --git a/tests/cc-cg/064-switch.scm b/tests/cc-cg/064-switch.scm @@ -26,8 +26,8 @@ (params (cg-fn-begin cg "main" '() %t-i32)) (x-sl (cg-alloc-slot cg 4 4)) (s-sl (cg-alloc-slot cg 4 4)) - (x-sym (%sym "x" 'var 'auto %t-i32 x-sl)) - (s-sym (%sym "s" 'var 'auto %t-i32 s-sl))) + (x-sym (%sym "x" 'var 'auto %t-i32 x-sl #t)) + (s-sym (%sym "s" 'var 'auto %t-i32 s-sl #t))) ;; x = 2; s = 0; (cg-push-sym cg x-sym) (cg-push-imm cg %t-i32 2) (cg-assign cg) (cg-pop cg) diff --git a/tests/cc-cg/065-goto.scm b/tests/cc-cg/065-goto.scm @@ -19,8 +19,8 @@ (params (cg-fn-begin cg "main" '() %t-i32)) (s-sl (cg-alloc-slot cg 4 4)) (i-sl (cg-alloc-slot cg 4 4)) - (s-sym (%sym "s" 'var 'auto %t-i32 s-sl)) - (i-sym (%sym "i" 'var 'auto %t-i32 i-sl))) + (s-sym (%sym "s" 'var 'auto %t-i32 s-sl #t)) + (i-sym (%sym "i" 'var 'auto %t-i32 i-sl #t))) ;; s = 0; i = 0; (cg-push-sym cg s-sym) (cg-push-imm cg %t-i32 0) (cg-assign cg) (cg-pop cg) diff --git a/tests/cc-cg/066-vararg-call.scm b/tests/cc-cg/066-vararg-call.scm @@ -17,7 +17,7 @@ (let* ((cg (cg-init)) (sumv-fnty (%ctype 'fn 8 8 (cons %t-i32 (cons (list %t-i32) #t)))) - (sumv-sym (%sym "sum_var" 'fn 'extern sumv-fnty #f))) + (sumv-sym (%sym "sum_var" 'fn 'extern sumv-fnty #f #t))) ;; int sum_var(int n, int a, int b) { return n + a + b; } ;; (Modeling 3 fixed params; the callee doesn't care about variadic ;; ABI in this fixture — see §G.2 for that.) @@ -38,8 +38,8 @@ (let* ((params (cg-fn-begin cg "main" '() %t-i32)) (c-sl (cg-alloc-slot cg 1 1)) (s-sl (cg-alloc-slot cg 2 2)) - (c-sym (%sym "c" 'var 'auto %t-i8 c-sl)) - (s-sym (%sym "s" 'var 'auto %t-i16 s-sl))) + (c-sym (%sym "c" 'var 'auto %t-i8 c-sl #t)) + (s-sym (%sym "s" 'var 'auto %t-i16 s-sl #t))) ;; c = 5; (cg-push-sym cg c-sym) (cg-push-imm cg %t-i32 5) (cg-assign cg) (cg-pop cg) diff --git a/tests/cc-cg/067-fnptr-call.scm b/tests/cc-cg/067-fnptr-call.scm @@ -10,7 +10,7 @@ (let* ((cg (cg-init)) (triple-fnty (%ctype 'fn 8 8 (cons %t-i32 (cons (list %t-i32) #f)))) - (triple-sym (%sym "triple" 'fn 'extern triple-fnty #f))) + (triple-sym (%sym "triple" 'fn 'extern triple-fnty #f #t))) ;; int triple(int x) { return x + x + x; } (let* ((params (cg-fn-begin cg "triple" (list (cons "x" %t-i32)) @@ -25,7 +25,7 @@ (let* ((params (cg-fn-begin cg "main" '() %t-i32)) (fp-ty (%ctype 'ptr 8 8 triple-fnty)) (fp-sl (cg-alloc-slot cg 8 8)) - (fp-sym (%sym "fp" 'var 'auto fp-ty fp-sl))) + (fp-sym (%sym "fp" 'var 'auto fp-ty fp-sl #t))) ;; fp = triple (address of fn into the slot) (cg-push-sym cg fp-sym) (cg-push-sym cg triple-sym) diff --git a/tests/cc-cg/068-ptr-cmp.scm b/tests/cc-cg/068-ptr-cmp.scm @@ -15,8 +15,8 @@ (params (cg-fn-begin cg "main" '() %t-i32)) (x-sl (cg-alloc-slot cg 4 4)) (y-sl (cg-alloc-slot cg 4 4)) - (x-sym (%sym "x" 'var 'auto %t-i32 x-sl)) - (y-sym (%sym "y" 'var 'auto %t-i32 y-sl))) + (x-sym (%sym "x" 'var 'auto %t-i32 x-sl #t)) + (y-sym (%sym "y" 'var 'auto %t-i32 y-sl #t))) ;; (a < b) || (b < a) — without short-circuit. Take addresses ;; explicitly and feed cg-binop 'lt twice. (cg-push-sym cg x-sym) (cg-take-addr cg) diff --git a/tests/cc-cg/069-vararg-recv.scm b/tests/cc-cg/069-vararg-recv.scm @@ -17,7 +17,7 @@ (let* ((cg (cg-init)) (sum-fnty (%ctype 'fn 8 8 (cons %t-i32 (cons (list %t-i32) #t)))) - (sum-sym (%sym "sum" 'fn 'extern sum-fnty #f))) + (sum-sym (%sym "sum" 'fn 'extern sum-fnty #f #t))) ;; int sum(int n, ...) (let* ((params (cg-fn-begin/v cg "sum" (list (cons "n" %t-i32)) @@ -26,11 +26,11 @@ (n* (cdr (car params))) (ap-ty (%ctype 'ptr 8 8 %t-i8)) ; va_list = char* (just a pointer) (ap-sl (cg-alloc-slot cg 8 8)) - (ap-sym (%sym "ap" 'var 'auto ap-ty ap-sl)) + (ap-sym (%sym "ap" 'var 'auto ap-ty ap-sl #t)) (tot-sl (cg-alloc-slot cg 4 4)) - (tot-sym (%sym "total" 'var 'auto %t-i32 tot-sl)) + (tot-sym (%sym "total" 'var 'auto %t-i32 tot-sl #t)) (i-sl (cg-alloc-slot cg 4 4)) - (i-sym (%sym "i" 'var 'auto %t-i32 i-sl))) + (i-sym (%sym "i" 'var 'auto %t-i32 i-sl #t))) ;; va_start(ap) (cg-push-sym cg ap-sym) (cg-va-start cg) diff --git a/tests/cc-cg/070-struct-ret-1word.scm b/tests/cc-cg/070-struct-ret-1word.scm @@ -21,7 +21,7 @@ (list "b" %t-i32 4))))) (fn-ty (%ctype 'fn 8 8 (cons st-ty (cons (list %t-i32 %t-i32) #f)))) - (make-sym (%sym "make" 'fn 'extern fn-ty #f))) + (make-sym (%sym "make" 'fn 'extern fn-ty #f #t))) ;; struct S make(int a, int b) { ... return s; } (let* ((params (cg-fn-begin cg "make" (list (cons "a" %t-i32) (cons "b" %t-i32)) @@ -29,7 +29,7 @@ (a* (cdr (car params))) (b* (cdr (cadr params))) (s-off (cg-alloc-slot cg 8 4)) - (s-sym (%sym "s" 'var 'auto st-ty s-off))) + (s-sym (%sym "s" 'var 'auto st-ty s-off #t))) ;; s.a = a (cg-push-sym cg s-sym) (cg-push-field cg "a") (cg-push-sym cg a*) (cg-load cg) diff --git a/tests/cc-cg/071-struct-ret-2word.scm b/tests/cc-cg/071-struct-ret-2word.scm @@ -22,7 +22,7 @@ (list "b" %t-i64 8))))) (fn-ty (%ctype 'fn 8 8 (cons pair-ty (cons (list %t-i64 %t-i64) #f)))) - (pair-sym (%sym "pair" 'fn 'extern fn-ty #f))) + (pair-sym (%sym "pair" 'fn 'extern fn-ty #f #t))) ;; struct P pair(long a, long b) { ... return p; } (let* ((params (cg-fn-begin cg "pair" (list (cons "a" %t-i64) (cons "b" %t-i64)) @@ -30,7 +30,7 @@ (a* (cdr (car params))) (b* (cdr (cadr params))) (p-off (cg-alloc-slot cg 16 8)) - (p-sym (%sym "p" 'var 'auto pair-ty p-off))) + (p-sym (%sym "p" 'var 'auto pair-ty p-off #t))) ;; p.a = a (cg-push-sym cg p-sym) (cg-push-field cg "a") (cg-push-sym cg a*) (cg-load cg) diff --git a/tests/cc-cg/072-cg-snapshot-rewind.scm b/tests/cc-cg/072-cg-snapshot-rewind.scm @@ -24,7 +24,7 @@ (let ((cg (cg-init))) (cg-fn-begin cg "main" '() %t-i32) (let* ((off-x (cg-alloc-slot cg 4 4)) - (sym-x (%sym "x" 'var 'auto %t-i32 off-x))) + (sym-x (%sym "x" 'var 'auto %t-i32 off-x #t))) ;; x = 5 (committed) (cg-push-sym cg sym-x) (cg-push-imm cg %t-i32 5) diff --git a/tests/cc-cg/073-struct-ret-3word.scm b/tests/cc-cg/073-struct-ret-3word.scm @@ -17,7 +17,7 @@ (list "c" %t-i64 16))))) (fty (%ctype 'fn 8 8 (cons ty (cons (list %t-i64 %t-i64 %t-i64) #f)))) - (mk (%sym "make" 'fn 'extern fty #f))) + (mk (%sym "make" 'fn 'extern fty #f #t))) (let* ((ps (cg-fn-begin cg "make" (list (cons "a" %t-i64) (cons "b" %t-i64) @@ -25,7 +25,7 @@ ty)) (a* (cdr (car ps))) (b* (cdr (cadr ps))) (c* (cdr (caddr ps))) (to (cg-alloc-slot cg 24 8)) - (ts (%sym "t" 'var 'auto ty to))) + (ts (%sym "t" 'var 'auto ty to #t))) (cg-push-sym cg ts) (cg-push-field cg "a") (cg-push-sym cg a*) (cg-load cg) (cg-assign cg) (cg-pop cg) (cg-push-sym cg ts) (cg-push-field cg "b") diff --git a/tests/cc-lex/000-empty.expected b/tests/cc-lex/000-empty.expected @@ -1 +1 @@ -(EOF #f "00-empty.c" 1 1) +(EOF #f "000-empty.c" 1 1) diff --git a/tests/cc-lex/001-keywords.expected b/tests/cc-lex/001-keywords.expected @@ -1,12 +1,12 @@ -(KW int "01-keywords.c" 1 1) -(IDENT "main" "01-keywords.c" 1 5) -(PUNCT lparen "01-keywords.c" 1 9) -(KW void "01-keywords.c" 1 10) -(PUNCT rparen "01-keywords.c" 1 14) -(PUNCT lbrace "01-keywords.c" 1 16) -(KW return "01-keywords.c" 1 18) -(INT 0 "01-keywords.c" 1 25) -(PUNCT semi "01-keywords.c" 1 26) -(PUNCT rbrace "01-keywords.c" 1 28) -(NL #f "01-keywords.c" 1 29) -(EOF #f "01-keywords.c" 2 1) +(KW int "001-keywords.c" 1 1) +(IDENT "main" "001-keywords.c" 1 5) +(PUNCT lparen "001-keywords.c" 1 9) +(KW void "001-keywords.c" 1 10) +(PUNCT rparen "001-keywords.c" 1 14) +(PUNCT lbrace "001-keywords.c" 1 16) +(KW return "001-keywords.c" 1 18) +(INT 0 "001-keywords.c" 1 25) +(PUNCT semi "001-keywords.c" 1 26) +(PUNCT rbrace "001-keywords.c" 1 28) +(NL #f "001-keywords.c" 1 29) +(EOF #f "001-keywords.c" 2 1) diff --git a/tests/cc-lex/002-integers.expected b/tests/cc-lex/002-integers.expected @@ -1,11 +1,11 @@ -(INT 42 "02-integers.c" 1 1) -(INT 0 "02-integers.c" 1 4) -(INT 7 "02-integers.c" 1 6) -(INT 100 "02-integers.c" 1 8) -(INT 0 "02-integers.c" 1 13) -(INT 255 "02-integers.c" 1 16) -(INT 255 "02-integers.c" 1 21) -(INT 493 "02-integers.c" 1 26) -(INT 1 "02-integers.c" 1 31) -(NL #f "02-integers.c" 1 35) -(EOF #f "02-integers.c" 2 1) +(INT 42 "002-integers.c" 1 1) +(INT 0 "002-integers.c" 1 4) +(INT 7 "002-integers.c" 1 6) +(INT 100 "002-integers.c" 1 8) +(INT 0 "002-integers.c" 1 13) +(INT 255 "002-integers.c" 1 16) +(INT 255 "002-integers.c" 1 21) +(INT 493 "002-integers.c" 1 26) +(INT 1 "002-integers.c" 1 31) +(NL #f "002-integers.c" 1 35) +(EOF #f "002-integers.c" 2 1) diff --git a/tests/cc-lex/003-strings.expected b/tests/cc-lex/003-strings.expected @@ -1,7 +1,7 @@ -(STR "hello" "03-strings.c" 1 1) -(STR "a\nb\tc" "03-strings.c" 1 9) -(STR "\\\"" "03-strings.c" 1 19) -(STR "AB" "03-strings.c" 1 26) -(STR "\x00end" "03-strings.c" 1 37) -(NL #f "03-strings.c" 1 44) -(EOF #f "03-strings.c" 2 1) +(STR "hello" "003-strings.c" 1 1) +(STR "a\nb\tc" "003-strings.c" 1 9) +(STR "\\\"" "003-strings.c" 1 19) +(STR "AB" "003-strings.c" 1 26) +(STR "\x00end" "003-strings.c" 1 37) +(NL #f "003-strings.c" 1 44) +(EOF #f "003-strings.c" 2 1) diff --git a/tests/cc-lex/004-chars.expected b/tests/cc-lex/004-chars.expected @@ -1,10 +1,10 @@ -(CHAR 97 "04-chars.c" 1 1) -(CHAR 10 "04-chars.c" 1 5) -(CHAR 9 "04-chars.c" 1 10) -(CHAR 92 "04-chars.c" 1 15) -(CHAR 39 "04-chars.c" 1 20) -(CHAR 65 "04-chars.c" 1 25) -(CHAR 0 "04-chars.c" 1 32) -(CHAR 63 "04-chars.c" 1 37) -(NL #f "04-chars.c" 1 43) -(EOF #f "04-chars.c" 2 1) +(CHAR 97 "004-chars.c" 1 1) +(CHAR 10 "004-chars.c" 1 5) +(CHAR 9 "004-chars.c" 1 10) +(CHAR 92 "004-chars.c" 1 15) +(CHAR 39 "004-chars.c" 1 20) +(CHAR 65 "004-chars.c" 1 25) +(CHAR 0 "004-chars.c" 1 32) +(CHAR 63 "004-chars.c" 1 37) +(NL #f "004-chars.c" 1 43) +(EOF #f "004-chars.c" 2 1) diff --git a/tests/cc-lex/005-comments.expected b/tests/cc-lex/005-comments.expected @@ -1,13 +1,13 @@ -(KW int "05-comments.c" 1 1) -(IDENT "x" "05-comments.c" 1 5) -(PUNCT semi "05-comments.c" 1 6) -(NL #f "05-comments.c" 1 23) -(KW int "05-comments.c" 2 1) -(IDENT "y" "05-comments.c" 2 17) -(PUNCT semi "05-comments.c" 2 18) -(NL #f "05-comments.c" 2 19) -(KW int "05-comments.c" 4 12) -(IDENT "z" "05-comments.c" 4 16) -(PUNCT semi "05-comments.c" 4 17) -(NL #f "05-comments.c" 4 18) -(EOF #f "05-comments.c" 5 1) +(KW int "005-comments.c" 1 1) +(IDENT "x" "005-comments.c" 1 5) +(PUNCT semi "005-comments.c" 1 6) +(NL #f "005-comments.c" 1 23) +(KW int "005-comments.c" 2 1) +(IDENT "y" "005-comments.c" 2 17) +(PUNCT semi "005-comments.c" 2 18) +(NL #f "005-comments.c" 2 19) +(KW int "005-comments.c" 4 12) +(IDENT "z" "005-comments.c" 4 16) +(PUNCT semi "005-comments.c" 4 17) +(NL #f "005-comments.c" 4 18) +(EOF #f "005-comments.c" 5 1) diff --git a/tests/cc-lex/006-line-splice.expected b/tests/cc-lex/006-line-splice.expected @@ -1,7 +1,7 @@ -(KW int "06-line-splice.c" 1 1) -(IDENT "abcd" "06-line-splice.c" 1 5) -(PUNCT assign "06-line-splice.c" 2 4) -(INT 1 "06-line-splice.c" 2 6) -(PUNCT semi "06-line-splice.c" 2 7) -(NL #f "06-line-splice.c" 2 8) -(EOF #f "06-line-splice.c" 3 1) +(KW int "006-line-splice.c" 1 1) +(IDENT "abcd" "006-line-splice.c" 1 5) +(PUNCT assign "006-line-splice.c" 2 4) +(INT 1 "006-line-splice.c" 2 6) +(PUNCT semi "006-line-splice.c" 2 7) +(NL #f "006-line-splice.c" 2 8) +(EOF #f "006-line-splice.c" 3 1) diff --git a/tests/cc-lex/007-punctuators.expected b/tests/cc-lex/007-punctuators.expected @@ -1,52 +1,52 @@ -(PUNCT lbrack "07-punctuators.c" 1 1) -(PUNCT rbrack "07-punctuators.c" 1 2) -(PUNCT lparen "07-punctuators.c" 1 3) -(PUNCT rparen "07-punctuators.c" 1 4) -(PUNCT lbrace "07-punctuators.c" 1 5) -(PUNCT rbrace "07-punctuators.c" 1 6) -(PUNCT dot "07-punctuators.c" 1 7) -(PUNCT comma "07-punctuators.c" 1 8) -(PUNCT semi "07-punctuators.c" 1 9) -(PUNCT colon "07-punctuators.c" 1 10) -(PUNCT qmark "07-punctuators.c" 1 11) -(PUNCT ellipsis "07-punctuators.c" 1 12) -(PUNCT arrow "07-punctuators.c" 1 15) -(NL #f "07-punctuators.c" 1 17) -(PUNCT inc "07-punctuators.c" 2 1) -(PUNCT dec "07-punctuators.c" 2 4) -(PUNCT plus "07-punctuators.c" 2 7) -(PUNCT minus "07-punctuators.c" 2 9) -(PUNCT star "07-punctuators.c" 2 11) -(PUNCT slash "07-punctuators.c" 2 13) -(PUNCT pct "07-punctuators.c" 2 15) -(PUNCT amp "07-punctuators.c" 2 17) -(PUNCT bar "07-punctuators.c" 2 19) -(PUNCT caret "07-punctuators.c" 2 21) -(PUNCT tilde "07-punctuators.c" 2 23) -(PUNCT bang "07-punctuators.c" 2 25) -(PUNCT lt "07-punctuators.c" 2 27) -(PUNCT gt "07-punctuators.c" 2 29) -(PUNCT assign "07-punctuators.c" 2 31) -(PUNCT eq2 "07-punctuators.c" 2 33) -(PUNCT ne "07-punctuators.c" 2 36) -(PUNCT le "07-punctuators.c" 2 39) -(PUNCT ge "07-punctuators.c" 2 42) -(PUNCT land "07-punctuators.c" 2 45) -(PUNCT lor "07-punctuators.c" 2 48) -(PUNCT shl "07-punctuators.c" 2 51) -(PUNCT shr "07-punctuators.c" 2 54) -(PUNCT plus-eq "07-punctuators.c" 2 57) -(PUNCT minus-eq "07-punctuators.c" 2 60) -(PUNCT star-eq "07-punctuators.c" 2 63) -(PUNCT slash-eq "07-punctuators.c" 2 66) -(PUNCT pct-eq "07-punctuators.c" 2 69) -(PUNCT amp-eq "07-punctuators.c" 2 72) -(PUNCT bar-eq "07-punctuators.c" 2 75) -(PUNCT caret-eq "07-punctuators.c" 2 78) -(PUNCT shl-eq "07-punctuators.c" 2 81) -(PUNCT shr-eq "07-punctuators.c" 2 85) -(NL #f "07-punctuators.c" 2 88) -(HASH #f "07-punctuators.c" 3 1) -(PUNCT paste "07-punctuators.c" 3 3) -(NL #f "07-punctuators.c" 3 5) -(EOF #f "07-punctuators.c" 4 1) +(PUNCT lbrack "007-punctuators.c" 1 1) +(PUNCT rbrack "007-punctuators.c" 1 2) +(PUNCT lparen "007-punctuators.c" 1 3) +(PUNCT rparen "007-punctuators.c" 1 4) +(PUNCT lbrace "007-punctuators.c" 1 5) +(PUNCT rbrace "007-punctuators.c" 1 6) +(PUNCT dot "007-punctuators.c" 1 7) +(PUNCT comma "007-punctuators.c" 1 8) +(PUNCT semi "007-punctuators.c" 1 9) +(PUNCT colon "007-punctuators.c" 1 10) +(PUNCT qmark "007-punctuators.c" 1 11) +(PUNCT ellipsis "007-punctuators.c" 1 12) +(PUNCT arrow "007-punctuators.c" 1 15) +(NL #f "007-punctuators.c" 1 17) +(PUNCT inc "007-punctuators.c" 2 1) +(PUNCT dec "007-punctuators.c" 2 4) +(PUNCT plus "007-punctuators.c" 2 7) +(PUNCT minus "007-punctuators.c" 2 9) +(PUNCT star "007-punctuators.c" 2 11) +(PUNCT slash "007-punctuators.c" 2 13) +(PUNCT pct "007-punctuators.c" 2 15) +(PUNCT amp "007-punctuators.c" 2 17) +(PUNCT bar "007-punctuators.c" 2 19) +(PUNCT caret "007-punctuators.c" 2 21) +(PUNCT tilde "007-punctuators.c" 2 23) +(PUNCT bang "007-punctuators.c" 2 25) +(PUNCT lt "007-punctuators.c" 2 27) +(PUNCT gt "007-punctuators.c" 2 29) +(PUNCT assign "007-punctuators.c" 2 31) +(PUNCT eq2 "007-punctuators.c" 2 33) +(PUNCT ne "007-punctuators.c" 2 36) +(PUNCT le "007-punctuators.c" 2 39) +(PUNCT ge "007-punctuators.c" 2 42) +(PUNCT land "007-punctuators.c" 2 45) +(PUNCT lor "007-punctuators.c" 2 48) +(PUNCT shl "007-punctuators.c" 2 51) +(PUNCT shr "007-punctuators.c" 2 54) +(PUNCT plus-eq "007-punctuators.c" 2 57) +(PUNCT minus-eq "007-punctuators.c" 2 60) +(PUNCT star-eq "007-punctuators.c" 2 63) +(PUNCT slash-eq "007-punctuators.c" 2 66) +(PUNCT pct-eq "007-punctuators.c" 2 69) +(PUNCT amp-eq "007-punctuators.c" 2 72) +(PUNCT bar-eq "007-punctuators.c" 2 75) +(PUNCT caret-eq "007-punctuators.c" 2 78) +(PUNCT shl-eq "007-punctuators.c" 2 81) +(PUNCT shr-eq "007-punctuators.c" 2 85) +(NL #f "007-punctuators.c" 2 88) +(HASH #f "007-punctuators.c" 3 1) +(PUNCT paste "007-punctuators.c" 3 3) +(NL #f "007-punctuators.c" 3 5) +(EOF #f "007-punctuators.c" 4 1) diff --git a/tests/cc-lex/008-digraphs.expected b/tests/cc-lex/008-digraphs.expected @@ -1,16 +1,16 @@ -(KW int "08-digraphs.c" 1 1) -(IDENT "a" "08-digraphs.c" 1 5) -(PUNCT lbrack "08-digraphs.c" 1 6) -(INT 5 "08-digraphs.c" 1 8) -(PUNCT rbrack "08-digraphs.c" 1 9) -(PUNCT assign "08-digraphs.c" 1 12) -(PUNCT lbrace "08-digraphs.c" 1 14) -(INT 1 "08-digraphs.c" 1 16) -(PUNCT comma "08-digraphs.c" 1 17) -(INT 2 "08-digraphs.c" 1 19) -(PUNCT rbrace "08-digraphs.c" 1 20) -(PUNCT semi "08-digraphs.c" 1 22) -(PUNCT hash "08-digraphs.c" 1 24) -(PUNCT paste "08-digraphs.c" 1 27) -(NL #f "08-digraphs.c" 1 31) -(EOF #f "08-digraphs.c" 2 1) +(KW int "008-digraphs.c" 1 1) +(IDENT "a" "008-digraphs.c" 1 5) +(PUNCT lbrack "008-digraphs.c" 1 6) +(INT 5 "008-digraphs.c" 1 8) +(PUNCT rbrack "008-digraphs.c" 1 9) +(PUNCT assign "008-digraphs.c" 1 12) +(PUNCT lbrace "008-digraphs.c" 1 14) +(INT 1 "008-digraphs.c" 1 16) +(PUNCT comma "008-digraphs.c" 1 17) +(INT 2 "008-digraphs.c" 1 19) +(PUNCT rbrace "008-digraphs.c" 1 20) +(PUNCT semi "008-digraphs.c" 1 22) +(PUNCT hash "008-digraphs.c" 1 24) +(PUNCT paste "008-digraphs.c" 1 27) +(NL #f "008-digraphs.c" 1 31) +(EOF #f "008-digraphs.c" 2 1) diff --git a/tests/cc-lex/009-kw-vs-ident.expected b/tests/cc-lex/009-kw-vs-ident.expected @@ -1,10 +1,10 @@ -(KW if "09-kw-vs-ident.c" 1 1) -(IDENT "ifx" "09-kw-vs-ident.c" 1 4) -(KW int "09-kw-vs-ident.c" 1 8) -(IDENT "integer" "09-kw-vs-ident.c" 1 12) -(KW void "09-kw-vs-ident.c" 1 20) -(IDENT "voidp" "09-kw-vs-ident.c" 1 25) -(KW _Bool "09-kw-vs-ident.c" 1 31) -(IDENT "_BoolX" "09-kw-vs-ident.c" 1 37) -(NL #f "09-kw-vs-ident.c" 1 43) -(EOF #f "09-kw-vs-ident.c" 2 1) +(KW if "009-kw-vs-ident.c" 1 1) +(IDENT "ifx" "009-kw-vs-ident.c" 1 4) +(KW int "009-kw-vs-ident.c" 1 8) +(IDENT "integer" "009-kw-vs-ident.c" 1 12) +(KW void "009-kw-vs-ident.c" 1 20) +(IDENT "voidp" "009-kw-vs-ident.c" 1 25) +(KW _Bool "009-kw-vs-ident.c" 1 31) +(IDENT "_BoolX" "009-kw-vs-ident.c" 1 37) +(NL #f "009-kw-vs-ident.c" 1 43) +(EOF #f "009-kw-vs-ident.c" 2 1) diff --git a/tests/cc-lex/010-nl-tokens.expected b/tests/cc-lex/010-nl-tokens.expected @@ -1,6 +1,6 @@ -(IDENT "a" "10-nl-tokens.c" 1 1) -(NL #f "10-nl-tokens.c" 1 2) -(NL #f "10-nl-tokens.c" 2 1) -(IDENT "b" "10-nl-tokens.c" 3 1) -(NL #f "10-nl-tokens.c" 3 2) -(EOF #f "10-nl-tokens.c" 4 1) +(IDENT "a" "010-nl-tokens.c" 1 1) +(NL #f "010-nl-tokens.c" 1 2) +(NL #f "010-nl-tokens.c" 2 1) +(IDENT "b" "010-nl-tokens.c" 3 1) +(NL #f "010-nl-tokens.c" 3 2) +(EOF #f "010-nl-tokens.c" 4 1) diff --git a/tests/cc-lex/011-trigraphs.expected b/tests/cc-lex/011-trigraphs.expected @@ -1,8 +1,8 @@ -(HASH #f "11-trigraphs.c" 1 1) -(IDENT "define" "11-trigraphs.c" 1 4) -(IDENT "x" "11-trigraphs.c" 1 11) -(PUNCT lbrack "11-trigraphs.c" 1 13) -(INT 0 "11-trigraphs.c" 1 16) -(PUNCT rbrack "11-trigraphs.c" 1 17) -(NL #f "11-trigraphs.c" 1 20) -(EOF #f "11-trigraphs.c" 2 1) +(HASH #f "011-trigraphs.c" 1 1) +(IDENT "define" "011-trigraphs.c" 1 4) +(IDENT "x" "011-trigraphs.c" 1 11) +(PUNCT lbrack "011-trigraphs.c" 1 13) +(INT 0 "011-trigraphs.c" 1 16) +(PUNCT rbrack "011-trigraphs.c" 1 17) +(NL #f "011-trigraphs.c" 1 20) +(EOF #f "011-trigraphs.c" 2 1) diff --git a/tests/cc-lex/012-program.expected b/tests/cc-lex/012-program.expected @@ -1,20 +1,20 @@ -(KW int "12-program.c" 1 1) -(IDENT "main" "12-program.c" 1 5) -(PUNCT lparen "12-program.c" 1 9) -(KW int "12-program.c" 1 10) -(IDENT "argc" "12-program.c" 1 14) -(PUNCT comma "12-program.c" 1 18) -(KW char "12-program.c" 1 20) -(PUNCT star "12-program.c" 1 25) -(PUNCT star "12-program.c" 1 26) -(IDENT "argv" "12-program.c" 1 27) -(PUNCT rparen "12-program.c" 1 31) -(PUNCT lbrace "12-program.c" 1 33) -(NL #f "12-program.c" 1 34) -(KW return "12-program.c" 2 5) -(IDENT "argc" "12-program.c" 2 12) -(PUNCT semi "12-program.c" 2 16) -(NL #f "12-program.c" 2 17) -(PUNCT rbrace "12-program.c" 3 1) -(NL #f "12-program.c" 3 2) -(EOF #f "12-program.c" 4 1) +(KW int "012-program.c" 1 1) +(IDENT "main" "012-program.c" 1 5) +(PUNCT lparen "012-program.c" 1 9) +(KW int "012-program.c" 1 10) +(IDENT "argc" "012-program.c" 1 14) +(PUNCT comma "012-program.c" 1 18) +(KW char "012-program.c" 1 20) +(PUNCT star "012-program.c" 1 25) +(PUNCT star "012-program.c" 1 26) +(IDENT "argv" "012-program.c" 1 27) +(PUNCT rparen "012-program.c" 1 31) +(PUNCT lbrace "012-program.c" 1 33) +(NL #f "012-program.c" 1 34) +(KW return "012-program.c" 2 5) +(IDENT "argc" "012-program.c" 2 12) +(PUNCT semi "012-program.c" 2 16) +(NL #f "012-program.c" 2 17) +(PUNCT rbrace "012-program.c" 3 1) +(NL #f "012-program.c" 3 2) +(EOF #f "012-program.c" 4 1) diff --git a/tests/cc-lex/013-keywords-all.expected b/tests/cc-lex/013-keywords-all.expected @@ -1,33 +1,33 @@ -(KW auto "13-keywords-all.c" 1 1) -(KW register "13-keywords-all.c" 1 6) -(KW static "13-keywords-all.c" 1 15) -(KW extern "13-keywords-all.c" 1 22) -(KW typedef "13-keywords-all.c" 1 29) -(NL #f "13-keywords-all.c" 1 36) -(KW const "13-keywords-all.c" 2 1) -(KW volatile "13-keywords-all.c" 2 7) -(KW restrict "13-keywords-all.c" 2 16) -(KW inline "13-keywords-all.c" 2 25) -(NL #f "13-keywords-all.c" 2 31) -(KW short "13-keywords-all.c" 3 1) -(KW long "13-keywords-all.c" 3 7) -(KW signed "13-keywords-all.c" 3 12) -(KW unsigned "13-keywords-all.c" 3 19) -(NL #f "13-keywords-all.c" 3 27) -(KW struct "13-keywords-all.c" 4 1) -(KW union "13-keywords-all.c" 4 8) -(KW enum "13-keywords-all.c" 4 14) -(NL #f "13-keywords-all.c" 4 18) -(KW while "13-keywords-all.c" 5 1) -(KW do "13-keywords-all.c" 5 7) -(KW for "13-keywords-all.c" 5 10) -(KW switch "13-keywords-all.c" 5 14) -(KW case "13-keywords-all.c" 5 21) -(KW default "13-keywords-all.c" 5 26) -(KW break "13-keywords-all.c" 5 34) -(KW continue "13-keywords-all.c" 5 40) -(KW goto "13-keywords-all.c" 5 49) -(NL #f "13-keywords-all.c" 5 53) -(KW sizeof "13-keywords-all.c" 6 1) -(NL #f "13-keywords-all.c" 6 7) -(EOF #f "13-keywords-all.c" 7 1) +(KW auto "013-keywords-all.c" 1 1) +(KW register "013-keywords-all.c" 1 6) +(KW static "013-keywords-all.c" 1 15) +(KW extern "013-keywords-all.c" 1 22) +(KW typedef "013-keywords-all.c" 1 29) +(NL #f "013-keywords-all.c" 1 36) +(KW const "013-keywords-all.c" 2 1) +(KW volatile "013-keywords-all.c" 2 7) +(KW restrict "013-keywords-all.c" 2 16) +(KW inline "013-keywords-all.c" 2 25) +(NL #f "013-keywords-all.c" 2 31) +(KW short "013-keywords-all.c" 3 1) +(KW long "013-keywords-all.c" 3 7) +(KW signed "013-keywords-all.c" 3 12) +(KW unsigned "013-keywords-all.c" 3 19) +(NL #f "013-keywords-all.c" 3 27) +(KW struct "013-keywords-all.c" 4 1) +(KW union "013-keywords-all.c" 4 8) +(KW enum "013-keywords-all.c" 4 14) +(NL #f "013-keywords-all.c" 4 18) +(KW while "013-keywords-all.c" 5 1) +(KW do "013-keywords-all.c" 5 7) +(KW for "013-keywords-all.c" 5 10) +(KW switch "013-keywords-all.c" 5 14) +(KW case "013-keywords-all.c" 5 21) +(KW default "013-keywords-all.c" 5 26) +(KW break "013-keywords-all.c" 5 34) +(KW continue "013-keywords-all.c" 5 40) +(KW goto "013-keywords-all.c" 5 49) +(NL #f "013-keywords-all.c" 5 53) +(KW sizeof "013-keywords-all.c" 6 1) +(NL #f "013-keywords-all.c" 6 7) +(EOF #f "013-keywords-all.c" 7 1) diff --git a/tests/cc-lex/014-reject-float.expected b/tests/cc-lex/014-reject-float.expected @@ -1,4 +1,4 @@ ;; Negative test: lex must die on float literal "1.0". -;; Expected exit status: 1 (see 14-reject-float.expected-exit). +;; Expected exit status: 1 (see 014-reject-float.expected-exit). ;; Expected stderr prefix: -;; 14-reject-float.c:1:9: error: floating-point literal not supported +;; 014-reject-float.c:1:9: error: floating-point literal not supported diff --git a/tests/cc-lex/015-reject-multichar.expected b/tests/cc-lex/015-reject-multichar.expected @@ -1,4 +1,4 @@ ;; Negative test: lex must die on multi-character char constant 'AB'. -;; Expected exit status: 1 (see 15-reject-multichar.expected-exit). +;; Expected exit status: 1 (see 015-reject-multichar.expected-exit). ;; Expected stderr prefix: -;; 15-reject-multichar.c:1:9: error: multi-character char constant not supported +;; 015-reject-multichar.c:1:9: error: multi-character char constant not supported diff --git a/tests/cc-pp/000-noop.expected b/tests/cc-pp/000-noop.expected @@ -1,6 +1,6 @@ -(KW int "00-noop.c" 1 1) -(IDENT "x" "00-noop.c" 1 5) -(PUNCT assign "00-noop.c" 1 7) -(INT 0 "00-noop.c" 1 9) -(PUNCT semi "00-noop.c" 1 10) -(EOF #f "00-noop.c" 2 1) +(KW int "000-noop.c" 1 1) +(IDENT "x" "000-noop.c" 1 5) +(PUNCT assign "000-noop.c" 1 7) +(INT 0 "000-noop.c" 1 9) +(PUNCT semi "000-noop.c" 1 10) +(EOF #f "000-noop.c" 2 1) diff --git a/tests/cc-pp/001-obj-macro.expected b/tests/cc-pp/001-obj-macro.expected @@ -1,2 +1,2 @@ -(INT 42 "01-obj-macro.c" 1 11) -(EOF #f "01-obj-macro.c" 3 1) +(INT 42 "001-obj-macro.c" 1 11) +(EOF #f "001-obj-macro.c" 3 1) diff --git a/tests/cc-pp/002-obj-macro-multi-tok.expected b/tests/cc-pp/002-obj-macro-multi-tok.expected @@ -1,4 +1,4 @@ -(INT 1 "02-obj-macro-multi-tok.c" 1 11) -(PUNCT plus "02-obj-macro-multi-tok.c" 1 13) -(INT 2 "02-obj-macro-multi-tok.c" 1 15) -(EOF #f "02-obj-macro-multi-tok.c" 3 1) +(INT 1 "002-obj-macro-multi-tok.c" 1 11) +(PUNCT plus "002-obj-macro-multi-tok.c" 1 13) +(INT 2 "002-obj-macro-multi-tok.c" 1 15) +(EOF #f "002-obj-macro-multi-tok.c" 3 1) diff --git a/tests/cc-pp/003-fn-macro.expected b/tests/cc-pp/003-fn-macro.expected @@ -1,2 +1,2 @@ -(INT 42 "03-fn-macro.c" 2 4) -(EOF #f "03-fn-macro.c" 3 1) +(INT 42 "003-fn-macro.c" 2 4) +(EOF #f "003-fn-macro.c" 3 1) diff --git a/tests/cc-pp/004-fn-macro-2args.expected b/tests/cc-pp/004-fn-macro-2args.expected @@ -1,4 +1,4 @@ -(INT 3 "04-fn-macro-2args.c" 2 5) -(PUNCT plus "04-fn-macro-2args.c" 1 19) -(INT 4 "04-fn-macro-2args.c" 2 7) -(EOF #f "04-fn-macro-2args.c" 3 1) +(INT 3 "004-fn-macro-2args.c" 2 5) +(PUNCT plus "004-fn-macro-2args.c" 1 19) +(INT 4 "004-fn-macro-2args.c" 2 7) +(EOF #f "004-fn-macro-2args.c" 3 1) diff --git a/tests/cc-pp/005-variadic.expected b/tests/cc-pp/005-variadic.expected @@ -1,5 +1,5 @@ -(STR "x" "05-variadic.c" 2 5) -(INT 1 "05-variadic.c" 2 10) +(STR "x" "005-variadic.c" 2 5) +(INT 1 "005-variadic.c" 2 10) (PUNCT comma "<expand>" 0 0) -(INT 2 "05-variadic.c" 2 13) -(EOF #f "05-variadic.c" 3 1) +(INT 2 "005-variadic.c" 2 13) +(EOF #f "005-variadic.c" 3 1) diff --git a/tests/cc-pp/006-stringize.expected b/tests/cc-pp/006-stringize.expected @@ -1,2 +1,2 @@ -(STR "hello" "06-stringize.c" 1 16) -(EOF #f "06-stringize.c" 3 1) +(STR "hello" "006-stringize.c" 1 16) +(EOF #f "006-stringize.c" 3 1) diff --git a/tests/cc-pp/007-paste.expected b/tests/cc-pp/007-paste.expected @@ -1,2 +1,2 @@ -(IDENT "foobar" "07-paste.c" 2 5) -(EOF #f "07-paste.c" 3 1) +(IDENT "foobar" "007-paste.c" 2 5) +(EOF #f "007-paste.c" 3 1) diff --git a/tests/cc-pp/008-nested-expansion.expected b/tests/cc-pp/008-nested-expansion.expected @@ -1,2 +1,2 @@ -(INT 1 "08-nested-expansion.c" 1 11) -(EOF #f "08-nested-expansion.c" 4 1) +(INT 1 "008-nested-expansion.c" 1 11) +(EOF #f "008-nested-expansion.c" 4 1) diff --git a/tests/cc-pp/009-hideset-self.expected b/tests/cc-pp/009-hideset-self.expected @@ -1,2 +1,2 @@ -(IDENT "X" "09-hideset-self.c" 1 11) -(EOF #f "09-hideset-self.c" 3 1) +(IDENT "X" "009-hideset-self.c" 1 11) +(EOF #f "009-hideset-self.c" 3 1) diff --git a/tests/cc-pp/010-if-defined.expected b/tests/cc-pp/010-if-defined.expected @@ -1,2 +1,2 @@ -(INT 7 "10-if-defined.c" 3 1) -(EOF #f "10-if-defined.c" 5 1) +(INT 7 "010-if-defined.c" 3 1) +(EOF #f "010-if-defined.c" 5 1) diff --git a/tests/cc-pp/011-if-arith.expected b/tests/cc-pp/011-if-arith.expected @@ -1,2 +1,2 @@ -(INT 42 "11-if-arith.c" 2 1) -(EOF #f "11-if-arith.c" 4 1) +(INT 42 "011-if-arith.c" 2 1) +(EOF #f "011-if-arith.c" 4 1) diff --git a/tests/cc-pp/012-ifdef-ifndef.expected b/tests/cc-pp/012-ifdef-ifndef.expected @@ -1,3 +1,3 @@ -(INT 1 "12-ifdef-ifndef.c" 3 1) -(INT 2 "12-ifdef-ifndef.c" 6 1) -(EOF #f "12-ifdef-ifndef.c" 11 1) +(INT 1 "012-ifdef-ifndef.c" 3 1) +(INT 2 "012-ifdef-ifndef.c" 6 1) +(EOF #f "012-ifdef-ifndef.c" 11 1) diff --git a/tests/cc-pp/013-elif-chain.expected b/tests/cc-pp/013-elif-chain.expected @@ -1,2 +1,2 @@ -(INT 5 "13-elif-chain.c" 4 1) -(EOF #f "13-elif-chain.c" 10 1) +(INT 5 "013-elif-chain.c" 4 1) +(EOF #f "013-elif-chain.c" 10 1) diff --git a/tests/cc-pp/014-nested-if.expected b/tests/cc-pp/014-nested-if.expected @@ -1,2 +1,2 @@ -(INT 4 "14-nested-if.c" 5 1) -(EOF #f "14-nested-if.c" 10 1) +(INT 4 "014-nested-if.c" 5 1) +(EOF #f "014-nested-if.c" 10 1) diff --git a/tests/cc-pp/015-undef.expected b/tests/cc-pp/015-undef.expected @@ -1,3 +1,3 @@ -(INT 1 "15-undef.c" 1 11) -(IDENT "X" "15-undef.c" 4 1) -(EOF #f "15-undef.c" 5 1) +(INT 1 "015-undef.c" 1 11) +(IDENT "X" "015-undef.c" 4 1) +(EOF #f "015-undef.c" 5 1) diff --git a/tests/cc-pp/018-builtin-stdc.expected b/tests/cc-pp/018-builtin-stdc.expected @@ -1,3 +1,3 @@ -(INT 1 "18-builtin-stdc.c" 1 1) -(INT 1 "18-builtin-stdc.c" 1 10) -(EOF #f "18-builtin-stdc.c" 2 1) +(INT 1 "018-builtin-stdc.c" 1 1) +(INT 1 "018-builtin-stdc.c" 1 10) +(EOF #f "018-builtin-stdc.c" 2 1) diff --git a/tests/cc-pp/019-pragma-dropped.expected b/tests/cc-pp/019-pragma-dropped.expected @@ -1,2 +1,2 @@ -(INT 7 "19-pragma-dropped.c" 2 1) -(EOF #f "19-pragma-dropped.c" 3 1) +(INT 7 "019-pragma-dropped.c" 2 1) +(EOF #f "019-pragma-dropped.c" 3 1) diff --git a/tests/cc-pp/020-cexpr-ops.expected b/tests/cc-pp/020-cexpr-ops.expected @@ -1,2 +1,2 @@ -(INT 77 "20-cexpr-ops.c" 2 1) -(EOF #f "20-cexpr-ops.c" 4 1) +(INT 77 "020-cexpr-ops.c" 2 1) +(EOF #f "020-cexpr-ops.c" 4 1) diff --git a/tests/cc-pp/021-undefined-id-zero.expected b/tests/cc-pp/021-undefined-id-zero.expected @@ -1,2 +1,2 @@ -(INT 42 "21-undefined-id-zero.c" 2 1) -(EOF #f "21-undefined-id-zero.c" 4 1) +(INT 42 "021-undefined-id-zero.c" 2 1) +(EOF #f "021-undefined-id-zero.c" 4 1) diff --git a/tests/cc-pp/030-define-end-to-end.expected b/tests/cc-pp/030-define-end-to-end.expected @@ -1,2 +1,2 @@ -(INT 42 "30-define-end-to-end.c" 1 11) -(EOF #f "30-define-end-to-end.c" 3 1) +(INT 42 "030-define-end-to-end.c" 1 11) +(EOF #f "030-define-end-to-end.c" 3 1) diff --git a/tests/cc-pp/031-string-concat.expected b/tests/cc-pp/031-string-concat.expected @@ -1,6 +1,6 @@ -(STR "abc" "31-string-concat.c" 1 1) -(INT 1 "31-string-concat.c" 2 1) -(STR "pq" "31-string-concat.c" 3 1) -(INT 2 "31-string-concat.c" 4 1) -(STR "r" "31-string-concat.c" 4 3) -(EOF #f "31-string-concat.c" 5 1) +(STR "abc" "031-string-concat.c" 1 1) +(INT 1 "031-string-concat.c" 2 1) +(STR "pq" "031-string-concat.c" 3 1) +(INT 2 "031-string-concat.c" 4 1) +(STR "r" "031-string-concat.c" 4 3) +(EOF #f "031-string-concat.c" 5 1) diff --git a/tests/cc-pp/032-builtin-date-time.expected b/tests/cc-pp/032-builtin-date-time.expected @@ -1,5 +1,5 @@ -(STR "Jan 1 1970" "32-builtin-date-time.c" 1 1) -(PUNCT semi "32-builtin-date-time.c" 1 10) -(STR "00:00:00" "32-builtin-date-time.c" 2 1) -(PUNCT semi "32-builtin-date-time.c" 2 10) -(EOF #f "32-builtin-date-time.c" 3 1) +(STR "Jan 1 1970" "032-builtin-date-time.c" 1 1) +(PUNCT semi "032-builtin-date-time.c" 1 10) +(STR "00:00:00" "032-builtin-date-time.c" 2 1) +(PUNCT semi "032-builtin-date-time.c" 2 10) +(EOF #f "032-builtin-date-time.c" 3 1) diff --git a/tests/cc-pp/033-builtin-stdc-version-hosted.expected b/tests/cc-pp/033-builtin-stdc-version-hosted.expected @@ -1,3 +1,3 @@ -(INT 199901 "33-builtin-stdc-version-hosted.c" 1 1) -(INT 1 "33-builtin-stdc-version-hosted.c" 2 1) -(EOF #f "33-builtin-stdc-version-hosted.c" 3 1) +(INT 199901 "033-builtin-stdc-version-hosted.c" 1 1) +(INT 1 "033-builtin-stdc-version-hosted.c" 2 1) +(EOF #f "033-builtin-stdc-version-hosted.c" 3 1) diff --git a/tests/cc-pp/034-builtin-file-line.expected b/tests/cc-pp/034-builtin-file-line.expected @@ -1,3 +1,3 @@ -(STR "34-builtin-file-line.c" "34-builtin-file-line.c" 1 1) -(INT 2 "34-builtin-file-line.c" 2 1) -(EOF #f "34-builtin-file-line.c" 3 1) +(STR "034-builtin-file-line.c" "034-builtin-file-line.c" 1 1) +(INT 2 "034-builtin-file-line.c" 2 1) +(EOF #f "034-builtin-file-line.c" 3 1) diff --git a/tests/cc-pp/035-stringize-str-char.expected b/tests/cc-pp/035-stringize-str-char.expected @@ -1,7 +1,7 @@ -(STR "\"hi\"" "35-stringize-str-char.c" 1 14) -(PUNCT semi "35-stringize-str-char.c" 2 9) -(STR "'a'" "35-stringize-str-char.c" 1 14) -(PUNCT semi "35-stringize-str-char.c" 3 8) -(STR "\"a\\\\b\"" "35-stringize-str-char.c" 1 14) -(PUNCT semi "35-stringize-str-char.c" 4 11) -(EOF #f "35-stringize-str-char.c" 5 1) +(STR "\"hi\"" "035-stringize-str-char.c" 1 14) +(PUNCT semi "035-stringize-str-char.c" 2 9) +(STR "'a'" "035-stringize-str-char.c" 1 14) +(PUNCT semi "035-stringize-str-char.c" 3 8) +(STR "\"a\\\\b\"" "035-stringize-str-char.c" 1 14) +(PUNCT semi "035-stringize-str-char.c" 4 11) +(EOF #f "035-stringize-str-char.c" 5 1) diff --git a/tests/cc-pp/036-empty-arg.expected b/tests/cc-pp/036-empty-arg.expected @@ -1,6 +1,6 @@ -(PUNCT lbrack "36-empty-arg.c" 1 14) -(IDENT "x" "36-empty-arg.c" 2 3) -(PUNCT rbrack "36-empty-arg.c" 1 16) -(PUNCT lbrack "36-empty-arg.c" 1 14) -(PUNCT rbrack "36-empty-arg.c" 1 16) -(EOF #f "36-empty-arg.c" 4 1) +(PUNCT lbrack "036-empty-arg.c" 1 14) +(IDENT "x" "036-empty-arg.c" 2 3) +(PUNCT rbrack "036-empty-arg.c" 1 16) +(PUNCT lbrack "036-empty-arg.c" 1 14) +(PUNCT rbrack "036-empty-arg.c" 1 16) +(EOF #f "036-empty-arg.c" 4 1) diff --git a/tests/cc-pp/037-vararg-empty.expected b/tests/cc-pp/037-vararg-empty.expected @@ -1,10 +1,10 @@ -(PUNCT lbrack "37-vararg-empty.c" 1 23) -(STR "x" "37-vararg-empty.c" 2 5) -(PUNCT semi "37-vararg-empty.c" 1 27) -(PUNCT rbrack "37-vararg-empty.c" 1 40) -(PUNCT lbrack "37-vararg-empty.c" 1 23) -(STR "y" "37-vararg-empty.c" 3 5) -(PUNCT semi "37-vararg-empty.c" 1 27) -(INT 1 "37-vararg-empty.c" 3 10) -(PUNCT rbrack "37-vararg-empty.c" 1 40) -(EOF #f "37-vararg-empty.c" 4 1) +(PUNCT lbrack "037-vararg-empty.c" 1 23) +(STR "x" "037-vararg-empty.c" 2 5) +(PUNCT semi "037-vararg-empty.c" 1 27) +(PUNCT rbrack "037-vararg-empty.c" 1 40) +(PUNCT lbrack "037-vararg-empty.c" 1 23) +(STR "y" "037-vararg-empty.c" 3 5) +(PUNCT semi "037-vararg-empty.c" 1 27) +(INT 1 "037-vararg-empty.c" 3 10) +(PUNCT rbrack "037-vararg-empty.c" 1 40) +(EOF #f "037-vararg-empty.c" 4 1) diff --git a/tests/cc-pp/038-arg-prescan-stringize.expected b/tests/cc-pp/038-arg-prescan-stringize.expected @@ -1,2 +1,2 @@ -(STR "42" "38-arg-prescan-stringize.c" 1 16) -(EOF #f "38-arg-prescan-stringize.c" 5 1) +(STR "42" "038-arg-prescan-stringize.c" 1 16) +(EOF #f "038-arg-prescan-stringize.c" 5 1) diff --git a/tests/cc-pp/039-arg-prescan-paste.expected b/tests/cc-pp/039-arg-prescan-paste.expected @@ -1,2 +1,2 @@ -(IDENT "foobar" "39-arg-prescan-paste.c" 3 11) -(EOF #f "39-arg-prescan-paste.c" 5 1) +(IDENT "foobar" "039-arg-prescan-paste.c" 3 11) +(EOF #f "039-arg-prescan-paste.c" 5 1) diff --git a/tests/cc-pp/040-ifdef-active-typedef-fnmacro.expected b/tests/cc-pp/040-ifdef-active-typedef-fnmacro.expected @@ -1,16 +1,16 @@ -(KW typedef "40-ifdef-active-typedef-fnmacro.c" 3 1) -(KW char "40-ifdef-active-typedef-fnmacro.c" 3 9) -(PUNCT star "40-ifdef-active-typedef-fnmacro.c" 3 14) -(IDENT "T" "40-ifdef-active-typedef-fnmacro.c" 3 15) -(PUNCT semi "40-ifdef-active-typedef-fnmacro.c" 3 16) -(IDENT "T" "40-ifdef-active-typedef-fnmacro.c" 7 1) -(IDENT "a" "40-ifdef-active-typedef-fnmacro.c" 7 3) -(PUNCT semi "40-ifdef-active-typedef-fnmacro.c" 7 4) -(KW int "40-ifdef-active-typedef-fnmacro.c" 8 1) -(IDENT "x" "40-ifdef-active-typedef-fnmacro.c" 8 5) -(PUNCT assign "40-ifdef-active-typedef-fnmacro.c" 8 7) -(PUNCT lparen "40-ifdef-active-typedef-fnmacro.c" 4 14) -(INT 0 "40-ifdef-active-typedef-fnmacro.c" 8 11) -(PUNCT rparen "40-ifdef-active-typedef-fnmacro.c" 4 16) -(PUNCT semi "40-ifdef-active-typedef-fnmacro.c" 8 13) -(EOF #f "40-ifdef-active-typedef-fnmacro.c" 9 1) +(KW typedef "040-ifdef-active-typedef-fnmacro.c" 3 1) +(KW char "040-ifdef-active-typedef-fnmacro.c" 3 9) +(PUNCT star "040-ifdef-active-typedef-fnmacro.c" 3 14) +(IDENT "T" "040-ifdef-active-typedef-fnmacro.c" 3 15) +(PUNCT semi "040-ifdef-active-typedef-fnmacro.c" 3 16) +(IDENT "T" "040-ifdef-active-typedef-fnmacro.c" 7 1) +(IDENT "a" "040-ifdef-active-typedef-fnmacro.c" 7 3) +(PUNCT semi "040-ifdef-active-typedef-fnmacro.c" 7 4) +(KW int "040-ifdef-active-typedef-fnmacro.c" 8 1) +(IDENT "x" "040-ifdef-active-typedef-fnmacro.c" 8 5) +(PUNCT assign "040-ifdef-active-typedef-fnmacro.c" 8 7) +(PUNCT lparen "040-ifdef-active-typedef-fnmacro.c" 4 14) +(INT 0 "040-ifdef-active-typedef-fnmacro.c" 8 11) +(PUNCT rparen "040-ifdef-active-typedef-fnmacro.c" 4 16) +(PUNCT semi "040-ifdef-active-typedef-fnmacro.c" 8 13) +(EOF #f "040-ifdef-active-typedef-fnmacro.c" 9 1) diff --git a/tests/cc-pp/041-ifndef-defined-else-typedef-fnmacro.expected b/tests/cc-pp/041-ifndef-defined-else-typedef-fnmacro.expected @@ -1,16 +1,16 @@ -(KW typedef "41-ifndef-defined-else-typedef-fnmacro.c" 5 1) -(KW char "41-ifndef-defined-else-typedef-fnmacro.c" 5 9) -(PUNCT star "41-ifndef-defined-else-typedef-fnmacro.c" 5 14) -(IDENT "T" "41-ifndef-defined-else-typedef-fnmacro.c" 5 15) -(PUNCT semi "41-ifndef-defined-else-typedef-fnmacro.c" 5 16) -(IDENT "T" "41-ifndef-defined-else-typedef-fnmacro.c" 9 1) -(IDENT "a" "41-ifndef-defined-else-typedef-fnmacro.c" 9 3) -(PUNCT semi "41-ifndef-defined-else-typedef-fnmacro.c" 9 4) -(KW int "41-ifndef-defined-else-typedef-fnmacro.c" 10 1) -(IDENT "x" "41-ifndef-defined-else-typedef-fnmacro.c" 10 5) -(PUNCT assign "41-ifndef-defined-else-typedef-fnmacro.c" 10 7) -(PUNCT lparen "41-ifndef-defined-else-typedef-fnmacro.c" 6 14) -(INT 0 "41-ifndef-defined-else-typedef-fnmacro.c" 10 11) -(PUNCT rparen "41-ifndef-defined-else-typedef-fnmacro.c" 6 16) -(PUNCT semi "41-ifndef-defined-else-typedef-fnmacro.c" 10 13) -(EOF #f "41-ifndef-defined-else-typedef-fnmacro.c" 11 1) +(KW typedef "041-ifndef-defined-else-typedef-fnmacro.c" 5 1) +(KW char "041-ifndef-defined-else-typedef-fnmacro.c" 5 9) +(PUNCT star "041-ifndef-defined-else-typedef-fnmacro.c" 5 14) +(IDENT "T" "041-ifndef-defined-else-typedef-fnmacro.c" 5 15) +(PUNCT semi "041-ifndef-defined-else-typedef-fnmacro.c" 5 16) +(IDENT "T" "041-ifndef-defined-else-typedef-fnmacro.c" 9 1) +(IDENT "a" "041-ifndef-defined-else-typedef-fnmacro.c" 9 3) +(PUNCT semi "041-ifndef-defined-else-typedef-fnmacro.c" 9 4) +(KW int "041-ifndef-defined-else-typedef-fnmacro.c" 10 1) +(IDENT "x" "041-ifndef-defined-else-typedef-fnmacro.c" 10 5) +(PUNCT assign "041-ifndef-defined-else-typedef-fnmacro.c" 10 7) +(PUNCT lparen "041-ifndef-defined-else-typedef-fnmacro.c" 6 14) +(INT 0 "041-ifndef-defined-else-typedef-fnmacro.c" 10 11) +(PUNCT rparen "041-ifndef-defined-else-typedef-fnmacro.c" 6 16) +(PUNCT semi "041-ifndef-defined-else-typedef-fnmacro.c" 10 13) +(EOF #f "041-ifndef-defined-else-typedef-fnmacro.c" 11 1) diff --git a/tests/cc-pp/050-stringize-char-special.expected b/tests/cc-pp/050-stringize-char-special.expected @@ -1,2 +1,2 @@ -(STR "'\\n'" "50-stringize-char-special.c" 1 14) -(EOF #f "50-stringize-char-special.c" 3 1) +(STR "'\\n'" "050-stringize-char-special.c" 1 14) +(EOF #f "050-stringize-char-special.c" 3 1) diff --git a/tests/cc-pp/051-pp-shortcircuit-lor.expected b/tests/cc-pp/051-pp-shortcircuit-lor.expected @@ -1,2 +1,2 @@ -(INT 77 "51-pp-shortcircuit-lor.c" 2 1) -(EOF #f "51-pp-shortcircuit-lor.c" 4 1) +(INT 77 "051-pp-shortcircuit-lor.c" 2 1) +(EOF #f "051-pp-shortcircuit-lor.c" 4 1) diff --git a/tests/cc-pp/052-digraph-hash-directive.expected b/tests/cc-pp/052-digraph-hash-directive.expected @@ -1,2 +1,2 @@ -(INT 7 "52-digraph-hash-directive.c" 1 14) -(EOF #f "52-digraph-hash-directive.c" 3 1) +(INT 7 "052-digraph-hash-directive.c" 1 14) +(EOF #f "052-digraph-hash-directive.c" 3 1) diff --git a/tests/cc-pp/052-pp-shortcircuit-land.expected b/tests/cc-pp/052-pp-shortcircuit-land.expected @@ -1,2 +1,2 @@ -(INT 77 "52-pp-shortcircuit-land.c" 4 1) -(EOF #f "52-pp-shortcircuit-land.c" 6 1) +(INT 77 "052-pp-shortcircuit-land.c" 4 1) +(EOF #f "052-pp-shortcircuit-land.c" 6 1) diff --git a/tests/cc-pp/053-line-directive-effect.expected b/tests/cc-pp/053-line-directive-effect.expected @@ -1,4 +1,4 @@ -(INT 1 "53-line-directive-effect.c" 1 1) +(INT 1 "053-line-directive-effect.c" 1 1) (INT 100 "x.c" 100 1) (STR "x.c" "x.c" 101 1) -(EOF #f "53-line-directive-effect.c" 5 1) +(EOF #f "053-line-directive-effect.c" 5 1) diff --git a/tests/cc-pp/053-pp-shortcircuit-cond.expected b/tests/cc-pp/053-pp-shortcircuit-cond.expected @@ -1,2 +1,2 @@ -(INT 77 "53-pp-shortcircuit-cond.c" 2 1) -(EOF #f "53-pp-shortcircuit-cond.c" 4 1) +(INT 77 "053-pp-shortcircuit-cond.c" 2 1) +(EOF #f "053-pp-shortcircuit-cond.c" 4 1) diff --git a/tests/cc-util/004-alist.scm b/tests/cc-util/004-alist.scm @@ -2,11 +2,12 @@ ;; alist-update. ;; Assumes cc/util.scm is loaded. -;; alist-ref uses equal? — bv keys +;; alist-ref uses byte-aware equality for string/bytevector keys. (define al1 (alist-set "k1" 1 (alist-set "k2" 2 '()))) (if (= (alist-ref "k1" al1) 1) 0 (sys-exit 1)) (if (= (alist-ref "k2" al1) 2) 0 (sys-exit 2)) (if (alist-ref "k3" al1) (sys-exit 3) 0) ; missing -> #f +(if (= (alist-ref (bytevector 107 49) al1) 1) 0 (sys-exit 11)) ;; alist-set conses on the front (later entries shadow older ones via search order) (define al2 (alist-set "k1" 99 al1)) @@ -22,6 +23,8 @@ (define al4 (alist-update "k1" (lambda (v) (+ v 100)) al1)) (if (= (alist-ref "k1" al4) 101) 0 (sys-exit 8)) (if (= (alist-ref "k2" al4) 2) 0 (sys-exit 9)) ; other key untouched +(define al4b (alist-update (bytevector 107 49) (lambda (v) (+ v 200)) al1)) +(if (= (alist-ref "k1" al4b) 201) 0 (sys-exit 12)) ;; alist-update: missing key -> upsert with (f #f) (define al5 (alist-update "new" (lambda (v) (if v v 7)) '())) diff --git a/tests/scheme1/007-hex.scm b/tests/scheme1/007-hex.scm @@ -1,10 +1,9 @@ -; #x and #X dispatch, lowercase / uppercase / mixed-case digits, and the -; negative-literal form #x-NN. +; Micro uses lowercase #x dispatch, accepts either case in the digits, and +; supports an optional sign after the prefix. (if (= #x2a 42) 0 (sys-exit 1)) ; lowercase #x, lowercase digits -(if (= #X2a 42) 0 (sys-exit 2)) ; uppercase #X (if (= #xff 255) 0 (sys-exit 3)) ; lowercase digits (if (= #xFF 255) 0 (sys-exit 4)) ; uppercase digits (if (= #xFf 255) 0 (sys-exit 5)) ; mixed-case digits (if (= #x-2a -42) 0 (sys-exit 6)) ; negative -(if (= #X-Ff -255) 0 (sys-exit 7)) ; negative + uppercase #X + uppercase digits +(if (= #x+2a 42) 0 (sys-exit 7)) ; explicit positive sign (sys-exit 42) diff --git a/tests/scheme1/040-argv.scm b/tests/scheme1/040-argv.scm @@ -1,6 +1,6 @@ -; Verify the prelude's (argv) and (exit n) wrappers. argv[0] is the +; Verify the prelude's argv wrapper. argv[0] is the ; program name, argv[1] is this script. Exit with the entry count so ; the runner can diff it against expected-exit. (define (count xs) (if (null? xs) 0 (+ 1 (count (cdr xs))))) -(exit (count (argv))) +(sys-exit (count (argv))) diff --git a/tests/scheme1/041-fileio.scm b/tests/scheme1/041-fileio.scm @@ -3,8 +3,8 @@ ; proving open and read both succeeded and the data made it into a ; Scheme bytevector. Path comes from (argv); no raw sys-* primitives. (define ip (open-input (car (cdr (argv))))) -(if (not (car ip)) (exit 1) 0) +(if (not (car ip)) (sys-exit 1) 0) (define rd (read-bytes (cdr ip) 1)) (close (cdr ip)) -(if (not (car rd)) (exit 2) 0) -(exit (bytevector-u8-ref (cdr rd) 0)) +(if (not (car rd)) (sys-exit 2) 0) +(sys-exit (bytevector-u8-ref (cdr rd) 0)) diff --git a/tests/scheme1/045-shell-spawn.scm b/tests/scheme1/045-shell-spawn.scm @@ -2,4 +2,4 @@ ; child's exit. Together with 51 (signal branch) this covers both ; halves of decode-wait-status without raw sys-* poking. (define r (run "/bin/true")) -(if (car r) (exit (cdr r)) (exit 99)) +(if (car r) (sys-exit (cdr r)) (sys-exit 99)) diff --git a/tests/scheme1/048-display-write.expected b/tests/scheme1/048-display-write.expected @@ -8,7 +8,14 @@ foo (1 . 2) (a (b c) d) hi +string +A 42 foo (1 2 3) -"hi" +#u8(104 105) +"string" +"a\n\x00;b" +#\A +#\space +#\x7f diff --git a/tests/scheme1/048-display-write.scm b/tests/scheme1/048-display-write.scm @@ -1,9 +1,8 @@ ; Verify display and write across the value spaces. ; -; display emits human-readable output: bytevectors as raw bytes, no -; quotes; symbols as their name; pairs in list syntax; immediates in -; their reader form. write is identical except bytevectors are quoted -; "..." (treated as strings). +; display emits human-readable output; write emits reader-compatible +; datums for strings, bytevectors, and characters. Boot2 retains raw +; bytevector display for compiler diagnostics. (define (newline) (display (make-bytevector 1 10))) (define hi (make-bytevector 2 0)) @@ -20,10 +19,17 @@ (display '(1 . 2)) (newline) (display '(a (b c) d)) (newline) (display hi) (newline) +(display "string") (newline) +(display #\A) (newline) (write 42) (newline) (write 'foo) (newline) (write '(1 2 3)) (newline) (write hi) (newline) +(write "string") (newline) +(write "a\n\x0;b") (newline) +(write #\A) (newline) +(write #\space) (newline) +(write #\x7f) (newline) (sys-exit 0) diff --git a/tests/scheme1/051-shell-signal.scm b/tests/scheme1/051-shell-signal.scm @@ -3,4 +3,4 @@ ; Together with 45/56 (exit-code branch) this covers both branches of ; decode-wait-status without any raw sys-* poking. (define r (run "/bin/sh" "-c" "kill -9 $$")) -(if (car r) (exit (cdr r)) (exit 99)) +(if (car r) (sys-exit (cdr r)) (sys-exit 99)) diff --git a/tests/scheme1/052-string-literal.scm b/tests/scheme1/052-string-literal.scm @@ -1,9 +1,13 @@ -; "..." string literals are bytevectors. Basic content + length. +; String literals have their own length-bearing type. Boot2 bytevector +; operations can still inspect their encoded bytes. (define s "abc") -(if (= (bytevector-length s) 3) 0 (sys-exit 1)) -(if (= (bytevector-u8-ref s 0) 97) 0 (sys-exit 2)) ; 'a' -(if (= (bytevector-u8-ref s 1) 98) 0 (sys-exit 3)) ; 'b' -(if (= (bytevector-u8-ref s 2) 99) 0 (sys-exit 4)) ; 'c' -; Empty string is a 0-length bytevector. -(if (= (bytevector-length "") 0) 0 (sys-exit 5)) +(if (string? s) 0 (sys-exit 1)) +(if (not (bytevector? s)) 0 (sys-exit 2)) +(if (bytes? s) 0 (sys-exit 3)) +(if (= (string-length s) 3) 0 (sys-exit 4)) +(if (= (bytevector-length s) 3) 0 (sys-exit 5)) +(if (= (bytevector-u8-ref s 0) 97) 0 (sys-exit 6)) ; 'a' +(if (= (bytevector-u8-ref s 1) 98) 0 (sys-exit 7)) ; 'b' +(if (= (bytevector-u8-ref s 2) 99) 0 (sys-exit 8)) ; 'c' +(if (= (string-length "") 0) 0 (sys-exit 9)) (sys-exit 0) diff --git a/tests/scheme1/053-string-escapes.scm b/tests/scheme1/053-string-escapes.scm @@ -29,6 +29,8 @@ (if (= (bytevector-u8-ref h2 2) 99) 0 (sys-exit 15)) ; 'c' (if (= (bytevector-u8-ref h2 3) 255) 0 (sys-exit 16)) ; 0xff (if (= (bytevector-u8-ref h2 4) 0) 0 (sys-exit 17)) ; 0x00 +(if (= (string-length h2) 5) 0 (sys-exit 20)) ; NUL is not a terminator +(if (eq? (string-ref h2 4) #\null) 0 (sys-exit 21)) ; Multi-digit form (still byte-sized) and uppercase X is NOT accepted — ; only lowercase \x; this matches R7RS-Small literal syntax. diff --git a/tests/scheme1/054-char-literal.scm b/tests/scheme1/054-char-literal.scm @@ -1,11 +1,11 @@ -; #\<c> for printable ASCII evaluates to the u8 of <c>. -; #\xNN evaluates to the byte with that hex value. -(if (= #\a 97) 0 (sys-exit 1)) ; lowercase -(if (= #\Z 90) 0 (sys-exit 2)) ; uppercase -(if (= #\! 33) 0 (sys-exit 3)) ; punctuation -(if (= #\~ 126) 0 (sys-exit 4)) ; last printable -(if (= #\x41 65) 0 (sys-exit 5)) ; hex form -> 'A' -(if (= #\x7f 127) 0 (sys-exit 6)) ; hex form -> DEL -(if (= #\xff 255) 0 (sys-exit 7)) ; hex, 8-bit max -(if (= #\xFF 255) 0 (sys-exit 8)) ; hex, uppercase digits +; Character literals are disjoint from integers; conversion is explicit. +(if (= (char->integer #\a) 97) 0 (sys-exit 1)) +(if (= (char->integer #\Z) 90) 0 (sys-exit 2)) +(if (= (char->integer #\!) 33) 0 (sys-exit 3)) +(if (= (char->integer #\~) 126) 0 (sys-exit 4)) +(if (= (char->integer #\x41) 65) 0 (sys-exit 5)) +(if (= (char->integer #\x7f) 127) 0 (sys-exit 6)) +(if (= (char->integer #\xff) 255) 0 (sys-exit 7)) +(if (= (char->integer #\xFF) 255) 0 (sys-exit 8)) +(if (= (char->integer #\x00041) 65) 0 (sys-exit 9)) (sys-exit 0) diff --git a/tests/scheme1/055-char-named.scm b/tests/scheme1/055-char-named.scm @@ -1,7 +1,7 @@ ; Named character forms: #\space #\newline #\tab #\return #\null. -(if (= #\space 32) 0 (sys-exit 1)) -(if (= #\newline 10) 0 (sys-exit 2)) -(if (= #\tab 9) 0 (sys-exit 3)) -(if (= #\return 13) 0 (sys-exit 4)) -(if (= #\null 0) 0 (sys-exit 5)) +(if (= (char->integer #\space) 32) 0 (sys-exit 1)) +(if (= (char->integer #\newline) 10) 0 (sys-exit 2)) +(if (= (char->integer #\tab) 9) 0 (sys-exit 3)) +(if (= (char->integer #\return) 13) 0 (sys-exit 4)) +(if (= (char->integer #\null) 0) 0 (sys-exit 5)) (sys-exit 0) diff --git a/tests/scheme1/057-bytevector-eq.scm b/tests/scheme1/057-bytevector-eq.scm @@ -1,6 +1,6 @@ -; (bytevector=? a b) -> #t iff a and b are bytevectors of equal length -; with the same bytes. Only structural; non-bytevector inputs are #f -; rather than an error (kept lax until LISP.md pins the policy). +; Boot2 widens bytevector=? to its byte bridge: either operand may be a +; bytevector or string. bytes=? gives the same mixed-type comparison an +; explicitly nonstandard name. ; Self-equal. (if (bytevector=? "abc" "abc") 0 (sys-exit 1)) @@ -24,6 +24,7 @@ ; String literal vs handcrafted bv with identical bytes. (define s "AAA") (if (bytevector=? s a) 0 (sys-exit 6)) +(if (bytes=? s a) 0 (sys-exit 9)) ; Non-bytevector inputs return #f rather than crashing. (if (not (bytevector=? '(1 2 3) "abc")) 0 (sys-exit 7)) diff --git a/tests/scheme1/058-equal.scm b/tests/scheme1/058-equal.scm @@ -1,6 +1,7 @@ ; (equal? a b) -- structural equality. Falls back to eq? for ; fixnums/symbols/immediates/identical heap-or-pair pointers; recurses -; into pair structure; uses bytevector=? for bytevector contents. Other +; into pair structure; compares strings and bytevectors within their own +; disjoint types. Other ; heap types (closures, prims, records, type descriptors) compare by ; identity only. @@ -33,11 +34,13 @@ (if (equal? (cons 1 2) (cons 1 2)) 0 (sys-exit 12)) (if (not (equal? (cons 1 2) (cons 1 3))) 0 (sys-exit 13)) -; Bytevectors compared structurally. +; Strings compared structurally. (if (equal? "abc" "abc") 0 (sys-exit 14)) (if (not (equal? "abc" "abd")) 0 (sys-exit 15)) (if (not (equal? "abc" "ab")) 0 (sys-exit 16)) (if (equal? "" "") 0 (sys-exit 17)) +(if (not (equal? "abc" #u8(97 98 99))) 0 (sys-exit 22)) +(if (equal? #u8(97 98 99) #u8(97 98 99)) 0 (sys-exit 23)) ; Nested: pair containing bytevector. (define x (cons 'tag (cons "abc" '()))) diff --git a/tests/scheme1/059-stringq.scm b/tests/scheme1/059-stringq.scm @@ -1,18 +1,16 @@ -; (string? x) -- #t iff x is a bytevector. scheme1 uses bytevectors as -; the underlying string representation, so string? and bytevector? are -; the same predicate (LISP.md:strings; we'll split if/when characters -; gain a distinct repr). +; Strings and bytevectors are disjoint categories. (if (string? "abc") 0 (sys-exit 1)) (if (string? "") 0 (sys-exit 2)) -(if (string? (make-bytevector 4 0)) 0 (sys-exit 3)) +(if (string? (make-string 4 #\null)) 0 (sys-exit 3)) +(if (not (string? (make-bytevector 4 0))) 0 (sys-exit 4)) -(if (not (string? 42)) 0 (sys-exit 4)) -(if (not (string? 'foo)) 0 (sys-exit 5)) -(if (not (string? '())) 0 (sys-exit 6)) -(if (not (string? '(1 2))) 0 (sys-exit 7)) -(if (not (string? #t)) 0 (sys-exit 8)) -(if (not (string? #f)) 0 (sys-exit 9)) -(if (not (string? car)) 0 (sys-exit 10)) +(if (not (string? 42)) 0 (sys-exit 5)) +(if (not (string? 'foo)) 0 (sys-exit 6)) +(if (not (string? '())) 0 (sys-exit 7)) +(if (not (string? '(1 2))) 0 (sys-exit 8)) +(if (not (string? #t)) 0 (sys-exit 9)) +(if (not (string? #f)) 0 (sys-exit 10)) +(if (not (string? car)) 0 (sys-exit 11)) (sys-exit 0) diff --git a/tests/scheme1/063-file-output-roundtrip.scm b/tests/scheme1/063-file-output-roundtrip.scm @@ -6,15 +6,15 @@ (define payload "abc\nxyz") (define op (open-output path)) -(if (not (car op)) (exit 10) 0) +(if (not (car op)) (sys-exit 10) 0) (define wr (write-bytes (cdr op) payload)) (close (cdr op)) -(if (not (car wr)) (exit 20) 0) +(if (not (car wr)) (sys-exit 20) 0) (define ip (open-input path)) -(if (not (car ip)) (exit 30) 0) +(if (not (car ip)) (sys-exit 30) 0) (define rd (read-all (cdr ip))) (close (cdr ip)) -(if (not (car rd)) (exit 40) 0) +(if (not (car rd)) (sys-exit 40) 0) -(if (bytevector=? (cdr rd) payload) (exit 0) (exit 50)) +(if (bytevector=? (cdr rd) payload) (sys-exit 0) (sys-exit 50)) diff --git a/tests/scheme1/064-file-append.scm b/tests/scheme1/064-file-append.scm @@ -4,19 +4,19 @@ (define path "/tmp/scheme1-append.txt") (define o1 (open-output path)) -(if (not (car o1)) (exit 10) 0) +(if (not (car o1)) (sys-exit 10) 0) (write-bytes (cdr o1) "hello\n") (close (cdr o1)) (define o2 (open-append path)) -(if (not (car o2)) (exit 20) 0) +(if (not (car o2)) (sys-exit 20) 0) (write-bytes (cdr o2) "world\n") (close (cdr o2)) (define ip (open-input path)) -(if (not (car ip)) (exit 30) 0) +(if (not (car ip)) (sys-exit 30) 0) (define rd (read-all (cdr ip))) (close (cdr ip)) -(if (not (car rd)) (exit 40) 0) +(if (not (car rd)) (sys-exit 40) 0) -(if (bytevector=? (cdr rd) "hello\nworld\n") (exit 0) (exit 50)) +(if (bytevector=? (cdr rd) "hello\nworld\n") (sys-exit 0) (sys-exit 50)) diff --git a/tests/scheme1/065-string-symbol.scm b/tests/scheme1/065-string-symbol.scm @@ -1,6 +1,5 @@ -; (string->symbol bv) and (symbol->string sym) -- bridge between the -; bytevector and symbol spaces. string->symbol interns into the global -; symtab; symbol->string returns a fresh bytevector copy of the name. +; string->symbol interns into the global symtab; symbol->string returns +; a fresh string copy of the name. ; Round-trip a literal. (define s (string->symbol "hello")) @@ -13,25 +12,26 @@ ; Interning a literal matches a quoted symbol. (if (eq? (string->symbol "foo") 'foo) 0 (sys-exit 3)) -; symbol->string returns a bytevector with the right bytes. +; symbol->string returns a string with the right bytes. (define name (symbol->string 'world)) (if (string? name) 0 (sys-exit 4)) -(if (bytevector=? name "world") 0 (sys-exit 5)) +(if (not (bytevector? name)) 0 (sys-exit 5)) +(if (string=? name "world") 0 (sys-exit 6)) -; symbol->string returns a *fresh* bv: mutating it does not bleed back +; symbol->string returns a *fresh* string: mutating it does not bleed back ; into the symtab (next conversion still gives "world"). -(bytevector-u8-set! name 0 88) ; 'X' -(if (bytevector=? (symbol->string 'world) "world") 0 (sys-exit 6)) +(string-set! name 0 #\X) +(if (string=? (symbol->string 'world) "world") 0 (sys-exit 7)) ; Round-trip both directions. -(if (eq? 'banana (string->symbol (symbol->string 'banana))) 0 (sys-exit 7)) -(if (bytevector=? "banana" - (symbol->string (string->symbol "banana"))) 0 (sys-exit 8)) +(if (eq? 'banana (string->symbol (symbol->string 'banana))) 0 (sys-exit 8)) +(if (string=? "banana" + (symbol->string (string->symbol "banana"))) 0 (sys-exit 9)) ; Empty bytevector interns to a single canonical empty-named symbol. (define empty-name (string->symbol "")) (collect-garbage) -(if (eq? empty-name (string->symbol "")) 0 (sys-exit 9)) -(if (bytevector=? "" (symbol->string empty-name)) 0 (sys-exit 10)) +(if (eq? empty-name (string->symbol "")) 0 (sys-exit 10)) +(if (string=? "" (symbol->string empty-name)) 0 (sys-exit 11)) (sys-exit 0) diff --git a/tests/scheme1/066-bytevector-append.scm b/tests/scheme1/066-bytevector-append.scm @@ -3,36 +3,37 @@ ; Zero-arg form: empty bv. (define z (bytevector-append)) -(if (string? z) 0 (sys-exit 1)) -(if (= (bytevector-length z) 0) 0 (sys-exit 2)) +(if (bytevector? z) 0 (sys-exit 1)) +(if (not (string? z)) 0 (sys-exit 2)) +(if (= (bytevector-length z) 0) 0 (sys-exit 3)) ; One-arg form: equal contents but a fresh allocation. (define a (bytevector-append "abc")) -(if (bytevector=? a "abc") 0 (sys-exit 3)) +(if (bytevector=? a "abc") 0 (sys-exit 4)) (bytevector-u8-set! a 0 88) -(if (bytevector=? "abc" "abc") 0 (sys-exit 4)) ; literal untouched +(if (bytevector=? "abc" "abc") 0 (sys-exit 5)) ; literal untouched ; Two-arg form: simple concat. -(if (bytevector=? "abcdef" (bytevector-append "abc" "def")) 0 (sys-exit 5)) +(if (bytevector=? "abcdef" (bytevector-append "abc" "def")) 0 (sys-exit 6)) ; Three+ args. (if (bytevector=? "abcdefghi" - (bytevector-append "abc" "def" "ghi")) 0 (sys-exit 6)) + (bytevector-append "abc" "def" "ghi")) 0 (sys-exit 7)) ; Empty operands flush through. -(if (bytevector=? "abc" (bytevector-append "" "abc")) 0 (sys-exit 7)) -(if (bytevector=? "abc" (bytevector-append "abc" "")) 0 (sys-exit 8)) -(if (bytevector=? "abc" (bytevector-append "" "abc" "")) 0 (sys-exit 9)) -(if (bytevector=? "" (bytevector-append "" "" "")) 0 (sys-exit 10)) +(if (bytevector=? "abc" (bytevector-append "" "abc")) 0 (sys-exit 8)) +(if (bytevector=? "abc" (bytevector-append "abc" "")) 0 (sys-exit 9)) +(if (bytevector=? "abc" (bytevector-append "" "abc" "")) 0 (sys-exit 10)) +(if (bytevector=? "" (bytevector-append "" "" "")) 0 (sys-exit 11)) ; Non-literal bytevectors (built via make-bytevector + set!). (define p (make-bytevector 2 65)) ; "AA" (define q (make-bytevector 3 66)) ; "BBB" -(if (bytevector=? "AABBB" (bytevector-append p q)) 0 (sys-exit 11)) +(if (bytevector=? "AABBB" (bytevector-append p q)) 0 (sys-exit 12)) ; Result is independent: mutating the result doesn't affect the inputs. (define r (bytevector-append p q)) (bytevector-u8-set! r 0 90) -(if (= (bytevector-u8-ref p 0) 65) 0 (sys-exit 12)) +(if (= (bytevector-u8-ref p 0) 65) 0 (sys-exit 13)) (sys-exit 0) diff --git a/tests/scheme1/067-read-line.scm b/tests/scheme1/067-read-line.scm @@ -3,22 +3,22 @@ ; bv-concat-reverse via the line-assembly path inside read-line. (define path "/tmp/scheme1-read-line.txt") (define op (open-output path)) -(if (not (car op)) (exit 10) 0) +(if (not (car op)) (sys-exit 10) 0) (write-bytes (cdr op) "alpha\nbeta\ngamma\n") (close (cdr op)) (define ip (open-input path)) -(if (not (car ip)) (exit 20) 0) +(if (not (car ip)) (sys-exit 20) 0) (define p (cdr ip)) -(define l1 (read-line p)) -(define l2 (read-line p)) -(define l3 (read-line p)) -(define l4 (read-line p)) +(define l1 (fd-read-line/result p)) +(define l2 (fd-read-line/result p)) +(define l3 (fd-read-line/result p)) +(define l4 (fd-read-line/result p)) (close p) (if (and (car l1) (bytevector=? (cdr l1) "alpha") (car l2) (bytevector=? (cdr l2) "beta") (car l3) (bytevector=? (cdr l3) "gamma") (car l4) (eof? (cdr l4))) - (exit 0) - (exit 1)) + (sys-exit 0) + (sys-exit 1)) diff --git a/tests/scheme1/068-read-bytes-multi.scm b/tests/scheme1/068-read-bytes-multi.scm @@ -6,17 +6,17 @@ (define payload (make-bytevector 5000 65)) ; 5000 'A' bytes (define op (open-output path)) -(if (not (car op)) (exit 10) 0) +(if (not (car op)) (sys-exit 10) 0) (write-bytes (cdr op) payload) (close (cdr op)) (define ip (open-input path)) -(if (not (car ip)) (exit 20) 0) +(if (not (car ip)) (sys-exit 20) 0) (define rd (read-bytes (cdr ip) 5000)) (close (cdr ip)) -(if (not (car rd)) (exit 30) 0) +(if (not (car rd)) (sys-exit 30) 0) (if (and (= (bytevector-length (cdr rd)) 5000) (bytevector=? (cdr rd) payload)) - (exit 0) - (exit 40)) + (sys-exit 0) + (sys-exit 40)) diff --git a/tests/scheme1/069-open-input-missing.scm b/tests/scheme1/069-open-input-missing.scm @@ -6,5 +6,5 @@ ; - cdr is an integer (a real errno-like code, not garbage) (define r (open-input "/this/path/should/not/exist/scheme1-test")) (if (and (not (car r)) (integer? (cdr r))) - (exit 0) - (exit 1)) + (sys-exit 0) + (sys-exit 1)) diff --git a/tests/scheme1/070-type-predicates.scm b/tests/scheme1/070-type-predicates.scm @@ -18,6 +18,9 @@ (if (not (integer? #t)) 0 (sys-exit 9)) (if (not (integer? '(1 2))) 0 (sys-exit 10)) (if (not (integer? 'sym)) 0 (sys-exit 11)) +(if (not (integer? #\A)) 0 (sys-exit 18)) +(if (char? #\A) 0 (sys-exit 19)) +(if (not (char? 65)) 0 (sys-exit 20)) ; procedure? — closures and primitives (if (procedure? car) 0 (sys-exit 12)) diff --git a/tests/scheme1/074-num-str-conv.scm b/tests/scheme1/074-num-str-conv.scm @@ -1,4 +1,4 @@ -; number->string returns a fresh bytevector with the decimal repr. +; number->string returns a fresh string with the requested representation. ; string->number parses decimal (optional leading -) into a fixnum, ; or #f on garbage / empty input. @@ -7,6 +7,8 @@ (if (bytevector=? "42" (number->string 42)) 0 (sys-exit 3)) (if (bytevector=? "-7" (number->string -7)) 0 (sys-exit 4)) (if (bytevector=? "1234567" (number->string 1234567)) 0 (sys-exit 5)) +(if (string? (number->string 42)) 0 (sys-exit 20)) +(if (not (bytevector? (number->string 42))) 0 (sys-exit 21)) (if (= 0 (string->number "0")) 0 (sys-exit 6)) (if (= 1 (string->number "1")) 0 (sys-exit 7)) @@ -23,10 +25,12 @@ (if (= 99 (string->number (number->string 99))) 0 (sys-exit 16)) (if (= -99 (string->number (number->string -99))) 0 (sys-exit 17)) -; Radix arg is part of the surface (LISP.md). Impl is decimal-only for -; now; passing radix=10 must match the no-radix call. Other radices are -; not yet pinned by tests since the impl ignores them. +; Micro supports radix 10 and radix 16 and rejects all others. (if (bytevector=? "42" (number->string 42 10)) 0 (sys-exit 18)) (if (= 42 (string->number "42" 10)) 0 (sys-exit 19)) +(if (string=? "ff" (number->string 255 16)) 0 (sys-exit 22)) +(if (string=? "-ff" (number->string -255 16)) 0 (sys-exit 23)) +(if (= 255 (string->number "ff" 16)) 0 (sys-exit 24)) +(if (= -255 (string->number "-ff" 16)) 0 (sys-exit 25)) (sys-exit 0) diff --git a/tests/scheme1/079-bv-num-aliases.scm b/tests/scheme1/079-bv-num-aliases.scm @@ -1,12 +1,17 @@ -; bytevector? and number? — prelude aliases. bytevector? mirrors string? -; (one HDR.BV repr); number? mirrors integer? (only fixnums today). +; bytevector?, string?, and bytes? distinguish the standard types while +; exposing the explicit boot2 bridge. number? mirrors integer?. ; bytevector? -(if (bytevector? "abc") 0 (sys-exit 1)) +(if (not (bytevector? "abc")) 0 (sys-exit 1)) (if (bytevector? (make-bytevector 3 0)) 0 (sys-exit 2)) (if (not (bytevector? 0)) 0 (sys-exit 3)) (if (not (bytevector? '())) 0 (sys-exit 4)) (if (not (bytevector? 'foo)) 0 (sys-exit 5)) +(if (string? "abc") 0 (sys-exit 12)) +(if (not (string? (make-bytevector 3 0))) 0 (sys-exit 13)) +(if (bytes? "abc") 0 (sys-exit 14)) +(if (bytes? (make-bytevector 3 0)) 0 (sys-exit 15)) +(if (not (bytes? 0)) 0 (sys-exit 16)) ; number? (if (number? 0) 0 (sys-exit 6)) diff --git a/tests/scheme1/080-u8-literal.scm b/tests/scheme1/080-u8-literal.scm @@ -12,8 +12,9 @@ (if (= (bytevector-u8-ref a 1) 2) 0 (sys-exit 4)) (if (= (bytevector-u8-ref a 2) 3) 0 (sys-exit 5)) -; Equality with a same-bytes string literal (both HDR.BV). -(if (bytevector=? #u8(65 66 67) "ABC") 0 (sys-exit 6)) +; The boot2 bridge compares the disjoint types by encoded bytes. +(if (bytes=? #u8(65 66 67) "ABC") 0 (sys-exit 6)) +(if (not (equal? #u8(65 66 67) "ABC")) 0 (sys-exit 11)) ; Hex element values are accepted (parser shares atom dispatch). (define b #u8(#x00 #xff)) diff --git a/tests/scheme1/083-write-line.scm b/tests/scheme1/083-write-line.scm @@ -3,15 +3,15 @@ (define path "/tmp/scheme1-write-line.txt") (define op (open-output path)) -(if (not (car op)) (exit 10) 0) +(if (not (car op)) (sys-exit 10) 0) (write-line (cdr op) "hello") (write-line (cdr op) "world") (close (cdr op)) (define ip (open-input path)) -(if (not (car ip)) (exit 20) 0) +(if (not (car ip)) (sys-exit 20) 0) (define rd (read-all (cdr ip))) (close (cdr ip)) -(if (not (car rd)) (exit 30) 0) +(if (not (car rd)) (sys-exit 30) 0) -(if (bytevector=? (cdr rd) "hello\nworld\n") (exit 0) (exit 40)) +(if (bytevector=? (cdr rd) "hello\nworld\n") (sys-exit 0) (sys-exit 40)) diff --git a/tests/scheme1/088-pmatch-literals.scm b/tests/scheme1/088-pmatch-literals.scm @@ -8,7 +8,7 @@ (else (sys-exit 91)))) 0 (sys-exit 1)) -;; Character literals are integers; #\A == 65. +;; Character literals are disjoint values and match by identity. (if (= 65 (pmatch #\A (#\B (sys-exit 92)) diff --git a/tests/scheme1/100-char-procs.scm b/tests/scheme1/100-char-procs.scm @@ -1,18 +1,18 @@ ; char?, char->integer, integer->char, digit-value, char predicates, ; case maps, and the variadic char comparisons. -;; --- char? is a fixnum 0..255 range check -------------------------- +;; --- characters are a type disjoint from exact integers ------------ (if (char? #\A) 0 (sys-exit 1)) -(if (char? 0) 0 (sys-exit 2)) -(if (char? 255) 0 (sys-exit 3)) +(if (not (char? 0)) 0 (sys-exit 2)) +(if (not (char? 255)) 0 (sys-exit 3)) (if (not (char? -1)) 0 (sys-exit 4)) (if (not (char? 256)) 0 (sys-exit 5)) (if (not (char? 'sym)) 0 (sys-exit 6)) -;; --- char->integer / integer->char are the identity --------------- +;; --- char->integer / integer->char explicitly cross the boundary --- (if (= 65 (char->integer #\A)) 0 (sys-exit 7)) -(if (= #\A (integer->char 65)) 0 (sys-exit 8)) -(if (eq? #\A 65) 0 (sys-exit 9)) +(if (eq? #\A (integer->char 65)) 0 (sys-exit 8)) +(if (not (eq? #\A 65)) 0 (sys-exit 9)) ;; --- digit-value -------------------------------------------------- (if (= 0 (digit-value #\0)) 0 (sys-exit 10)) diff --git a/tests/scheme1/102-string-cmp-case.scm b/tests/scheme1/102-string-cmp-case.scm @@ -37,7 +37,7 @@ ;; --- string-for-each accumulates side effects -------------------- (define total 0) -(string-for-each (lambda (c) (set! total (+ total c))) "abc") +(string-for-each (lambda (c) (set! total (+ total (char->integer c)))) "abc") ;; 97 + 98 + 99 = 294 (if (= 294 total) 0 (sys-exit 24)) diff --git a/tests/scheme1/103-bv-system.scm b/tests/scheme1/103-bv-system.scm @@ -1,4 +1,4 @@ -; bytevector variadic constructor, command-line, file-exists? +; bytevector variadic constructor, argv, file-exists? ;; --- bytevector constructor ---------------------------------------- (define bv (bytevector 10 20 30 40)) @@ -9,8 +9,8 @@ (define ebv (bytevector)) (if (= 0 (bytevector-length ebv)) 0 (sys-exit 4)) -;; --- command-line returns a non-empty list ------------------------- -(define cl (command-line)) +;; --- argv returns a non-empty list --------------------------------- +(define cl (argv)) (if (pair? cl) 0 (sys-exit 5)) ;; --- file-exists? -------------------------------------------------- diff --git a/tests/scheme1/127-cond-test-only.scm b/tests/scheme1/127-cond-test-only.scm @@ -0,0 +1,4 @@ +; A successful one-expression cond clause returns its test value. +(if (= 42 (cond (#f) (42) (else 0))) 0 (sys-exit 1)) +(if (eq? 'answer (cond ('answer) (else #f))) 0 (sys-exit 2)) +(sys-exit 0) diff --git a/tests/scheme1/128-bv-copy-overlap.scm b/tests/scheme1/128-bv-copy-overlap.scm @@ -0,0 +1,10 @@ +; bytevector-copy! behaves as though the source range were copied first. +(define right (bytevector 0 1 2 3 4)) +(bytevector-copy! right 1 right 0 4) +(if (bytevector=? right (bytevector 0 0 1 2 3)) 0 (sys-exit 1)) + +(define left (bytevector 0 1 2 3 4)) +(bytevector-copy! left 0 left 1 5) +(if (bytevector=? left (bytevector 1 2 3 4 4)) 0 (sys-exit 2)) + +(sys-exit 0) diff --git a/tests/scheme1/129-set-unbound.expected b/tests/scheme1/129-set-unbound.expected @@ -0,0 +1 @@ +scheme1: set!: unbound variable diff --git a/tests/scheme1/129-set-unbound.expected-exit b/tests/scheme1/129-set-unbound.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/129-set-unbound.scm b/tests/scheme1/129-set-unbound.scm @@ -0,0 +1 @@ +(set! never-defined 1) diff --git a/tests/scheme1/130-number-radix-reject.expected b/tests/scheme1/130-number-radix-reject.expected @@ -0,0 +1 @@ +scheme1: unsupported radix diff --git a/tests/scheme1/130-number-radix-reject.expected-exit b/tests/scheme1/130-number-radix-reject.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/130-number-radix-reject.scm b/tests/scheme1/130-number-radix-reject.scm @@ -0,0 +1 @@ +(number->string 10 2) diff --git a/tests/scheme1/131-string-radix-reject.expected b/tests/scheme1/131-string-radix-reject.expected @@ -0,0 +1 @@ +scheme1: unsupported radix diff --git a/tests/scheme1/131-string-radix-reject.expected-exit b/tests/scheme1/131-string-radix-reject.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/131-string-radix-reject.scm b/tests/scheme1/131-string-radix-reject.scm @@ -0,0 +1 @@ +(string->number "10" 8) diff --git a/tests/scheme1/132-record-ctor-order.expected b/tests/scheme1/132-record-ctor-order.expected @@ -0,0 +1 @@ +scheme1: unsupported record constructor specification diff --git a/tests/scheme1/132-record-ctor-order.expected-exit b/tests/scheme1/132-record-ctor-order.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/132-record-ctor-order.scm b/tests/scheme1/132-record-ctor-order.scm @@ -0,0 +1,5 @@ +(define-record-type <bad-order> + (make-bad-order second first) + bad-order? + (first bad-order-first) + (second bad-order-second)) diff --git a/tests/scheme1/133-record-ctor-arity.expected b/tests/scheme1/133-record-ctor-arity.expected @@ -0,0 +1 @@ +scheme1: record constructor arity mismatch diff --git a/tests/scheme1/133-record-ctor-arity.expected-exit b/tests/scheme1/133-record-ctor-arity.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/133-record-ctor-arity.scm b/tests/scheme1/133-record-ctor-arity.scm @@ -0,0 +1,6 @@ +(define-record-type <point> + (make-point x y) + point? + (x point-x) + (y point-y)) +(make-point 1) diff --git a/tests/scheme1/134-overflow-source.expected b/tests/scheme1/134-overflow-source.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/134-overflow-source.expected-exit b/tests/scheme1/134-overflow-source.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/134-overflow-source.scm b/tests/scheme1/134-overflow-source.scm @@ -0,0 +1 @@ +#x1000000000000000 diff --git a/tests/scheme1/135-overflow-add.expected b/tests/scheme1/135-overflow-add.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/135-overflow-add.expected-exit b/tests/scheme1/135-overflow-add.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/135-overflow-add.scm b/tests/scheme1/135-overflow-add.scm @@ -0,0 +1 @@ +(+ #xfffffffffffffff 1) diff --git a/tests/scheme1/136-overflow-sub.expected b/tests/scheme1/136-overflow-sub.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/136-overflow-sub.expected-exit b/tests/scheme1/136-overflow-sub.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/136-overflow-sub.scm b/tests/scheme1/136-overflow-sub.scm @@ -0,0 +1 @@ +(- #x-1000000000000000 1) diff --git a/tests/scheme1/137-overflow-mul.expected b/tests/scheme1/137-overflow-mul.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/137-overflow-mul.expected-exit b/tests/scheme1/137-overflow-mul.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/137-overflow-mul.scm b/tests/scheme1/137-overflow-mul.scm @@ -0,0 +1 @@ +(* #x400000000000000 4) diff --git a/tests/scheme1/138-overflow-negate.expected b/tests/scheme1/138-overflow-negate.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/138-overflow-negate.expected-exit b/tests/scheme1/138-overflow-negate.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/138-overflow-negate.scm b/tests/scheme1/138-overflow-negate.scm @@ -0,0 +1 @@ +(- #x-1000000000000000) diff --git a/tests/scheme1/139-overflow-quotient.expected b/tests/scheme1/139-overflow-quotient.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/139-overflow-quotient.expected-exit b/tests/scheme1/139-overflow-quotient.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/139-overflow-quotient.scm b/tests/scheme1/139-overflow-quotient.scm @@ -0,0 +1 @@ +(quotient #x-1000000000000000 -1) diff --git a/tests/scheme1/140-overflow-abs.expected b/tests/scheme1/140-overflow-abs.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/140-overflow-abs.expected-exit b/tests/scheme1/140-overflow-abs.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/140-overflow-abs.scm b/tests/scheme1/140-overflow-abs.scm @@ -0,0 +1 @@ +(abs #x-1000000000000000) diff --git a/tests/scheme1/141-overflow-shift.expected b/tests/scheme1/141-overflow-shift.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/141-overflow-shift.expected-exit b/tests/scheme1/141-overflow-shift.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/141-overflow-shift.scm b/tests/scheme1/141-overflow-shift.scm @@ -0,0 +1 @@ +(arithmetic-shift 1 60) diff --git a/tests/scheme1/142-uppercase-hash-reject.expected b/tests/scheme1/142-uppercase-hash-reject.expected @@ -0,0 +1 @@ +scheme1: bad #-syntax diff --git a/tests/scheme1/142-uppercase-hash-reject.expected-exit b/tests/scheme1/142-uppercase-hash-reject.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/142-uppercase-hash-reject.scm b/tests/scheme1/142-uppercase-hash-reject.scm @@ -0,0 +1 @@ +#X2a diff --git a/tests/scheme1/143-conflicting-portq.expected b/tests/scheme1/143-conflicting-portq.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/143-conflicting-portq.expected-exit b/tests/scheme1/143-conflicting-portq.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/143-conflicting-portq.scm b/tests/scheme1/143-conflicting-portq.scm @@ -0,0 +1 @@ +(port? stdin) diff --git a/tests/scheme1/144-conflicting-read-line.expected b/tests/scheme1/144-conflicting-read-line.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/144-conflicting-read-line.expected-exit b/tests/scheme1/144-conflicting-read-line.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/144-conflicting-read-line.scm b/tests/scheme1/144-conflicting-read-line.scm @@ -0,0 +1 @@ +(read-line stdin) diff --git a/tests/scheme1/145-conflicting-write-string.expected b/tests/scheme1/145-conflicting-write-string.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/145-conflicting-write-string.expected-exit b/tests/scheme1/145-conflicting-write-string.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/145-conflicting-write-string.scm b/tests/scheme1/145-conflicting-write-string.scm @@ -0,0 +1 @@ +(write-string "x" stdout) diff --git a/tests/scheme1/146-conflicting-peek-u8.expected b/tests/scheme1/146-conflicting-peek-u8.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/146-conflicting-peek-u8.expected-exit b/tests/scheme1/146-conflicting-peek-u8.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/146-conflicting-peek-u8.scm b/tests/scheme1/146-conflicting-peek-u8.scm @@ -0,0 +1 @@ +(peek-u8 0) diff --git a/tests/scheme1/147-conflicting-exit.expected b/tests/scheme1/147-conflicting-exit.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/147-conflicting-exit.expected-exit b/tests/scheme1/147-conflicting-exit.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/147-conflicting-exit.scm b/tests/scheme1/147-conflicting-exit.scm @@ -0,0 +1 @@ +(exit 0) diff --git a/tests/scheme1/148-conflicting-command-line.expected b/tests/scheme1/148-conflicting-command-line.expected @@ -0,0 +1 @@ +scheme1: unbound variable diff --git a/tests/scheme1/148-conflicting-command-line.expected-exit b/tests/scheme1/148-conflicting-command-line.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/148-conflicting-command-line.scm b/tests/scheme1/148-conflicting-command-line.scm @@ -0,0 +1 @@ +(command-line) diff --git a/tests/scheme1/149-target-bindings.scm b/tests/scheme1/149-target-bindings.scm @@ -0,0 +1,6 @@ +(if (fd-port? stdin) 0 (sys-exit 1)) +(if (procedure? fd-read-line/result) 0 (sys-exit 2)) +(if (procedure? fd-write-string/result) 0 (sys-exit 3)) +(if (procedure? peek-memory-u8) 0 (sys-exit 4)) +(if (pair? (argv)) 0 (sys-exit 5)) +(sys-exit 0) diff --git a/tests/scheme1/150-pmatch-mixed-bytes.scm b/tests/scheme1/150-pmatch-mixed-bytes.scm @@ -0,0 +1,12 @@ +; Byte-literal pmatch is the one structural matcher widened by boot2. +(if (= 42 + (pmatch (bytevector 97 98 99) + ("abc" 42) + (else 0))) + 0 (sys-exit 1)) +(if (= 43 + (pmatch "abc" + (#u8(97 98 99) 43) + (else 0))) + 0 (sys-exit 2)) +(sys-exit 0) diff --git a/tests/scheme1/151-exact-boundaries.scm b/tests/scheme1/151-exact-boundaries.scm @@ -0,0 +1,13 @@ +; Boot2's tagged exact range is [-2^60, 2^60-1]. +(define max #xfffffffffffffff) +(define min #x-1000000000000000) +(if (= max 1152921504606846975) 0 (sys-exit 1)) +(if (= min -1152921504606846976) 0 (sys-exit 2)) +(if (= min (string->number "-1152921504606846976")) 0 (sys-exit 3)) +(if (= max (string->number "1152921504606846975")) 0 (sys-exit 4)) +(if (string=? "-1152921504606846976" (number->string min)) 0 (sys-exit 5)) +(if (string=? "-1000000000000000" (number->string min 16)) 0 (sys-exit 6)) +(if (= 0 (remainder min -1)) 0 (sys-exit 7)) +(if (= min (* #x-400000000000000 4)) 0 (sys-exit 8)) +(if (= -1 (arithmetic-shift min -1000)) 0 (sys-exit 9)) +(sys-exit 0) diff --git a/tests/scheme1/152-overflow-decimal-source.expected b/tests/scheme1/152-overflow-decimal-source.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/152-overflow-decimal-source.expected-exit b/tests/scheme1/152-overflow-decimal-source.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/152-overflow-decimal-source.scm b/tests/scheme1/152-overflow-decimal-source.scm @@ -0,0 +1 @@ +1152921504606846976 diff --git a/tests/scheme1/153-overflow-string-number.expected b/tests/scheme1/153-overflow-string-number.expected @@ -0,0 +1 @@ +scheme1: exact integer overflow diff --git a/tests/scheme1/153-overflow-string-number.expected-exit b/tests/scheme1/153-overflow-string-number.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/153-overflow-string-number.scm b/tests/scheme1/153-overflow-string-number.scm @@ -0,0 +1 @@ +(string->number "-1152921504606846977") diff --git a/tests/scheme1/154-cond-else-not-final.expected b/tests/scheme1/154-cond-else-not-final.expected @@ -0,0 +1 @@ +scheme1: cond: else clause is not final diff --git a/tests/scheme1/154-cond-else-not-final.expected-exit b/tests/scheme1/154-cond-else-not-final.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/154-cond-else-not-final.scm b/tests/scheme1/154-cond-else-not-final.scm @@ -0,0 +1 @@ +(cond (else 1) (#t 2)) diff --git a/tests/scheme1/155-closure-arity.expected b/tests/scheme1/155-closure-arity.expected @@ -0,0 +1 @@ +scheme1: wrong number of arguments diff --git a/tests/scheme1/155-closure-arity.expected-exit b/tests/scheme1/155-closure-arity.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/155-closure-arity.scm b/tests/scheme1/155-closure-arity.scm @@ -0,0 +1 @@ +((lambda (x y) x) 1) diff --git a/tests/scheme1/156-boolean-delimiter.expected b/tests/scheme1/156-boolean-delimiter.expected @@ -0,0 +1 @@ +scheme1: bad #-syntax diff --git a/tests/scheme1/156-boolean-delimiter.expected-exit b/tests/scheme1/156-boolean-delimiter.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/156-boolean-delimiter.scm b/tests/scheme1/156-boolean-delimiter.scm @@ -0,0 +1 @@ +#true diff --git a/tests/scheme1/157-char-hex-overflow.expected b/tests/scheme1/157-char-hex-overflow.expected @@ -0,0 +1 @@ +scheme1: bad #\ character literal diff --git a/tests/scheme1/157-char-hex-overflow.expected-exit b/tests/scheme1/157-char-hex-overflow.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/157-char-hex-overflow.scm b/tests/scheme1/157-char-hex-overflow.scm @@ -0,0 +1 @@ +#\x10000000000000041 diff --git a/tests/scheme1/158-string-hex-overflow.expected b/tests/scheme1/158-string-hex-overflow.expected @@ -0,0 +1 @@ +scheme1: bad string escape diff --git a/tests/scheme1/158-string-hex-overflow.expected-exit b/tests/scheme1/158-string-hex-overflow.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/158-string-hex-overflow.scm b/tests/scheme1/158-string-hex-overflow.scm @@ -0,0 +1 @@ +"\x10000000000000041;" diff --git a/tests/scheme1/159-make-bv-byte-range.expected b/tests/scheme1/159-make-bv-byte-range.expected @@ -0,0 +1 @@ +scheme1: byte value out of range diff --git a/tests/scheme1/159-make-bv-byte-range.expected-exit b/tests/scheme1/159-make-bv-byte-range.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/159-make-bv-byte-range.scm b/tests/scheme1/159-make-bv-byte-range.scm @@ -0,0 +1 @@ +(make-bytevector 1 256) diff --git a/tests/scheme1/160-bv-set-byte-range.expected b/tests/scheme1/160-bv-set-byte-range.expected @@ -0,0 +1 @@ +scheme1: byte value out of range diff --git a/tests/scheme1/160-bv-set-byte-range.expected-exit b/tests/scheme1/160-bv-set-byte-range.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/160-bv-set-byte-range.scm b/tests/scheme1/160-bv-set-byte-range.scm @@ -0,0 +1 @@ +(bytevector-u8-set! (make-bytevector 1) 0 -1) diff --git a/tests/scheme1/161-u8-byte-range.expected b/tests/scheme1/161-u8-byte-range.expected @@ -0,0 +1 @@ +scheme1: byte value out of range diff --git a/tests/scheme1/161-u8-byte-range.expected-exit b/tests/scheme1/161-u8-byte-range.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/161-u8-byte-range.scm b/tests/scheme1/161-u8-byte-range.scm @@ -0,0 +1 @@ +#u8(256) diff --git a/tests/scheme1/162-char-conversion-type.expected b/tests/scheme1/162-char-conversion-type.expected @@ -0,0 +1 @@ +scheme1: type error diff --git a/tests/scheme1/162-char-conversion-type.expected-exit b/tests/scheme1/162-char-conversion-type.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/162-char-conversion-type.scm b/tests/scheme1/162-char-conversion-type.scm @@ -0,0 +1 @@ +(char->integer 65) diff --git a/tests/scheme1/163-cond-unreachable-else.expected b/tests/scheme1/163-cond-unreachable-else.expected @@ -0,0 +1 @@ +scheme1: cond: else clause is not final diff --git a/tests/scheme1/163-cond-unreachable-else.expected-exit b/tests/scheme1/163-cond-unreachable-else.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/163-cond-unreachable-else.scm b/tests/scheme1/163-cond-unreachable-else.scm @@ -0,0 +1,5 @@ +; A non-final else is invalid even when an earlier clause would succeed. +(cond + (#t 1) + (else 2) + (#f 3)) diff --git a/tests/seed-accept.sh b/tests/seed-accept.sh @@ -155,16 +155,16 @@ trap 'rm -rf "$STAGE"' EXIT # ─── driver.scm — the in-VM acceptance program ──────────────────────── cat > "$STAGE/driver.scm" <<'SCM' ;; driver.scm — Tier-2 acceptance for seed-kernel. -(write-string stdout "scheme1: hello from acceptance driver\n") -(write-string stdout "scheme1: spawning child-prog (catm) C <- A + B\n") +(fd-write-string/result stdout "scheme1: hello from acceptance driver\n") +(fd-write-string/result stdout "scheme1: spawning child-prog (catm) C <- A + B\n") (let ((r (run "child-prog" "C" "A" "B"))) (if (car r) (begin - (write-string stdout "scheme1: child returned\n")) + (fd-write-string/result stdout "scheme1: child returned\n")) (begin - (write-string stdout "scheme1: spawn FAILED\n") - (exit 1)))) + (fd-write-string/result stdout "scheme1: spawn FAILED\n") + (sys-exit 1)))) (let ((rp (open-input "C"))) (if (car rp) @@ -172,15 +172,15 @@ cat > "$STAGE/driver.scm" <<'SCM' (rb (read-all p))) (if (car rb) (begin - (write-string stdout "scheme1: read C: [") + (fd-write-string/result stdout "scheme1: read C: [") (write-bytes stdout (cdr rb)) - (write-string stdout "]\n")) - (write-string stdout "scheme1: read C FAILED\n")) + (fd-write-string/result stdout "]\n")) + (fd-write-string/result stdout "scheme1: read C FAILED\n")) (close p)) - (write-string stdout "scheme1: open C FAILED\n"))) + (fd-write-string/result stdout "scheme1: open C FAILED\n"))) -(write-string stdout "scheme1: ALL-OK\n") -(exit 0) +(fd-write-string/result stdout "scheme1: ALL-OK\n") +(sys-exit 0) SCM # ─── Combine prelude + driver via host catm — this matches the chain's