commit a5acc123df1992ba01918c00751edb1f252fdd1d parent 9df676723aaea35b2c541a711b6219dc74a50c46 Author: Ryan Sepassi <rsepassi@gmail.com> Date: Sun, 26 Apr 2026 03:15:38 -0700 cc: switch cc-pp + cc-parse to real pipeline; uncover & fix lex/pp bug Test simplification per the post-integration review: cc-parse — drop cg-trace mock, use real cg. Fixtures already had .c sources; runner now catms full lex+pp+cg+parse through tests/cc-parse/_run-parse.scm and diffs P1pp text against new .expected-p1pp goldens. cg-trace.scm and mini-prelude.scm gone (the 256K readbuf bump made the latter unnecessary). cc-pp — drop hand-built tokens, use real lex. 21 hand-rolled .scm fixtures (01-21) replaced by .c sources fed through lex+pp via tests/cc-pp/_run-pp.scm. 22-initial-defines stays as the lone .scm — it tests pp's -D path which the driver doesn't expose. run-tests.sh — generalize cc-lex's runner shape into _cc_pipeline_suite, shared by cc-lex / cc-pp / cc-parse. Lex/pp integration bug uncovered by the new shape (mock-tested suites both passed in isolation but never met): - cc/lex.scm: line-leading `#` was emitted as `(PUNCT hash …)`, but CC-CONTRACTS §1.1 specifies `HASH` for that position and pp only dispatches on HASH. None of #define/#if/#error/#include were being recognized end-to-end. Fix: thread `bol?` through %lex-loop; emit HASH for a bare `#` at line-start (## stays as PUNCT paste). - cc/pp.scm: directive name lookup only accepted IDENT, but lex now promotes `if` and `else` to KW tokens. Fix: %pp-directive-name accepts both IDENT (bv value) and KW (symbol → bv via symbol->string). Goldens regenerated: 24 cc-pp, 15 cc-parse, plus cc-lex/07-punctuators and cc-lex/11-trigraphs (line-leading `#` now lexes as HASH). All cc-* suites pass on aarch64: cc-util 14/14 cc-lex 16/16 cc-pp 24/24 cc-cg 15/15 cc-parse 15/15 cc-e2e 1/1 Diffstat:
137 files changed, 686 insertions(+), 1317 deletions(-)
diff --git a/cc/lex.scm b/cc/lex.scm @@ -574,11 +574,14 @@ ;; lex-tokenize src file -> list of tok ending in EOF. ;; -------------------------------------------------------------------- (define (lex-tokenize src file) - (%lex-loop src 0 1 1 file '())) - -(define (%lex-loop src pos line col file acc) - ;; Skip non-newline whitespace + comments first, then dispatch on - ;; the next logical byte. + (%lex-loop src 0 1 1 file '() #t)) + +;; bol? — `#t` when no token has been emitted on the current physical +;; line yet (start of file, or only NL + whitespace seen since the last +;; line break). pp recognizes a directive only when its leading `#` is +;; at line-start; we forward that decision into the token stream by +;; emitting `HASH` instead of `(PUNCT hash …)` for a line-leading `#`. +(define (%lex-loop src pos line col file acc bol?) (let* ((sw (%skip-ws-and-comments src pos line col file)) (pos1 (car sw)) (line1 (car (cdr sw))) @@ -590,11 +593,29 @@ ((not b) (let* ((eof-tok (make-tok 'EOF #f (%loc file line1 col1)))) (reverse (cons eof-tok acc)))) - ;; Newline → emit NL, keep going. + ;; Newline → emit NL, reset bol?. ((%newline? b) (let ((nl (make-tok 'NL #f (%loc file line1 col1)))) (%lex-loop src (%pk-pos p) (%pk-line p) (%pk-col p) - file (cons nl acc)))) + file (cons nl acc) #t))) + ;; Line-leading `#` → emit HASH, but only the bare `#`. `##` is + ;; never line-leading in valid C; if it appears, fall through to + ;; normal punctuator handling so it lexes as `paste`. + ((and bol? (= b 35)) + (let* ((q (%lex-peek src (%pk-pos p) (%pk-line p) (%pk-col p))) + (b2 (%pk-byte q))) + (cond + ((and b2 (= b2 35)) + (let* ((r (%lex-read-punct src pos1 line1 col1 file)) + (tok (car r)) + (npos (car (cdr r))) + (nline (car (cdr (cdr r)))) + (ncol (car (cdr (cdr (cdr r)))))) + (%lex-loop src npos nline ncol file (cons tok acc) #f))) + (else + (let ((tok (make-tok 'HASH #f (%loc file line1 col1)))) + (%lex-loop src (%pk-pos p) (%pk-line p) (%pk-col p) + file (cons tok acc) #f)))))) ;; Identifier / keyword ((%ident-start? b) (let* ((r (%lex-read-ident src pos1 line1 col1 file)) @@ -602,7 +623,7 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc)))) + (%lex-loop src npos nline ncol file (cons tok acc) #f))) ;; Number (digit start) ((%digit? b) (let* ((r (%lex-read-number src pos1 line1 col1 file)) @@ -610,7 +631,7 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc)))) + (%lex-loop src npos nline ncol file (cons tok acc) #f))) ;; '.' might start a number (1.0 actually starts with digit; .5 ;; would route here). We keep this as a punctuator unless followed ;; by a digit, in which case the lexer rejects per spec. @@ -626,7 +647,7 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc))))))) + (%lex-loop src npos nline ncol file (cons tok acc) #f)))))) ;; String ((= b 34) (let* ((r (%lex-read-string src pos1 line1 col1 file)) @@ -634,7 +655,7 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc)))) + (%lex-loop src npos nline ncol file (cons tok acc) #f))) ;; Char ((= b 39) (let* ((r (%lex-read-char src pos1 line1 col1 file)) @@ -642,7 +663,7 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc)))) + (%lex-loop src npos nline ncol file (cons tok acc) #f))) ;; Punctuator (default) (else (let* ((r (%lex-read-punct src pos1 line1 col1 file)) @@ -650,4 +671,4 @@ (npos (car (cdr r))) (nline (car (cdr (cdr r)))) (ncol (car (cdr (cdr (cdr r)))))) - (%lex-loop src npos nline ncol file (cons tok acc))))))) + (%lex-loop src npos nline ncol file (cons tok acc) #f)))))) diff --git a/cc/pp.scm b/cc/pp.scm @@ -135,12 +135,20 @@ ;; --- directive dispatch --- ;; pmatch-based on the directive name bv. bv literals match by equal?. +;; 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). +(define (%pp-directive-name t) + (cond ((eq? (tok-kind t) 'IDENT) (tok-value t)) + ((eq? (tok-kind t) 'KW) (symbol->string (tok-value t))) + (else #f))) + (define (%pp-dispatch-directive hash-tok line state out) (let ((line (%pp-skip-ws line))) (cond ((null? line) #t) ; bare `#` line — null directive - ((%pp-ident? (car line)) - (let ((name (tok-value (car line))) + ((%pp-directive-name (car line)) + (let ((name (%pp-directive-name (car line))) (rest (cdr line)) (loc (tok-loc (car line)))) (pmatch name diff --git a/scripts/run-tests.sh b/scripts/run-tests.sh @@ -292,8 +292,8 @@ run_scheme1_suite() { ## toolchain (m1pp + tools), which the Make deps already cover. ## ## Filenames starting with `_` are skipped by `discover()` — that's how -## suite-internal driver and mock files (_run-lex.scm, _cg-trace.scm, -## _mini-prelude.scm, _run-pp.scm) avoid being picked up as fixtures. +## suite-internal driver files (_run-lex.scm, _run-pp.scm, +## _run-parse.scm) avoid being picked up as fixtures. # _cc_check <label> <expected-stdout> <expected-exit> <actual-stdout> <actual-exit> _cc_check() { @@ -357,52 +357,32 @@ run_cc_util_suite() { _cc_unit_suite cc-util expected "scheme1/prelude.scm cc/util.scm" } -# cc-pp: prelude + util + data + pp. -run_cc_pp_suite() { - _cc_unit_suite cc-pp expected \ - "scheme1/prelude.scm cc/util.scm cc/data.scm cc/pp.scm" -} - -# cc-cg: prelude + util + data + cg. -run_cc_cg_suite() { - _cc_unit_suite cc-cg expected \ - "scheme1/prelude.scm cc/util.scm cc/data.scm cc/cg.scm" -} - -# cc-parse: mini-prelude + util + data + cg-trace mock + parse. -# (Full prelude+everything would push past scheme1's source-buffer cap -# — see CC-INTERNALS.md and the project memory note.) -run_cc_parse_suite() { - _cc_unit_suite cc-parse expected-trace \ - "tests/cc-parse/_mini-prelude.scm cc/util.scm cc/data.scm tests/cc-parse/_cg-trace.scm cc/parse.scm" -} - -# cc-lex: needs the _run-lex.scm driver + the .c fixture as scheme1 argv. -# Expected file is .expected-toks; `;;` lines are stripped (negative -# fixtures use them for human notes). -run_cc_lex_suite() { - [ -n "$NAMES" ] || NAMES=$(discover tests/cc-lex c) - layers="scheme1/prelude.scm cc/util.scm cc/data.scm cc/lex.scm tests/cc-lex/_run-lex.scm" +# _cc_pipeline_suite <suite-name> <expected-ext> <layers> +# Generic pipeline runner for cc-lex / cc-pp / cc-parse. +# Each fixture is tests/<suite>/<name>.c. `<layers>` ends with the +# suite-specific _run-<phase>.scm driver, which the test runner passes +# the fixture path to as argv[2]. Expected stdout in +# tests/<suite>/<name>.<expected-ext> ("|| true" filters the negative- +# fixture `;;` notes); exit in <name>.expected-exit (default 0). +# Negative fixtures (expected-exit != 0) only check the exit code. +_cc_pipeline_suite() { + suite=$1; ext=$2; layers=$3 + [ -n "$NAMES" ] || NAMES=$(discover tests/$suite c) for arch in $(_cc_arches); do for name in $NAMES; do - fixture=tests/cc-lex/$name.c + fixture=tests/$suite/$name.c [ -e "$fixture" ] || { echo " SKIP $name (no .c)"; continue; } - if [ -e "tests/cc-lex/$name.expected-toks" ]; then - # `|| true` because grep returns 1 when zero lines match - # (negative-test fixtures have only ;; comments). - expout=$(grep -v '^;;' "tests/cc-lex/$name.expected-toks" || true) + if [ -e "tests/$suite/$name.$ext" ]; then + expout=$(grep -v '^;;' "tests/$suite/$name.$ext" || true) else expout= fi - if [ -e "tests/cc-lex/$name.expected-exit" ]; then - expexit=$(cat "tests/cc-lex/$name.expected-exit") + if [ -e "tests/$suite/$name.expected-exit" ]; then + expexit=$(cat "tests/$suite/$name.expected-exit") else expexit=0 fi tmp=$(mktemp) - # Negative fixtures (expected-exit != 0) write diagnostics to - # stderr; we don't compare their output, only exit code. - # The merged stdout+stderr capture is uniform either way. if run_in_container "$arch" sh -c " build/$arch/tools/catm /tmp/cc-test.scm $layers exec build/$arch/scheme1 /tmp/cc-test.scm $fixture @@ -417,11 +397,43 @@ run_cc_lex_suite() { act_out=$(cat "$tmp") fi rm -f "$tmp" - _cc_check "[$arch] cc-lex/$name" "$expout" "$expexit" "$act_out" "$act_exit" + _cc_check "[$arch] $suite/$name" "$expout" "$expexit" "$act_out" "$act_exit" done done } +# cc-lex: prelude + util + data + lex + run-lex driver. +run_cc_lex_suite() { + _cc_pipeline_suite cc-lex expected-toks \ + "scheme1/prelude.scm cc/util.scm cc/data.scm cc/lex.scm tests/cc-lex/_run-lex.scm" +} + +# cc-pp: prelude + util + data + lex + pp + run-pp driver. +# Two passes: .c fixtures via the pipeline (real lex+pp); the lone .scm +# fixture (22-initial-defines) covers the -D mechanism the driver doesn't +# expose, so it stays on the unit-suite path. +run_cc_pp_suite() { + saved=$NAMES + NAMES=$saved + _cc_pipeline_suite cc-pp expected-toks \ + "scheme1/prelude.scm cc/util.scm cc/data.scm cc/lex.scm cc/pp.scm tests/cc-pp/_run-pp.scm" + NAMES=$saved + _cc_unit_suite cc-pp expected \ + "scheme1/prelude.scm cc/util.scm cc/data.scm cc/pp.scm" +} + +# cc-cg: prelude + util + data + cg. Direct cg API exercises in .scm. +run_cc_cg_suite() { + _cc_unit_suite cc-cg expected \ + "scheme1/prelude.scm cc/util.scm cc/data.scm cc/cg.scm" +} + +# cc-parse: full pipeline through real cg, P1pp text golden. +run_cc_parse_suite() { + _cc_pipeline_suite cc-parse expected-p1pp \ + "scheme1/prelude.scm cc/util.scm cc/data.scm cc/lex.scm cc/pp.scm cc/cg.scm cc/parse.scm tests/cc-parse/_run-parse.scm" +} + # cc-e2e: compile a .c through cc, assemble to ELF, run. # Fixture: <name>.c; expected stdout in <name>.expected (default empty); # exit in <name>.expected-exit (default 0). diff --git a/tests/cc-lex/07-punctuators.expected-toks b/tests/cc-lex/07-punctuators.expected-toks @@ -46,7 +46,7 @@ (PUNCT shl-eq "07-punctuators.c" 2 81) (PUNCT shr-eq "07-punctuators.c" 2 85) (NL #f "07-punctuators.c" 2 88) -(PUNCT hash "07-punctuators.c" 3 1) +(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) diff --git a/tests/cc-lex/11-trigraphs.expected-toks b/tests/cc-lex/11-trigraphs.expected-toks @@ -1,4 +1,4 @@ -(PUNCT hash "11-trigraphs.c" 1 1) +(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) diff --git a/tests/cc-parse/00-empty-main.expected-p1pp b/tests/cc-parse/00-empty-main.expected-p1pp @@ -0,0 +1,15 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 16, { +%li(a0, 0) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/00-empty-main.expected-trace b/tests/cc-parse/00-empty-main.expected-trace @@ -1,5 +0,0 @@ -(fn-begin "main" () i32) -(push-imm i32 0) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/00-empty-main.scm b/tests/cc-parse/00-empty-main.scm @@ -1,27 +0,0 @@ -;; tests/cc-parse/00-empty-main.scm — driver for 00-empty-main.c. -;; -;; Hand-builds the tokens for: int main(void) { return 0; } -;; Runs parse-translation-unit against the cg-trace mock and prints -;; the trace. The expected-trace golden is diffed by the runner. - -(define %loc0 (%loc "00-empty-main.c" 1 1)) -(define (mk k v) (make-tok k v %loc0)) - -(define %toks - (list - (mk 'KW 'int) - (mk 'IDENT "main") - (mk 'PUNCT 'lparen) - (mk 'KW 'void) - (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'INT 0) - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) - (mk 'EOF #f))) - -(let ((cg (cg-init))) - (let ((ps (make-pstate %toks cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/01-return-argc.expected-p1pp b/tests/cc-parse/01-return-argc.expected-p1pp @@ -0,0 +1,19 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 32, { +%st(a0, sp, (+ %main__SO 8)) +%st(a1, sp, (+ %main__SO 16)) +%ld(t0, sp, (+ %main__SO 8)) +%st(t0, sp, (+ %main__SO 24)) +%ld(a0, sp, (+ %main__SO 24)) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/01-return-argc.expected-trace b/tests/cc-parse/01-return-argc.expected-trace @@ -1,6 +0,0 @@ -(fn-begin "main" (("argc" i32) ("argv" (ptr (ptr i8)))) i32) -(push-sym ("argc" param)) -(load) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/01-return-argc.scm b/tests/cc-parse/01-return-argc.scm @@ -1,17 +0,0 @@ -;; int main(int argc, char **argv) { return argc; } -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "main") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "argc") (mk 'PUNCT 'comma) - (mk 'KW 'char) (mk 'PUNCT 'star) (mk 'PUNCT 'star) - (mk 'IDENT "argv") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) (mk 'IDENT "argc") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/02-add-const.expected-p1pp b/tests/cc-parse/02-add-const.expected-p1pp @@ -0,0 +1,19 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 16, { +%li(a0, 1) +%li(a1, 2) +%add(t0, a0, a1) +%st(t0, sp, (+ %main__SO 8)) +%ld(a0, sp, (+ %main__SO 8)) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/02-add-const.expected-trace b/tests/cc-parse/02-add-const.expected-trace @@ -1,10 +0,0 @@ -(fn-begin "main" () i32) -(push-imm i32 1) -(promote) -(push-imm i32 2) -(promote) -(arith-conv) -(binop add) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/02-add-const.scm b/tests/cc-parse/02-add-const.scm @@ -1,15 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "main") - (mk 'PUNCT 'lparen) (mk 'KW 'void) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'INT 1) (mk 'PUNCT 'plus) (mk 'INT 2) - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/03-local-assign.expected-p1pp b/tests/cc-parse/03-local-assign.expected-p1pp @@ -0,0 +1,20 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 32, { +%li(a0, 5) +%st(a0, sp, (+ %main__SO 8)) +%st(a0, sp, (+ %main__SO 16)) +%ld(t0, sp, (+ %main__SO 8)) +%st(t0, sp, (+ %main__SO 24)) +%ld(a0, sp, (+ %main__SO 24)) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/03-local-assign.expected-trace b/tests/cc-parse/03-local-assign.expected-trace @@ -1,10 +0,0 @@ -(fn-begin "main" () i32) -(alloc-slot 4 4 0) -(push-sym ("x" var)) -(push-imm i32 5) -(assign) -(push-sym ("x" var)) -(load) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/03-local-assign.scm b/tests/cc-parse/03-local-assign.scm @@ -1,16 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "main") - (mk 'PUNCT 'lparen) (mk 'KW 'void) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'int) (mk 'IDENT "x") (mk 'PUNCT 'semi) - (mk 'IDENT "x") (mk 'PUNCT 'assign) (mk 'INT 5) - (mk 'PUNCT 'semi) - (mk 'KW 'return) (mk 'IDENT "x") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/04-if-else.expected-p1pp b/tests/cc-parse/04-if-else.expected-p1pp @@ -0,0 +1,25 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 32, { +%st(a0, sp, (+ %f__SO 8)) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(t0, sp, (+ %f__SO 16)) +%ifelse_nez(t0, { +%li(a0, 1) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +}, { +%li(a0, 0) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +}) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/04-if-else.expected-trace b/tests/cc-parse/04-if-else.expected-trace @@ -1,13 +0,0 @@ -(fn-begin "f" (("x" i32)) i32) -(push-sym ("x" param)) -(load) -(ifelse-begin) -(push-imm i32 1) -(cast i32) -(return) -(ifelse-mid) -(push-imm i32 0) -(cast i32) -(return) -(ifelse-end) -(fn-end) diff --git a/tests/cc-parse/04-if-else.scm b/tests/cc-parse/04-if-else.scm @@ -1,18 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "x") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'if) (mk 'PUNCT 'lparen) (mk 'IDENT "x") - (mk 'PUNCT 'rparen) - (mk 'KW 'return) (mk 'INT 1) (mk 'PUNCT 'semi) - (mk 'KW 'else) - (mk 'KW 'return) (mk 'INT 0) (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/05-while-break.expected-p1pp b/tests/cc-parse/05-while-break.expected-p1pp @@ -0,0 +1,25 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 32, { +%st(a0, sp, (+ %f__SO 8)) +%loop_tag(L0, { +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(t0, sp, (+ %f__SO 16)) +%if_eqz(t0, { %break(L0) }) +%break(L0) +}) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 24)) +%ld(a0, sp, (+ %f__SO 24)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/05-while-break.expected-trace b/tests/cc-parse/05-while-break.expected-trace @@ -1,11 +0,0 @@ -(fn-begin "f" (("x" i32)) i32) -(loop-begin) -(push-sym ("x" param)) -(load) -(break "L0") -(loop-end) -(push-sym ("x" param)) -(load) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/05-while-break.scm b/tests/cc-parse/05-while-break.scm @@ -1,19 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "x") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'while) (mk 'PUNCT 'lparen) (mk 'IDENT "x") - (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'break) (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) - (mk 'KW 'return) (mk 'IDENT "x") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/06-call-no-args.expected-p1pp b/tests/cc-parse/06-call-no-args.expected-p1pp @@ -0,0 +1,17 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 16, { +%call(&cc__g) +%st(a0, sp, (+ %main__SO 8)) +%ld(a0, sp, (+ %main__SO 8)) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/06-call-no-args.expected-trace b/tests/cc-parse/06-call-no-args.expected-trace @@ -1,6 +0,0 @@ -(fn-begin "main" () i32) -(push-sym ("g" fn)) -(call 0 #t) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/06-call-no-args.scm b/tests/cc-parse/06-call-no-args.scm @@ -1,18 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "g") - (mk 'PUNCT 'lparen) (mk 'KW 'void) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'semi) - (mk 'KW 'int) (mk 'IDENT "main") - (mk 'PUNCT 'lparen) (mk 'KW 'void) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) (mk 'IDENT "g") - (mk 'PUNCT 'lparen) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/07-call-with-args.expected-p1pp b/tests/cc-parse/07-call-with-args.expected-p1pp @@ -0,0 +1,19 @@ +%macro main__SO() +0 +%endm +%fn(cc__main, 16, { +%li(a0, 1) +%li(a1, 2) +%call(&cc__g) +%st(a0, sp, (+ %main__SO 8)) +%ld(a0, sp, (+ %main__SO 8)) +%st(a0, sp, (+ %main__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %main__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/07-call-with-args.expected-trace b/tests/cc-parse/07-call-with-args.expected-trace @@ -1,8 +0,0 @@ -(fn-begin "main" () i32) -(push-sym ("g" fn)) -(push-imm i32 1) -(push-imm i32 2) -(call 2 #t) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/07-call-with-args.scm b/tests/cc-parse/07-call-with-args.scm @@ -1,19 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "g") - (mk 'PUNCT 'lparen) (mk 'KW 'int) (mk 'PUNCT 'comma) - (mk 'KW 'int) (mk 'PUNCT 'rparen) (mk 'PUNCT 'semi) - (mk 'KW 'int) (mk 'IDENT "main") - (mk 'PUNCT 'lparen) (mk 'KW 'void) (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) (mk 'IDENT "g") - (mk 'PUNCT 'lparen) - (mk 'INT 1) (mk 'PUNCT 'comma) (mk 'INT 2) - (mk 'PUNCT 'rparen) (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/08-pointer-deref.expected-p1pp b/tests/cc-parse/08-pointer-deref.expected-p1pp @@ -0,0 +1,23 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 48, { +%st(a0, sp, (+ %f__SO 8)) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(t0, sp, (+ %f__SO 16)) +%st(t0, sp, (+ %f__SO 24)) +%ld(t0, sp, (+ %f__SO 24)) +%ld(t0, t0, 0) +%st(t0, sp, (+ %f__SO 32)) +%ld(a0, sp, (+ %f__SO 32)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/08-pointer-deref.expected-trace b/tests/cc-parse/08-pointer-deref.expected-trace @@ -1,8 +0,0 @@ -(fn-begin "f" (("p" (ptr i32))) i32) -(push-sym ("p" param)) -(load) -(push-deref) -(load) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/08-pointer-deref.scm b/tests/cc-parse/08-pointer-deref.scm @@ -1,16 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'PUNCT 'star) (mk 'IDENT "p") - (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'PUNCT 'star) (mk 'IDENT "p") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/09-address-of.expected-p1pp b/tests/cc-parse/09-address-of.expected-p1pp @@ -0,0 +1,19 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 32, { +%st(a0, sp, (+ %f__SO 8)) +%mov(t0, sp) +%addi(t0, t0, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(a0, sp, (+ %f__SO 16)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/09-address-of.expected-trace b/tests/cc-parse/09-address-of.expected-trace @@ -1,6 +0,0 @@ -(fn-begin "f" (("x" i32)) (ptr i32)) -(push-sym ("x" param)) -(take-addr) -(cast (ptr i32)) -(return) -(fn-end) diff --git a/tests/cc-parse/09-address-of.scm b/tests/cc-parse/09-address-of.scm @@ -1,15 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'PUNCT 'star) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "x") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'PUNCT 'amp) (mk 'IDENT "x") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/10-typedef.expected-p1pp b/tests/cc-parse/10-typedef.expected-p1pp @@ -0,0 +1,18 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 32, { +%st(a0, sp, (+ %f__SO 8)) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(a0, sp, (+ %f__SO 16)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/10-typedef.expected-trace b/tests/cc-parse/10-typedef.expected-trace @@ -1,6 +0,0 @@ -(fn-begin "f" (("x" i32)) i32) -(push-sym ("x" param)) -(load) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/10-typedef.scm b/tests/cc-parse/10-typedef.scm @@ -1,16 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'typedef) (mk 'KW 'int) (mk 'IDENT "myint") - (mk 'PUNCT 'semi) - (mk 'IDENT "myint") (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'IDENT "myint") (mk 'IDENT "x") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) (mk 'IDENT "x") (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/11-two-params.expected-p1pp b/tests/cc-parse/11-two-params.expected-p1pp @@ -0,0 +1,25 @@ +%macro add__SO() +0 +%endm +%fn(cc__add, 48, { +%st(a0, sp, (+ %add__SO 8)) +%st(a1, sp, (+ %add__SO 16)) +%ld(t0, sp, (+ %add__SO 8)) +%st(t0, sp, (+ %add__SO 24)) +%ld(t0, sp, (+ %add__SO 16)) +%st(t0, sp, (+ %add__SO 32)) +%ld(a0, sp, (+ %add__SO 24)) +%ld(a1, sp, (+ %add__SO 32)) +%add(t0, a0, a1) +%st(t0, sp, (+ %add__SO 40)) +%ld(a0, sp, (+ %add__SO 40)) +%st(a0, sp, (+ %add__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %add__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/11-two-params.expected-trace b/tests/cc-parse/11-two-params.expected-trace @@ -1,12 +0,0 @@ -(fn-begin "add" (("a" i32) ("b" i32)) i32) -(push-sym ("a" param)) -(load) -(promote) -(push-sym ("b" param)) -(load) -(promote) -(arith-conv) -(binop add) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/11-two-params.scm b/tests/cc-parse/11-two-params.scm @@ -1,17 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "add") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "a") (mk 'PUNCT 'comma) - (mk 'KW 'int) (mk 'IDENT "b") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'IDENT "a") (mk 'PUNCT 'plus) (mk 'IDENT "b") - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/12-comparison.expected-p1pp b/tests/cc-parse/12-comparison.expected-p1pp @@ -0,0 +1,25 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 48, { +%st(a0, sp, (+ %f__SO 8)) +%st(a1, sp, (+ %f__SO 16)) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 24)) +%ld(t0, sp, (+ %f__SO 16)) +%st(t0, sp, (+ %f__SO 32)) +%ld(a0, sp, (+ %f__SO 24)) +%ld(a1, sp, (+ %f__SO 32)) +%ifelse_lt(a0, a1, { %li(t0, 1) }, { %li(t0, 0) }) +%st(t0, sp, (+ %f__SO 40)) +%ld(a0, sp, (+ %f__SO 40)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/12-comparison.expected-trace b/tests/cc-parse/12-comparison.expected-trace @@ -1,12 +0,0 @@ -(fn-begin "f" (("a" i32) ("b" i32)) i32) -(push-sym ("a" param)) -(load) -(promote) -(push-sym ("b" param)) -(load) -(promote) -(arith-conv) -(binop lt) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/12-comparison.scm b/tests/cc-parse/12-comparison.scm @@ -1,17 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "a") (mk 'PUNCT 'comma) - (mk 'KW 'int) (mk 'IDENT "b") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'IDENT "a") (mk 'PUNCT 'lt) (mk 'IDENT "b") - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/13-while-continue.expected-p1pp b/tests/cc-parse/13-while-continue.expected-p1pp @@ -0,0 +1,23 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 32, { +%st(a0, sp, (+ %f__SO 8)) +%loop_tag(L0, { +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 16)) +%ld(t0, sp, (+ %f__SO 16)) +%if_eqz(t0, { %break(L0) }) +%continue(L0) +}) +%li(a0, 0) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/13-while-continue.expected-trace b/tests/cc-parse/13-while-continue.expected-trace @@ -1,10 +0,0 @@ -(fn-begin "f" (("x" i32)) i32) -(loop-begin) -(push-sym ("x" param)) -(load) -(continue "L0") -(loop-end) -(push-imm i32 0) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/13-while-continue.scm b/tests/cc-parse/13-while-continue.scm @@ -1,19 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "x") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'while) (mk 'PUNCT 'lparen) (mk 'IDENT "x") - (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'continue) (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) - (mk 'KW 'return) (mk 'INT 0) (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/14-mul-paren.expected-p1pp b/tests/cc-parse/14-mul-paren.expected-p1pp @@ -0,0 +1,32 @@ +%macro f__SO() +0 +%endm +%fn(cc__f, 80, { +%st(a0, sp, (+ %f__SO 8)) +%st(a1, sp, (+ %f__SO 16)) +%st(a2, sp, (+ %f__SO 24)) +%ld(t0, sp, (+ %f__SO 8)) +%st(t0, sp, (+ %f__SO 32)) +%ld(t0, sp, (+ %f__SO 16)) +%st(t0, sp, (+ %f__SO 40)) +%ld(t0, sp, (+ %f__SO 24)) +%st(t0, sp, (+ %f__SO 48)) +%ld(a0, sp, (+ %f__SO 40)) +%ld(a1, sp, (+ %f__SO 48)) +%add(t0, a0, a1) +%st(t0, sp, (+ %f__SO 56)) +%ld(a0, sp, (+ %f__SO 32)) +%ld(a1, sp, (+ %f__SO 56)) +%mul(t0, a0, a1) +%st(t0, sp, (+ %f__SO 64)) +%ld(a0, sp, (+ %f__SO 64)) +%st(a0, sp, (+ %f__SO 0)) +%b(&::ret) +::ret +%ld(a0, sp, (+ %f__SO 0)) +}) +# entry stub +%fn(p1_main, 16, { +%call(&cc__main) +}) +:ELF_end diff --git a/tests/cc-parse/14-mul-paren.expected-trace b/tests/cc-parse/14-mul-paren.expected-trace @@ -1,18 +0,0 @@ -(fn-begin "f" (("a" i32) ("b" i32) ("c" i32)) i32) -(push-sym ("a" param)) -(load) -(promote) -(push-sym ("b" param)) -(load) -(promote) -(push-sym ("c" param)) -(load) -(promote) -(arith-conv) -(binop add) -(promote) -(arith-conv) -(binop mul) -(cast i32) -(return) -(fn-end) diff --git a/tests/cc-parse/14-mul-paren.scm b/tests/cc-parse/14-mul-paren.scm @@ -1,21 +0,0 @@ -(define %L (%loc "x" 1 1)) -(define (mk k v) (make-tok k v %L)) - -(let ((cg (cg-init))) - (let ((ps (make-pstate - (list (mk 'KW 'int) (mk 'IDENT "f") - (mk 'PUNCT 'lparen) - (mk 'KW 'int) (mk 'IDENT "a") (mk 'PUNCT 'comma) - (mk 'KW 'int) (mk 'IDENT "b") (mk 'PUNCT 'comma) - (mk 'KW 'int) (mk 'IDENT "c") (mk 'PUNCT 'rparen) - (mk 'PUNCT 'lbrace) - (mk 'KW 'return) - (mk 'IDENT "a") (mk 'PUNCT 'star) - (mk 'PUNCT 'lparen) - (mk 'IDENT "b") (mk 'PUNCT 'plus) (mk 'IDENT "c") - (mk 'PUNCT 'rparen) - (mk 'PUNCT 'semi) - (mk 'PUNCT 'rbrace) (mk 'EOF #f)) - cg))) - (parse-translation-unit ps) - (cg-trace-print))) diff --git a/tests/cc-parse/_cg-trace.scm b/tests/cc-parse/_cg-trace.scm @@ -1,171 +0,0 @@ -;; tests/cc-parse/cg-trace.scm — swap-in mock for cc/cg.scm. -;; Provides every public cg-* entry point parse.scm calls; each call -;; appends a record to %cg-trace. Format follows CC-CONTRACTS §2.2. -;; cg-trace-print writes one Scheme list per line to fd 1. - -(define %cg-trace '()) -(define (%cg-emit! e) (set! %cg-trace (cons e %cg-trace))) -(define (cg-trace-get) (reverse %cg-trace)) - -(define (%render-ctype t) - (if (not t) 'NIL - (let ((k (ctype-kind t))) - (cond - ((eq? k 'ptr) (list 'ptr (%render-ctype (ctype-ext t)))) - ((eq? k 'arr) - (let ((e (ctype-ext t))) - (list 'arr (%render-ctype (car e)) - (if (< (cdr e) 0) '* (cdr e))))) - ((eq? k 'fn) - (let ((e (ctype-ext t))) - (list 'fn (%render-ctype (car e)) - (map %render-ctype (cadr e)) - (car (cddr e))))) - ((eq? k 'struct) (list 'struct (car (ctype-ext t)))) - ((eq? k 'union) (list 'union (car (ctype-ext t)))) - ((eq? k 'enum) (list 'enum (car (ctype-ext t)))) - (else k))))) - -(define (%render-sym s) (list (sym-name s) (sym-kind s))) - -(define (%fake-opnd t lv?) (%opnd 'frame (if t t %t-i32) 0 lv?)) - -(define %cg-stack '()) -(define (%push o) (set! %cg-stack (cons o %cg-stack)) o) -(define (%pop) - (cond ((null? %cg-stack) (%fake-opnd %t-i32 #f)) - (else (let ((o (car %cg-stack))) - (set! %cg-stack (cdr %cg-stack)) o)))) -(define (%top) - (cond ((null? %cg-stack) #f) (else (car %cg-stack)))) - -(define (cg-init) (set! %cg-trace '()) (set! %cg-stack '()) 'mock-cg) -(define (cg-finish cg) (%cg-emit! '(finish)) "") - -(define (cg-fn-begin cg name params return-type) - (let ((rp (map (lambda (p) (list (car p) (%render-ctype (cdr p)))) - params))) - (%cg-emit! (list 'fn-begin name rp (%render-ctype return-type)))) - (let loop ((ps params) (i 0) (acc '())) - (if (null? ps) (reverse acc) - (loop (cdr ps) (+ i 1) - (cons (cons (car (car ps)) - (%sym (car (car ps)) 'param 'auto - (cdr (car ps)) (* i 8))) - acc))))) - -(define (cg-fn-end cg) (%cg-emit! '(fn-end)) #t) - -(define (cg-push cg op) (%push op)) -(define (cg-pop cg) (%pop)) -(define (cg-top cg) (%top)) -(define (cg-depth cg) (length %cg-stack)) - -(define (cg-push-imm cg ct v) - (%cg-emit! (list 'push-imm (%render-ctype ct) v)) - (%push (%fake-opnd ct #f))) -(define (cg-push-string cg b) - (%cg-emit! (list 'push-string b)) - (%push (%fake-opnd %t-i64 #f))) -(define (cg-push-sym cg s) - (%cg-emit! (list 'push-sym (%render-sym s))) - (%push (%fake-opnd (sym-type s) - (if (or (eq? (sym-kind s) 'fn) - (eq? (sym-kind s) 'enum-const)) #f #t)))) -(define (cg-push-deref cg) - (%cg-emit! '(push-deref)) - (%pop) (%push (%fake-opnd %t-i32 #t))) - -(define (cg-take-addr cg) - (%cg-emit! '(take-addr)) - (%pop) (%push (%fake-opnd %t-i64 #f))) -(define (cg-load cg) - (%cg-emit! '(load)) - (let ((o (%pop))) - (%push (%fake-opnd (opnd-type o) #f)))) - -(define (cg-cast cg ty) - (%cg-emit! (list 'cast (%render-ctype ty))) - (%pop) (%push (%fake-opnd ty #f))) -(define (cg-promote cg) - (%cg-emit! '(promote)) - (%pop) (%push (%fake-opnd %t-i32 #f))) -(define (cg-arith-conv cg) (%cg-emit! '(arith-conv)) #t) - -(define (cg-binop cg op) - (%cg-emit! (list 'binop op)) - (%pop) (%pop) (%push (%fake-opnd %t-i32 #f))) -(define (cg-unop cg op) - (%cg-emit! (list 'unop op)) - (%pop) (%push (%fake-opnd %t-i32 #f))) -(define (cg-assign cg) - (%cg-emit! '(assign)) - (%pop) (%pop) (%push (%fake-opnd %t-i32 #f))) - -(define (cg-call cg arity has-result?) - (%cg-emit! (list 'call arity has-result?)) - (let lp ((n (+ arity 1))) - (cond ((zero? n) #t) (else (%pop) (lp (- n 1))))) - (cond (has-result? (%push (%fake-opnd %t-i32 #f))) - (else #f))) -(define (cg-return cg) (%cg-emit! '(return)) (%pop) #t) - -(define (cg-if cg th) - (%cg-emit! '(if-begin)) (th) (%cg-emit! '(if-end)) #t) -(define (cg-ifelse cg th eh) - (%cg-emit! '(ifelse-begin)) (th) - (%cg-emit! '(ifelse-mid)) (eh) - (%cg-emit! '(ifelse-end)) #t) - -;; Mock-cg's loop tag counter mirrors real cg's `%cg-fresh-loop-tag` — -;; a fresh `Lk` per cg-loop / cg-switch-begin call. body receives the -;; tag (CC-CONTRACTS §3.3). -(define %mock-loop-namer (make-namer "L")) -(define (cg-loop cg head body) - (let ((tag (%mock-loop-namer))) - (%cg-emit! '(loop-begin)) - (head) (body tag) - (%cg-emit! '(loop-end)) - tag)) -(define (cg-loop-end cg tag) (%cg-emit! (list 'loop-close tag)) #t) -(define (cg-break cg tag) (%cg-emit! (list 'break tag)) #t) -(define (cg-continue cg tag) (%cg-emit! (list 'continue tag)) #t) - -;; Switch returns a swctx record so parse can read swctx-end-tag. -;; We import the real record def from cg.scm? No — cg.scm isn't -;; loaded under the trace mock. Recreate a minimal compatible record -;; here under the same name. -(define-record-type swctx - (%swctx ctrl-slot end-tag default-lbl) - swctx? - (ctrl-slot swctx-ctrl-slot) - (end-tag swctx-end-tag) - (default-lbl swctx-default-lbl swctx-default-lbl-set!)) - -(define (cg-switch-begin cg) - (%cg-emit! '(switch-begin)) - (%swctx 0 (%mock-loop-namer) #f)) -(define (cg-switch-case cg sw v) (%cg-emit! (list 'switch-case v)) #t) -(define (cg-switch-default cg sw) (%cg-emit! '(switch-default)) #t) -(define (cg-switch-end cg sw) (%cg-emit! '(switch-end)) #t) - -(define (cg-emit-global cg s init) - (%cg-emit! (list 'emit-global (%render-sym s) init)) #t) -(define (cg-emit-extern cg s) - (%cg-emit! (list 'emit-extern (%render-sym s))) #t) -(define (cg-intern-string cg b) - (%cg-emit! (list 'intern-string b)) b) - -(define %frame-hi 0) -(define (cg-alloc-slot cg sz al) - (let* ((a (align-up %frame-hi al)) (n (+ a sz))) - (set! %frame-hi n) - (%cg-emit! (list 'alloc-slot sz al a)) - a)) - -(define (cg-trace-print) - (let loop ((xs (cg-trace-get))) - (cond ((null? xs) #t) - (else (write (car xs)) - (write-bv-fd 1 NL-BV) - (loop (cdr xs)))))) diff --git a/tests/cc-parse/_mini-prelude.scm b/tests/cc-parse/_mini-prelude.scm @@ -1,66 +0,0 @@ -;; tests/cc-parse/mini-prelude.scm — minimal prelude for cc-parse fixtures. -;; Replaces scheme1/prelude.scm in the catm so the combined file fits in -;; scheme1's 64 KiB readbuf. Defines only what util.scm + parse.scm + -;; cg-trace.scm + the fixture driver actually use. - -(define (<= a b) (if (< b a) #f #t)) -(define (>= a b) (if (< a b) #f #t)) -(define (negative? n) (< n 0)) -(define (positive? n) (> n 0)) -(define number? integer?) -(define bytevector? string?) -(define (min a b) (if (< a b) a b)) -(define (max a b) (if (< a b) b a)) -(define (modulo a b) - (let ((r (remainder a b))) - (if (zero? r) 0 - (if (eq? (negative? r) (negative? b)) r (+ r b))))) - -(define (caar x) (car (car x))) -(define (cadr x) (car (cdr x))) -(define (cdar x) (cdr (car x))) -(define (cddr x) (cdr (cdr x))) -(define (caddr x) (car (cdr (cdr x)))) - -(define (list . xs) xs) - -(define (reverse xs) - (let loop ((xs xs) (a '())) - (if (null? xs) a (loop (cdr xs) (cons (car xs) a))))) - -(define (append-pair a b) - (if (null? a) b (cons (car a) (append-pair (cdr a) b)))) -(define (append . ls) - (cond ((null? ls) '()) - ((null? (cdr ls)) (car ls)) - (else (append-pair (car ls) (apply append (cdr ls)))))) - -(define (assoc k al) - (if (null? al) #f - (if (eq? (car (car al)) k) (car al) (assoc k (cdr al))))) - -(define (member x xs) - (if (null? xs) #f - (if (eq? (car xs) x) xs (member x (cdr xs))))) - -(define (map f xs) - (if (null? xs) '() (cons (f (car xs)) (map f (cdr xs))))) -(define (for-each f xs) - (if (null? xs) '() (begin (f (car xs)) (for-each f (cdr xs))))) -(define (fold f acc xs) - (if (null? xs) acc (fold f (f acc (car xs)) (cdr xs)))) - -(define BUFSIZE 4096) -(define NL-BV (make-bytevector 1 10)) - -(define (bv-concat-reverse cs) - (let* ((xs (reverse cs)) - (n (let s ((ys xs) (n 0)) - (if (null? ys) n - (s (cdr ys) (+ n (bytevector-length (car ys))))))) - (out (make-bytevector n))) - (let loop ((ys xs) (i 0)) - (if (null? ys) out - (let ((len (bytevector-length (car ys)))) - (bytevector-copy! out i (car ys) 0 len) - (loop (cdr ys) (+ i len))))))) diff --git a/tests/cc-parse/_run-parse.scm b/tests/cc-parse/_run-parse.scm @@ -0,0 +1,46 @@ +;; tests/cc-parse/_run-parse.scm — driver for cc-parse .c fixtures. +;; +;; argv[0] = scheme1 binary path +;; argv[1] = combined source (assembled by the test runner via catm) +;; argv[2] = .c fixture path +;; +;; Runs the full lex+pp+parse+cg pipeline against the fixture and +;; writes the emitted P1pp text to stdout. Same plumbing as cc-main, +;; minus the -D/-o flag handling. + +(define (%basename path) + (let* ((n (bytevector-length path))) + (let loop ((i (- n 1))) + (cond + ((< i 0) path) + ((= (bytevector-u8-ref path i) 47) + (bv-slice path (+ i 1) n)) + (else (loop (- i 1))))))) + +(define (%run-parse path) + (let ((op (open-input path))) + (if (not (car op)) + (begin + (write-bv-fd 2 "run-parse: cannot open ") + (write-bv-fd 2 path) + (write-bv-fd 2 NL-BV) + (sys-exit 2)) + (let* ((src (slurp-fd (port-fd (cdr op)))) + (file (%basename path)) + (toks (lex-tokenize src file)) + (expanded (pp-expand toks '())) + (cg (cg-init)) + (ps (make-pstate expanded cg))) + (sys-close (port-fd (cdr op))) + (parse-translation-unit ps) + (write-bv-fd 1 (cg-finish cg)) + (sys-exit 0))))) + +(let ((args (argv))) + (cond + ((null? args) (sys-exit 2)) + ((null? (cdr args)) (sys-exit 2)) + ((null? (cdr (cdr args))) + (write-bv-fd 2 "run-parse: missing fixture path\n") + (sys-exit 2)) + (else (%run-parse (car (cdr (cdr args))))))) diff --git a/tests/cc-pp/01-obj-macro.c b/tests/cc-pp/01-obj-macro.c @@ -0,0 +1,2 @@ +#define X 42 +X diff --git a/tests/cc-pp/01-obj-macro.expected-exit b/tests/cc-pp/01-obj-macro.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/01-obj-macro.expected-toks b/tests/cc-pp/01-obj-macro.expected-toks @@ -0,0 +1,2 @@ +(INT 42 "01-obj-macro.c" 1 11) +(EOF #f "01-obj-macro.c" 3 1) diff --git a/tests/cc-pp/01-obj-macro.scm b/tests/cc-pp/01-obj-macro.scm @@ -1,18 +0,0 @@ -;; Object-like macro: `#define X 42` then `X` -> INT 42. -;; Hand-built tokens; does not depend on lex.scm. -(define l (%loc "t.c" 1 1)) -(define input - (list (%tok 'HASH #f l '()) - (%tok 'IDENT "define" l '()) - (%tok 'IDENT "X" l '()) - (%tok 'INT 42 l '()) - (%tok 'NL #f l '()) - (%tok 'IDENT "X" l '()) - (%tok 'NL #f l '()) - (%tok 'EOF #f l '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 42) 0 (sys-exit 13)) -(if (eq? (tok-kind (car (cdr out))) 'EOF) 0 (sys-exit 14)) -(sys-exit 0) diff --git a/tests/cc-pp/02-obj-macro-multi-tok.c b/tests/cc-pp/02-obj-macro-multi-tok.c @@ -0,0 +1,2 @@ +#define X 1 + 2 +X diff --git a/tests/cc-pp/02-obj-macro-multi-tok.expected-exit b/tests/cc-pp/02-obj-macro-multi-tok.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/02-obj-macro-multi-tok.expected-toks b/tests/cc-pp/02-obj-macro-multi-tok.expected-toks @@ -0,0 +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) diff --git a/tests/cc-pp/02-obj-macro-multi-tok.scm b/tests/cc-pp/02-obj-macro-multi-tok.scm @@ -1,24 +0,0 @@ -;; #define ADD1(no-paren-adjacent) - actually a multi-tok object macro: -;; #define X 1 + 2 -;; then `X` should produce three tokens: INT 1, PUNCT plus, INT 2. -(define l (%loc "t.c" 1 1)) -(define input - (list (%tok 'HASH #f l '()) - (%tok 'IDENT "define" l '()) - (%tok 'IDENT "X" l '()) - (%tok 'INT 1 l '()) - (%tok 'PUNCT 'plus l '()) - (%tok 'INT 2 l '()) - (%tok 'NL #f l '()) - (%tok 'IDENT "X" l '()) - (%tok 'NL #f l '()) - (%tok 'EOF #f l '()))) -(define out (pp-expand input '())) -(if (= (length out) 4) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 1) 0 (sys-exit 13)) -(if (eq? (tok-kind (car (cdr out))) 'PUNCT) 0 (sys-exit 14)) -(if (eq? (tok-value (car (cdr out))) 'plus) 0 (sys-exit 15)) -(if (eq? (tok-kind (car (cdr (cdr out)))) 'INT) 0 (sys-exit 16)) -(if (= (tok-value (car (cdr (cdr out)))) 2) 0 (sys-exit 17)) -(sys-exit 0) diff --git a/tests/cc-pp/03-fn-macro.c b/tests/cc-pp/03-fn-macro.c @@ -0,0 +1,2 @@ +#define ID(x) x +ID(42) diff --git a/tests/cc-pp/03-fn-macro.expected-exit b/tests/cc-pp/03-fn-macro.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/03-fn-macro.expected-toks b/tests/cc-pp/03-fn-macro.expected-toks @@ -0,0 +1,2 @@ +(INT 42 "03-fn-macro.c" 2 4) +(EOF #f "03-fn-macro.c" 3 1) diff --git a/tests/cc-pp/03-fn-macro.scm b/tests/cc-pp/03-fn-macro.scm @@ -1,26 +0,0 @@ -;; Function-like macro: -;; #define ID(x) x -;; then ID(42) -> INT 42. -;; The `(` after `ID` must be column-adjacent to ID; we synthesize cols -;; so that holds. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) ; col 1 - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "ID" (LL 9) '()) ; ID at col 9 (length 2) - (%tok 'PUNCT 'lparen (LL 11) '()) ; ( at col 11 = 9 + 2 - (%tok 'IDENT "x" (LL 12) '()) - (%tok 'PUNCT 'rparen (LL 13) '()) - (%tok 'IDENT "x" (LL 15) '()) - (%tok 'NL #f (LL 16) '()) - (%tok 'IDENT "ID" (LL 1) '()) - (%tok 'PUNCT 'lparen (LL 3) '()) - (%tok 'INT 42 (LL 4) '()) - (%tok 'PUNCT 'rparen (LL 6) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 42) 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/04-fn-macro-2args.c b/tests/cc-pp/04-fn-macro-2args.c @@ -0,0 +1,2 @@ +#define ADD(a,b) a+b +ADD(3,4) diff --git a/tests/cc-pp/04-fn-macro-2args.expected-exit b/tests/cc-pp/04-fn-macro-2args.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/04-fn-macro-2args.expected-toks b/tests/cc-pp/04-fn-macro-2args.expected-toks @@ -0,0 +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) diff --git a/tests/cc-pp/04-fn-macro-2args.scm b/tests/cc-pp/04-fn-macro-2args.scm @@ -1,29 +0,0 @@ -;; #define ADD(a,b) a+b then ADD(3,4) -> 3 + 4 -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "ADD" (LL 9) '()) - (%tok 'PUNCT 'lparen (LL 12) '()) ; col 9+3=12 - (%tok 'IDENT "a" (LL 13) '()) - (%tok 'PUNCT 'comma (LL 14) '()) - (%tok 'IDENT "b" (LL 15) '()) - (%tok 'PUNCT 'rparen (LL 16) '()) - (%tok 'IDENT "a" (LL 18) '()) - (%tok 'PUNCT 'plus (LL 19) '()) - (%tok 'IDENT "b" (LL 20) '()) - (%tok 'NL #f (LL 21) '()) - (%tok 'IDENT "ADD" (LL 1) '()) - (%tok 'PUNCT 'lparen (LL 4) '()) ; col 1+3=4 - (%tok 'INT 3 (LL 5) '()) - (%tok 'PUNCT 'comma (LL 6) '()) - (%tok 'INT 4 (LL 7) '()) - (%tok 'PUNCT 'rparen (LL 8) '()) - (%tok 'NL #f (LL 9) '()) - (%tok 'EOF #f (LL 9) '()))) -(define out (pp-expand input '())) -(if (= (length out) 4) 0 (sys-exit 11)) -(if (= (tok-value (car out)) 3) 0 (sys-exit 12)) -(if (eq? (tok-value (car (cdr out))) 'plus) 0 (sys-exit 13)) -(if (= (tok-value (car (cdr (cdr out)))) 4) 0 (sys-exit 14)) -(sys-exit 0) diff --git a/tests/cc-pp/05-variadic.c b/tests/cc-pp/05-variadic.c @@ -0,0 +1,2 @@ +#define LOG(fmt, ...) fmt __VA_ARGS__ +LOG("x", 1, 2) diff --git a/tests/cc-pp/05-variadic.expected-exit b/tests/cc-pp/05-variadic.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/05-variadic.expected-toks b/tests/cc-pp/05-variadic.expected-toks @@ -0,0 +1,5 @@ +(STR "x" "05-variadic.c" 2 5) +(INT 1 "05-variadic.c" 2 10) +(PUNCT comma "<expand>" 0 0) +(INT 2 "05-variadic.c" 2 13) +(EOF #f "05-variadic.c" 3 1) diff --git a/tests/cc-pp/05-variadic.scm b/tests/cc-pp/05-variadic.scm @@ -1,35 +0,0 @@ -;; Variadic macro: -;; #define LOG(fmt, ...) fmt __VA_ARGS__ -;; LOG("x", 1, 2) -> STR "x" INT 1 PUNCT comma INT 2 -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "LOG" (LL 9) '()) - (%tok 'PUNCT 'lparen (LL 12) '()) ; col 9+3=12 - (%tok 'IDENT "fmt" (LL 13) '()) - (%tok 'PUNCT 'comma (LL 16) '()) - (%tok 'PUNCT 'ellipsis (LL 17) '()) - (%tok 'PUNCT 'rparen (LL 20) '()) - (%tok 'IDENT "fmt" (LL 22) '()) - (%tok 'IDENT "__VA_ARGS__" (LL 26) '()) - (%tok 'NL #f (LL 36) '()) - (%tok 'IDENT "LOG" (LL 1) '()) - (%tok 'PUNCT 'lparen (LL 4) '()) ; col 1+3=4 - (%tok 'STR "x" (LL 5) '()) - (%tok 'PUNCT 'comma (LL 8) '()) - (%tok 'INT 1 (LL 9) '()) - (%tok 'PUNCT 'comma (LL 10) '()) - (%tok 'INT 2 (LL 11) '()) - (%tok 'PUNCT 'rparen (LL 12) '()) - (%tok 'NL #f (LL 13) '()) - (%tok 'EOF #f (LL 13) '()))) -(define out (pp-expand input '())) -;; Expected: STR "x", INT 1, PUNCT comma, INT 2, EOF. -(if (= (length out) 5) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'STR) 0 (sys-exit 12)) -(if (bytevector=? (tok-value (car out)) "x") 0 (sys-exit 13)) -(if (= (tok-value (car (cdr out))) 1) 0 (sys-exit 14)) -(if (eq? (tok-value (car (cdr (cdr out)))) 'comma) 0 (sys-exit 15)) -(if (= (tok-value (car (cdr (cdr (cdr out))))) 2) 0 (sys-exit 16)) -(sys-exit 0) diff --git a/tests/cc-pp/06-stringize.c b/tests/cc-pp/06-stringize.c @@ -0,0 +1,2 @@ +#define STR(x) #x +STR(hello) diff --git a/tests/cc-pp/06-stringize.expected-exit b/tests/cc-pp/06-stringize.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/06-stringize.expected-toks b/tests/cc-pp/06-stringize.expected-toks @@ -0,0 +1,2 @@ +(STR "hello" "06-stringize.c" 1 16) +(EOF #f "06-stringize.c" 3 1) diff --git a/tests/cc-pp/06-stringize.scm b/tests/cc-pp/06-stringize.scm @@ -1,25 +0,0 @@ -;; Stringize: -;; #define STR(x) #x -;; STR(hello) -> STR "hello" -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "STR" (LL 9) '()) - (%tok 'PUNCT 'lparen (LL 12) '()) - (%tok 'IDENT "x" (LL 13) '()) - (%tok 'PUNCT 'rparen (LL 14) '()) - (%tok 'PUNCT 'hash (LL 16) '()) - (%tok 'IDENT "x" (LL 17) '()) - (%tok 'NL #f (LL 18) '()) - (%tok 'IDENT "STR" (LL 1) '()) - (%tok 'PUNCT 'lparen (LL 4) '()) - (%tok 'IDENT "hello" (LL 5) '()) - (%tok 'PUNCT 'rparen (LL 10) '()) - (%tok 'NL #f (LL 11) '()) - (%tok 'EOF #f (LL 11) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'STR) 0 (sys-exit 12)) -(if (bytevector=? (tok-value (car out)) "hello") 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/07-paste.c b/tests/cc-pp/07-paste.c @@ -0,0 +1,2 @@ +#define CAT(a,b) a##b +CAT(foo, bar) diff --git a/tests/cc-pp/07-paste.expected-exit b/tests/cc-pp/07-paste.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/07-paste.expected-toks b/tests/cc-pp/07-paste.expected-toks @@ -0,0 +1,2 @@ +(IDENT "foobar" "07-paste.c" 2 5) +(EOF #f "07-paste.c" 3 1) diff --git a/tests/cc-pp/07-paste.scm b/tests/cc-pp/07-paste.scm @@ -1,30 +0,0 @@ -;; Token paste: -;; #define CAT(a,b) a##b -;; CAT(foo, bar) -> IDENT "foobar" -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "CAT" (LL 9) '()) - (%tok 'PUNCT 'lparen (LL 12) '()) - (%tok 'IDENT "a" (LL 13) '()) - (%tok 'PUNCT 'comma (LL 14) '()) - (%tok 'IDENT "b" (LL 15) '()) - (%tok 'PUNCT 'rparen (LL 16) '()) - (%tok 'IDENT "a" (LL 18) '()) - (%tok 'PUNCT 'paste (LL 19) '()) - (%tok 'IDENT "b" (LL 21) '()) - (%tok 'NL #f (LL 22) '()) - (%tok 'IDENT "CAT" (LL 1) '()) - (%tok 'PUNCT 'lparen (LL 4) '()) - (%tok 'IDENT "foo" (LL 5) '()) - (%tok 'PUNCT 'comma (LL 8) '()) - (%tok 'IDENT "bar" (LL 9) '()) - (%tok 'PUNCT 'rparen (LL 12) '()) - (%tok 'NL #f (LL 13) '()) - (%tok 'EOF #f (LL 13) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'IDENT) 0 (sys-exit 12)) -(if (bytevector=? (tok-value (car out)) "foobar") 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/08-nested-expansion.c b/tests/cc-pp/08-nested-expansion.c @@ -0,0 +1,3 @@ +#define A 1 +#define B A +B diff --git a/tests/cc-pp/08-nested-expansion.expected-exit b/tests/cc-pp/08-nested-expansion.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/08-nested-expansion.expected-toks b/tests/cc-pp/08-nested-expansion.expected-toks @@ -0,0 +1,2 @@ +(INT 1 "08-nested-expansion.c" 1 11) +(EOF #f "08-nested-expansion.c" 4 1) diff --git a/tests/cc-pp/08-nested-expansion.scm b/tests/cc-pp/08-nested-expansion.scm @@ -1,24 +0,0 @@ -;; Nested expansion: -;; #define A 1 -;; #define B A -;; B -> 1 (B expands to A, A expands to 1) -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "A" (LL 9) '()) - (%tok 'INT 1 (LL 11) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "B" (LL 9) '()) - (%tok 'IDENT "A" (LL 11) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'IDENT "B" (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'EOF #f (LL 2) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 1) 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/09-hideset-self.c b/tests/cc-pp/09-hideset-self.c @@ -0,0 +1,2 @@ +#define X X +X diff --git a/tests/cc-pp/09-hideset-self.expected-exit b/tests/cc-pp/09-hideset-self.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/09-hideset-self.expected-toks b/tests/cc-pp/09-hideset-self.expected-toks @@ -0,0 +1,2 @@ +(IDENT "X" "09-hideset-self.c" 1 11) +(EOF #f "09-hideset-self.c" 3 1) diff --git a/tests/cc-pp/09-hideset-self.scm b/tests/cc-pp/09-hideset-self.scm @@ -1,26 +0,0 @@ -;; Hide-set self-reference: -;; #define X X -;; X -> X (single IDENT, NOT recursively expanded) -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "X" (LL 9) '()) - (%tok 'IDENT "X" (LL 11) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'IDENT "X" (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'EOF #f (LL 2) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'IDENT) 0 (sys-exit 12)) -(if (bytevector=? (tok-value (car out)) "X") 0 (sys-exit 13)) -;; Verify the emitted token has X in its hide-set (it must, otherwise -;; rescan would loop). Just assert the hide-set contains "X". -(define h (tok-hide (car out))) -(define (mem? x xs) - (cond ((null? xs) #f) - ((bytevector=? x (car xs)) #t) - (else (mem? x (cdr xs))))) -(if (mem? "X" h) 0 (sys-exit 14)) -(sys-exit 0) diff --git a/tests/cc-pp/10-if-defined.c b/tests/cc-pp/10-if-defined.c @@ -0,0 +1,4 @@ +#define X 1 +#if defined(X) +7 +#endif diff --git a/tests/cc-pp/10-if-defined.expected-exit b/tests/cc-pp/10-if-defined.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/10-if-defined.expected-toks b/tests/cc-pp/10-if-defined.expected-toks @@ -0,0 +1,2 @@ +(INT 7 "10-if-defined.c" 3 1) +(EOF #f "10-if-defined.c" 5 1) diff --git a/tests/cc-pp/10-if-defined.scm b/tests/cc-pp/10-if-defined.scm @@ -1,30 +0,0 @@ -;; #if defined(X) — emit body when X defined. -;; #define X 1 -;; #if defined(X) -;; INT 7 -;; #endif -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "X" (LL 9) '()) - (%tok 'INT 1 (LL 11) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'IDENT "defined" (LL 5) '()) - (%tok 'PUNCT 'lparen (LL 12) '()) - (%tok 'IDENT "X" (LL 13) '()) - (%tok 'PUNCT 'rparen (LL 14) '()) - (%tok 'NL #f (LL 15) '()) - (%tok 'INT 7 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 7) 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/11-if-arith.c b/tests/cc-pp/11-if-arith.c @@ -0,0 +1,3 @@ +#if 1+2 == 3 +42 +#endif diff --git a/tests/cc-pp/11-if-arith.expected-exit b/tests/cc-pp/11-if-arith.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/11-if-arith.expected-toks b/tests/cc-pp/11-if-arith.expected-toks @@ -0,0 +1,2 @@ +(INT 42 "11-if-arith.c" 2 1) +(EOF #f "11-if-arith.c" 4 1) diff --git a/tests/cc-pp/11-if-arith.scm b/tests/cc-pp/11-if-arith.scm @@ -1,21 +0,0 @@ -;; #if 1+2 == 3 -> body emitted -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'INT 1 (LL 5) '()) - (%tok 'PUNCT 'plus (LL 6) '()) - (%tok 'INT 2 (LL 7) '()) - (%tok 'PUNCT 'eq2 (LL 9) '()) - (%tok 'INT 3 (LL 12) '()) - (%tok 'NL #f (LL 13) '()) - (%tok 'INT 42 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (= (tok-value (car out)) 42) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/12-ifdef-ifndef.c b/tests/cc-pp/12-ifdef-ifndef.c @@ -0,0 +1,10 @@ +#define A +#ifdef A +1 +#endif +#ifndef B +2 +#endif +#ifdef B +99 +#endif diff --git a/tests/cc-pp/12-ifdef-ifndef.expected-exit b/tests/cc-pp/12-ifdef-ifndef.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/12-ifdef-ifndef.expected-toks b/tests/cc-pp/12-ifdef-ifndef.expected-toks @@ -0,0 +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) diff --git a/tests/cc-pp/12-ifdef-ifndef.scm b/tests/cc-pp/12-ifdef-ifndef.scm @@ -1,46 +0,0 @@ -;; #define A -;; #ifdef A -> emit 1 -;; #endif -;; #ifndef B -> emit 2 -;; #endif -;; #ifdef B -> NOT emitted -;; #endif -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "A" (LL 9) '()) - (%tok 'NL #f (LL 10) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "ifdef" (LL 2) '()) - (%tok 'IDENT "A" (LL 8) '()) - (%tok 'NL #f (LL 9) '()) - (%tok 'INT 1 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "ifndef" (LL 2) '()) - (%tok 'IDENT "B" (LL 9) '()) - (%tok 'NL #f (LL 10) '()) - (%tok 'INT 2 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "ifdef" (LL 2) '()) - (%tok 'IDENT "B" (LL 8) '()) - (%tok 'NL #f (LL 9) '()) - (%tok 'INT 99 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 3) 0 (sys-exit 11)) ; INT 1, INT 2, EOF -(if (= (tok-value (car out)) 1) 0 (sys-exit 12)) -(if (= (tok-value (car (cdr out))) 2) 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/13-elif-chain.c b/tests/cc-pp/13-elif-chain.c @@ -0,0 +1,9 @@ +#if 0 +1 +#elif 1 +5 +#elif 1 +3 +#else +4 +#endif diff --git a/tests/cc-pp/13-elif-chain.expected-exit b/tests/cc-pp/13-elif-chain.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/13-elif-chain.expected-toks b/tests/cc-pp/13-elif-chain.expected-toks @@ -0,0 +1,2 @@ +(INT 5 "13-elif-chain.c" 4 1) +(EOF #f "13-elif-chain.c" 10 1) diff --git a/tests/cc-pp/13-elif-chain.scm b/tests/cc-pp/13-elif-chain.scm @@ -1,38 +0,0 @@ -;; #if 0 -> skipped -;; #elif 1 -> taken (emit 5) -;; #elif 1 -> NOT taken (already taken) -;; #else -> NOT taken -;; #endif -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'INT 0 (LL 5) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'INT 1 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "elif" (LL 2) '()) - (%tok 'INT 1 (LL 7) '()) - (%tok 'NL #f (LL 8) '()) - (%tok 'INT 5 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "elif" (LL 2) '()) - (%tok 'INT 1 (LL 7) '()) - (%tok 'NL #f (LL 8) '()) - (%tok 'INT 3 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "else" (LL 2) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'INT 4 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) ; INT 5, EOF -(if (= (tok-value (car out)) 5) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/14-nested-if.c b/tests/cc-pp/14-nested-if.c @@ -0,0 +1,9 @@ +#if 1 +#if 0 +3 +#else +4 +#endif +#else +5 +#endif diff --git a/tests/cc-pp/14-nested-if.expected-exit b/tests/cc-pp/14-nested-if.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/14-nested-if.expected-toks b/tests/cc-pp/14-nested-if.expected-toks @@ -0,0 +1,2 @@ +(INT 4 "14-nested-if.c" 5 1) +(EOF #f "14-nested-if.c" 10 1) diff --git a/tests/cc-pp/14-nested-if.scm b/tests/cc-pp/14-nested-if.scm @@ -1,43 +0,0 @@ -;; Nested #if: -;; #if 1 -;; #if 0 -> skip -;; 3 -;; #else -> emit 4 -;; 4 -;; #endif -;; #else -> outer skip -;; 5 -;; #endif -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'INT 1 (LL 5) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'INT 0 (LL 5) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'INT 3 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "else" (LL 2) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'INT 4 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "else" (LL 2) '()) - (%tok 'NL #f (LL 6) '()) - (%tok 'INT 5 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) ; INT 4, EOF -(if (= (tok-value (car out)) 4) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/15-undef.c b/tests/cc-pp/15-undef.c @@ -0,0 +1,4 @@ +#define X 1 +X +#undef X +X diff --git a/tests/cc-pp/15-undef.expected-exit b/tests/cc-pp/15-undef.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/15-undef.expected-toks b/tests/cc-pp/15-undef.expected-toks @@ -0,0 +1,3 @@ +(INT 1 "15-undef.c" 1 11) +(IDENT "X" "15-undef.c" 4 1) +(EOF #f "15-undef.c" 5 1) diff --git a/tests/cc-pp/15-undef.scm b/tests/cc-pp/15-undef.scm @@ -1,28 +0,0 @@ -;; #define X 1 -;; X -> INT 1 -;; #undef X -;; X -> IDENT X (no longer expanded) -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "define" (LL 2) '()) - (%tok 'IDENT "X" (LL 9) '()) - (%tok 'INT 1 (LL 11) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'IDENT "X" (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "undef" (LL 2) '()) - (%tok 'IDENT "X" (LL 8) '()) - (%tok 'NL #f (LL 9) '()) - (%tok 'IDENT "X" (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'EOF #f (LL 2) '()))) -(define out (pp-expand input '())) -;; Expected: INT 1, IDENT X, EOF -(if (= (length out) 3) 0 (sys-exit 11)) -(if (eq? (tok-kind (car out)) 'INT) 0 (sys-exit 12)) -(if (= (tok-value (car out)) 1) 0 (sys-exit 13)) -(if (eq? (tok-kind (car (cdr out))) 'IDENT) 0 (sys-exit 14)) -(if (bytevector=? (tok-value (car (cdr out))) "X") 0 (sys-exit 15)) -(sys-exit 0) diff --git a/tests/cc-pp/16-error.c b/tests/cc-pp/16-error.c @@ -0,0 +1 @@ +#error boom diff --git a/tests/cc-pp/16-error.expected b/tests/cc-pp/16-error.expected @@ -1 +0,0 @@ -t.c:1:2: error: #error: boom diff --git a/tests/cc-pp/16-error.scm b/tests/cc-pp/16-error.scm @@ -1,10 +0,0 @@ -;; #error msg -> die with exit 1. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "error" (LL 2) '()) - (%tok 'IDENT "boom" (LL 8) '()) - (%tok 'NL #f (LL 12) '()) - (%tok 'EOF #f (LL 12) '()))) -(pp-expand input '()) ; should die before this returns -(sys-exit 0) diff --git a/tests/cc-pp/17-include-rejected.c b/tests/cc-pp/17-include-rejected.c @@ -0,0 +1 @@ +#include "x" diff --git a/tests/cc-pp/17-include-rejected.expected b/tests/cc-pp/17-include-rejected.expected @@ -1 +0,0 @@ -t.c:1:10: error: #include: file inclusion is handled upstream by pre-flatten diff --git a/tests/cc-pp/17-include-rejected.scm b/tests/cc-pp/17-include-rejected.scm @@ -1,10 +0,0 @@ -;; #include "x" must die. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "include" (LL 2) '()) - (%tok 'STR "x" (LL 10) '()) - (%tok 'NL #f (LL 14) '()) - (%tok 'EOF #f (LL 14) '()))) -(pp-expand input '()) -(sys-exit 0) diff --git a/tests/cc-pp/18-builtin-stdc.c b/tests/cc-pp/18-builtin-stdc.c @@ -0,0 +1 @@ +__STDC__ __LISPCC__ diff --git a/tests/cc-pp/18-builtin-stdc.expected-exit b/tests/cc-pp/18-builtin-stdc.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/18-builtin-stdc.expected-toks b/tests/cc-pp/18-builtin-stdc.expected-toks @@ -0,0 +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) diff --git a/tests/cc-pp/18-builtin-stdc.scm b/tests/cc-pp/18-builtin-stdc.scm @@ -1,12 +0,0 @@ -;; Built-in macros __STDC__ -> 1, __LISPCC__ -> 1. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'IDENT "__STDC__" (LL 1) '()) - (%tok 'IDENT "__LISPCC__" (LL 11) '()) - (%tok 'NL #f (LL 22) '()) - (%tok 'EOF #f (LL 22) '()))) -(define out (pp-expand input '())) -(if (= (length out) 3) 0 (sys-exit 11)) ; INT 1, INT 1, EOF -(if (= (tok-value (car out)) 1) 0 (sys-exit 12)) -(if (= (tok-value (car (cdr out))) 1) 0 (sys-exit 13)) -(sys-exit 0) diff --git a/tests/cc-pp/19-pragma-dropped.c b/tests/cc-pp/19-pragma-dropped.c @@ -0,0 +1,2 @@ +#pragma once +7 diff --git a/tests/cc-pp/19-pragma-dropped.expected-exit b/tests/cc-pp/19-pragma-dropped.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/19-pragma-dropped.expected-toks b/tests/cc-pp/19-pragma-dropped.expected-toks @@ -0,0 +1,2 @@ +(INT 7 "19-pragma-dropped.c" 2 1) +(EOF #f "19-pragma-dropped.c" 3 1) diff --git a/tests/cc-pp/19-pragma-dropped.scm b/tests/cc-pp/19-pragma-dropped.scm @@ -1,14 +0,0 @@ -;; #pragma is accepted and dropped. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "pragma" (LL 2) '()) - (%tok 'IDENT "once" (LL 9) '()) - (%tok 'NL #f (LL 13) '()) - (%tok 'INT 7 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'EOF #f (LL 2) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) ; INT 7, EOF -(if (= (tok-value (car out)) 7) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/20-cexpr-ops.c b/tests/cc-pp/20-cexpr-ops.c @@ -0,0 +1,3 @@ +#if (1+2)*3 == 9 +77 +#endif diff --git a/tests/cc-pp/20-cexpr-ops.expected-exit b/tests/cc-pp/20-cexpr-ops.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/20-cexpr-ops.expected-toks b/tests/cc-pp/20-cexpr-ops.expected-toks @@ -0,0 +1,2 @@ +(INT 77 "20-cexpr-ops.c" 2 1) +(EOF #f "20-cexpr-ops.c" 4 1) diff --git a/tests/cc-pp/20-cexpr-ops.scm b/tests/cc-pp/20-cexpr-ops.scm @@ -1,26 +0,0 @@ -;; #if (1+2)*3 == 9 -> body emitted -;; Exercises parens, mul, ==. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'PUNCT 'lparen (LL 5) '()) - (%tok 'INT 1 (LL 6) '()) - (%tok 'PUNCT 'plus (LL 7) '()) - (%tok 'INT 2 (LL 8) '()) - (%tok 'PUNCT 'rparen (LL 9) '()) - (%tok 'PUNCT 'star (LL 10) '()) - (%tok 'INT 3 (LL 11) '()) - (%tok 'PUNCT 'eq2 (LL 13) '()) - (%tok 'INT 9 (LL 16) '()) - (%tok 'NL #f (LL 17) '()) - (%tok 'INT 77 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (= (tok-value (car out)) 77) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/21-undefined-id-zero.c b/tests/cc-pp/21-undefined-id-zero.c @@ -0,0 +1,3 @@ +#if UNKNOWN == 0 +42 +#endif diff --git a/tests/cc-pp/21-undefined-id-zero.expected-exit b/tests/cc-pp/21-undefined-id-zero.expected-exit @@ -1 +0,0 @@ -0 diff --git a/tests/cc-pp/21-undefined-id-zero.expected-toks b/tests/cc-pp/21-undefined-id-zero.expected-toks @@ -0,0 +1,2 @@ +(INT 42 "21-undefined-id-zero.c" 2 1) +(EOF #f "21-undefined-id-zero.c" 4 1) diff --git a/tests/cc-pp/21-undefined-id-zero.scm b/tests/cc-pp/21-undefined-id-zero.scm @@ -1,20 +0,0 @@ -;; In #if, an undefined identifier counts as 0: -;; #if UNKNOWN == 0 -> emit body. -(define (LL c) (%loc "t.c" 1 c)) -(define input - (list (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "if" (LL 2) '()) - (%tok 'IDENT "UNKNOWN" (LL 5) '()) - (%tok 'PUNCT 'eq2 (LL 13) '()) - (%tok 'INT 0 (LL 16) '()) - (%tok 'NL #f (LL 17) '()) - (%tok 'INT 42 (LL 1) '()) - (%tok 'NL #f (LL 2) '()) - (%tok 'HASH #f (LL 1) '()) - (%tok 'IDENT "endif" (LL 2) '()) - (%tok 'NL #f (LL 7) '()) - (%tok 'EOF #f (LL 7) '()))) -(define out (pp-expand input '())) -(if (= (length out) 2) 0 (sys-exit 11)) -(if (= (tok-value (car out)) 42) 0 (sys-exit 12)) -(sys-exit 0) diff --git a/tests/cc-pp/30-define-end-to-end.expected-toks b/tests/cc-pp/30-define-end-to-end.expected-toks @@ -1,5 +1,2 @@ -;; END-TO-END fixture (requires cc/lex.scm). Aspirational: the actual -;; column/line numbers depend on the lexer's `__LINE__`-replacement -;; semantics; refine this golden once lex.scm lands. -(INT 42 "30-define-end-to-end.c" 2 1) +(INT 42 "30-define-end-to-end.c" 1 11) (EOF #f "30-define-end-to-end.c" 3 1) diff --git a/tests/cc-pp/_run-pp.scm b/tests/cc-pp/_run-pp.scm @@ -1,59 +1,107 @@ -;; tests/cc-pp/run-pp.scm — end-to-end driver. +;; tests/cc-pp/_run-pp.scm — driver for cc-pp .c fixtures. ;; -;; REQUIRES: cc/lex.scm. Build with: -;; catm prelude.scm cc/util.scm cc/data.scm cc/lex.scm cc/pp.scm \ -;; tests/cc-pp/run-pp.scm > prog -;; scheme1 prog INPUT.c > toks-actual +;; argv[0] = scheme1 binary path +;; argv[1] = combined source (assembled by the test runner via catm) +;; argv[2] = .c fixture path ;; -;; Reads the .c path from argv[1], lexes, expands, prints one tok per -;; line in CC-CONTRACTS §2.1 format: -;; (KIND VALUE FILE LINE COL) +;; Slurps the fixture, runs lex-tokenize then pp-expand, prints one +;; tok per line on stdout in CC-CONTRACTS §2.1 format. Mirrors +;; tests/cc-lex/_run-lex.scm with one extra phase (pp). -(define (main argv) +(define (%hex-nibble n) + (if (< n 10) (+ n 48) (+ n 87))) + +(define (%bv-escape bv) + (let* ((n (bytevector-length bv)) + (buf (make-buf))) + (buf-push! buf "\"") + (let loop ((i 0)) + (cond + ((= i n) + (buf-push! buf "\"") + (buf-flush buf)) + (else + (let ((b (bytevector-u8-ref bv i))) + (cond + ((= b 10) (buf-push! buf "\\n")) + ((= b 9) (buf-push! buf "\\t")) + ((= b 13) (buf-push! buf "\\r")) + ((= b 92) (buf-push! buf "\\\\")) + ((= b 34) (buf-push! buf "\\\"")) + ((and (>= b 32) (<= b 126)) + (buf-push! buf (bv-of-byte b))) + (else + (let* ((hi (%hex-nibble (bit-and (arithmetic-shift b -4) 15))) + (lo (%hex-nibble (bit-and b 15)))) + (buf-push! buf "\\x") + (buf-push! buf (bv-of-byte hi)) + (buf-push! buf (bv-of-byte lo))))) + (loop (+ i 1)))))))) + +(define (%fmt-value kind val) (cond - ((or (null? argv) (null? (cdr argv))) - (write-bv-fd 2 "usage: run-pp.scm INPUT.c\n") - (sys-exit 2)) + ((eq? kind 'IDENT) (%bv-escape val)) + ((eq? kind 'STR) (%bv-escape val)) + ((eq? kind 'INT) (format "~d" val)) + ((eq? kind 'CHAR) (format "~d" val)) + ((eq? kind 'KW) (format "~a" val)) + ((eq? kind 'PUNCT) (format "~a" val)) + ((eq? kind 'HASH) "#f") + ((eq? kind 'NL) "#f") + ((eq? kind 'EOF) "#f") + (else (format "~a" val)))) + +(define (%fmt-tok t) + (let* ((kind (tok-kind t)) + (val (tok-value t)) + (loc (tok-loc t)) + (file (loc-file loc)) + (line (loc-line loc)) + (col (loc-col loc))) + (bv-cat (list "(" (format "~a" kind) " " + (%fmt-value kind val) " " + (%bv-escape file) " " + (format "~d" line) " " + (format "~d" col) ")" + NL-BV)))) + +(define (%emit-toks toks) + (cond + ((null? toks) #t) (else - (let* ((path (car (cdr argv))) - (r (open-input path))) - (cond - ((not (car r)) - (write-bv-fd 2 "run-pp: open failed\n") - (sys-exit 1)) - (else - (let* ((p (cdr r)) - (src-r (read-all p)) - (src (cdr src-r)) - (toks (lex-tokenize src path)) - (out (pp-expand toks '()))) - (close p) - (for-each %print-tok out) - (sys-exit 0)))))))) - -(define (%print-tok t) - (let ((k (tok-kind t)) (v (tok-value t)) (l (tok-loc t))) - ;; (KIND VALUE FILE LINE COL)\n - (write-bv-fd 1 - (bytevector-append "(" - (bytevector-append (symbol->string k) - (bytevector-append " " - (bytevector-append (%val->bv k v) - (bytevector-append " \"" - (bytevector-append (loc-file l) - (bytevector-append "\" " - (bytevector-append (fixnum->bv (loc-line l) 10) - (bytevector-append " " - (bytevector-append (fixnum->bv (loc-col l) 10) - ")\n")))))))))))))) - -(define (%val->bv k v) + (write-bv-fd 1 (%fmt-tok (car toks))) + (%emit-toks (cdr toks))))) + +(define (%basename path) + (let* ((n (bytevector-length path))) + (let loop ((i (- n 1))) + (cond + ((< i 0) path) + ((= (bytevector-u8-ref path i) 47) + (bv-slice path (+ i 1) n)) + (else (loop (- i 1))))))) + +(define (%run-pp path) + (let ((op (open-input path))) + (if (not (car op)) + (begin + (write-bv-fd 2 "run-pp: cannot open ") + (write-bv-fd 2 path) + (write-bv-fd 2 NL-BV) + (sys-exit 2)) + (let* ((src (slurp-fd (port-fd (cdr op)))) + (file (%basename path)) + (toks (lex-tokenize src file)) + (expanded (pp-expand toks '()))) + (sys-close (port-fd (cdr op))) + (%emit-toks expanded) + (sys-exit 0))))) + +(let ((args (argv))) (cond - ((or (eq? k 'HASH) (eq? k 'NL) (eq? k 'EOF)) "#f") - ((or (eq? k 'IDENT) (eq? k 'STR)) - (bytevector-append "\"" (bytevector-append v "\""))) - ((or (eq? k 'INT) (eq? k 'CHAR)) (fixnum->bv v 10)) - ((or (eq? k 'KW) (eq? k 'PUNCT)) (symbol->string v)) - (else "?"))) - -(main (sys-argv)) + ((null? args) (sys-exit 2)) + ((null? (cdr args)) (sys-exit 2)) + ((null? (cdr (cdr args))) + (write-bv-fd 2 "run-pp: missing fixture path\n") + (sys-exit 2)) + (else (%run-pp (car (cdr (cdr args)))))))