add codegen and args tests, fix couple of bugs in C generation

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)

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)

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 '())))

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)"))))

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)

tests/sexc.module.scm

@@ -1 +1,3 @@
-(module sexc (main) "../sexc.scm")
+(module sexc
+    *
+  "../sexc.scm")