From 36932fb48033d955277db5f10a8f2c230b55832b Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 15:49:27 +0300 Subject: [PATCH] add codegen and args tests, fix couple of bugs in C generation --- sex-fmt-c.scm | 33 +++++++++++++++++-- tests/Makefile | 2 +- tests/args.scm | 55 +++++++++++++++++++++++++++++++ tests/codegen.scm | 75 +++++++++++++++++++++++++++++++++++++++++++ tests/run.scm | 2 ++ tests/sexc.module.scm | 4 ++- 6 files changed, 167 insertions(+), 4 deletions(-) create mode 100644 tests/args.scm create mode 100644 tests/codegen.scm diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index d6a5aa1..127b2fc 100644 --- a/sex-fmt-c.scm +++ b/sex-fmt-c.scm @@ -787,8 +787,32 @@ (fmt-join c-expr name ", ") (c-expr name)))))) + ;; MODIFIED FROM UPSTREAM fmt-c: parenthesise a binary operand. + ;; + ;; A cast binds tighter than every binary operator, so upstream's + ;; unparenthesised (cat "(" type ")" expr) silently casts only the + ;; first operand: (cast (* 2 (sizeof GLfloat)) (* void)) came out as + ;; `(void *)2 * sizeof(GLfloat)'. Unary operands -- &x, *p, -n, + ;; sizeof, calls, identifiers, literals -- are already + ;; unary-expressions and are left alone, so this changes nothing that + ;; was previously correct. + (define c-binary-operators + '(+ - * / % << >> < > <= >= == != & ^ && %and %or + = *= /= %= &= ^= <<= >>=)) + + (define (c-binary-expression? expr) + (and (pair? expr) + (memq (car expr) c-binary-operators) + (pair? (cdr expr)) + (pair? (cddr expr)))) ; two or more operands + (define (c-cast type expr) - (cat "(" (c-type type) ")" (c-expr expr))) + (cat "(" (c-type type) ")" + (if (c-binary-expression? expr) + ;; c-with-op stops the operand from parenthesising itself + ;; a second time inside the parens we just added. + (cat "(" (c-with-op 'paren (c-expr expr)) ")") + (c-expr expr)))) (define (c-typedef type alias . o) (c-wrap-stmt @@ -861,7 +885,12 @@ (define (c-switch val . clauses) (c-reset-newline (lambda (st) - ((cat "switch (" (c-in-expr val) ")" (c-open-brace st) + ;; MODIFIED FROM UPSTREAM fmt-c: c-expr on the scrutinee. + ;; Upstream passes `val' straight to cat, which only works when + ;; it is an atom -- anything else (a member access, a call) is + ;; displayed as a raw s-expression instead of being rendered. + ;; c-while and c-for already do (c-in-test (c-expr check)). + ((cat "switch (" (c-in-expr (c-expr val)) ")" (c-open-brace st) (c-indent/switch st) (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl (c-current-indent-string st) (c-close-brace st) fl) diff --git a/tests/Makefile b/tests/Makefile index 6950dd6..0251aaa 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -6,7 +6,7 @@ MODULE_FLAGS = -emit-all-import-libraries -module-registration -c MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc SEX_OBJ = $(MODULES:%=%.o) -TESTS = basic semen reader fmt-c-writer utils line-directives +TESTS = basic semen reader fmt-c-writer utils line-directives codegen args TEST_SRCS = $(TESTS:%=%.scm) sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ) diff --git a/tests/args.scm b/tests/args.scm new file mode 100644 index 0000000..c4ced0f --- /dev/null +++ b/tests/args.scm @@ -0,0 +1,55 @@ +;;; Splitting the command line at `--'. +;;; +;;; getopt-long cannot do this: it consumes the separator and merges +;;; everything after it into `@' alongside the input file. So sexc +;;; splits the raw argv first, and only the head is parsed as options. +;;; Everything else reaches the C compiler exactly as written -- +;;; including the words that do not start with a dash, which a previous +;;; leading-dash heuristic used to drop. + +(import sexc) + +(define full '("foo.sex" "-o" "bar" "--" "-framework" "OpenGL" "-Wall")) + +(test-group "argument separator" + + (test "options and input file stay with sexc" + '("foo.sex" "-o" "bar") + (args-before-separator full)) + + (test "the tail reaches the compiler verbatim" + '("-framework" "OpenGL" "-Wall") + (args-after-separator full)) + + ;; The case that motivated this: `OpenGL' has no leading dash and was + ;; silently dropped, leaving `-framework' to swallow whatever flag + ;; came next. + (test "a word without a dash survives" + '("-framework" "OpenGL") + (args-after-separator '("x.sex" "--" "-framework" "OpenGL"))) + + (test "no separator means nothing for the compiler" + '() + (args-after-separator '("foo.sex" "-o" "bar"))) + + (test "no separator leaves every argument with sexc" + '("foo.sex" "-o" "bar") + (args-before-separator '("foo.sex" "-o" "bar"))) + + (test "a trailing separator is allowed" + '() + (args-after-separator '("foo.sex" "--"))) + + (test "a leading separator leaves no input file" + '() + (args-before-separator '("--" "-lm"))) + + ;; Only the first `--' separates; a later one is an ordinary compiler + ;; argument (ld takes several). + (test "only the first separator counts" + '("-Wl,--as-needed" "--" "-lm") + (args-after-separator '("x.sex" "--" "-Wl,--as-needed" "--" "-lm"))) + + (test "an empty command line is handled" + '() + (args-before-separator '()))) diff --git a/tests/codegen.scm b/tests/codegen.scm new file mode 100644 index 0000000..ad6c05b --- /dev/null +++ b/tests/codegen.scm @@ -0,0 +1,75 @@ +;;; Codegen details that are easy to get subtly wrong, and that the +;;; walk-* unit tests cannot see: they check the intermediate form we +;;; hand to fmt-c, not the C that fmt-c renders from it. +;;; +;;; Both cases below were found by writing an OpenGL example, not by +;;; the existing suite, because both need an operand shape that no +;;; earlier test program happened to use. + +(import (chicken port) + (chicken string) + srfi-13 + fmt-c-writer + reader + semen + utils) + +(define (sex->c source) + "Compile SOURCE, a string of Sex, and return the generated C." + (let ((forms (with-input-from-string source + (lambda () + (parameterize ((current-source-file "codegen.sex")) + (parse-all (current-input-port))))))) + (with-output-to-string + (lambda () + (parameterize ((sex-line-directives 'none)) + (emit-c (semen-process forms))))))) + +(define (emits? source fragment) + (and (string-contains (sex->c source) fragment) #t)) + +(define (in-fn body) + (string-append "(fn f ((a int) (b int)) void " body ")")) + +(test-group "codegen" + + ;; c-switch handed its scrutinee straight to `cat', which only works + ;; when it is an atom. Anything else was displayed as a raw + ;; s-expression: `switch ((%. e type))'. + (test-group "switch scrutinee" + (test-assert "member access" + (emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))" + "switch (e.type)")) + (test-assert "call" + (emits? (in-fn "(switch (g a) (case 1 (h)))") + "switch (g(a))")) + (test-assert "arithmetic" + (emits? (in-fn "(switch (+ a b) (case 1 (h)))") + "switch (a + b)"))) + + ;; A cast binds tighter than every binary operator, so an operand + ;; that is itself a binary expression has to be parenthesised -- + ;; otherwise the cast silently applies to the first operand only. + (test-group "cast precedence" + (test-assert "binary operand is parenthesised" + (emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))") + "(void *)(2 * sizeof(int))")) + (test-assert "subtraction operand is parenthesised" + (emits? (in-fn "(var f float (cast (- a b) float))") + "(float)(a - b)")) + ;; ...but exactly once. The operand used to parenthesise itself + ;; again inside the parens the cast had just added. + (test-assert "and not parenthesised twice" + (not (emits? (in-fn "(var f float (cast (- a b) float))") + "(float)((a - b))"))) + ;; Unary operands are already unary-expressions and must be left + ;; alone, or every existing cast in the tree gains noise. + (test-assert "identifier is left bare" + (emits? (in-fn "(var f float (cast a float))") + "(float)a")) + (test-assert "address-of is left bare" + (emits? (in-fn "(var p (* int) (cast (& a) (* int)))") + "(int *)&a")) + (test-assert "sizeof is left bare" + (emits? (in-fn "(var n int (cast (sizeof int) int))") + "(int)sizeof(int)")))) diff --git a/tests/run.scm b/tests/run.scm index 4f61af1..1256079 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -7,6 +7,8 @@ (include "fmt-c-writer.scm") (include "utils.scm") (include "line-directives.scm") +(include "codegen.scm") +(include "args.scm") ;;; Should be the last in the test suite (test-exit) diff --git a/tests/sexc.module.scm b/tests/sexc.module.scm index a0be047..320e689 100644 --- a/tests/sexc.module.scm +++ b/tests/sexc.module.scm @@ -1 +1,3 @@ -(module sexc (main) "../sexc.scm") +(module sexc + * + "../sexc.scm")