forked from alex-eg/sex
alex-eg
53f92727a5
A bare list was read as several forms, so a macro returning `((make-adder 10) 5)' -- a call of what make-adder returns -- was spliced into two. Add a new $ char to denote splicing, so ($ form ...) splices.
399 lines
20 KiB
Scheme
399 lines
20 KiB
Scheme
;;; 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 condition)
|
|
(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 (error-message source)
|
|
"Compile SOURCE and return the error text as the user sees it --
|
|
message plus arguments, the way CHICKEN prints it -- or #f if SOURCE
|
|
compiles."
|
|
(handle-exceptions e
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(display ((condition-property-accessor 'exn 'message) e))
|
|
(for-each (lambda (a) (display " ") (write a))
|
|
((condition-property-accessor 'exn 'arguments) e))))
|
|
(begin (sex->c source) #f)))
|
|
|
|
(define (reports? source fragment)
|
|
(let ((m (error-message source)))
|
|
(and m (string-contains m 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)")))
|
|
|
|
;; A comment among a call's arguments used to become an argument,
|
|
;; and c-apply put a comma on each side of it -- which does not
|
|
;; compile. It is dropped, as in any other expression context.
|
|
(test-group "comments among arguments"
|
|
(test-assert "no stray comma"
|
|
(not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
|
|
(test-assert "the arguments survive"
|
|
(emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
|
|
|
|
;; The reader leaves the `;'s that introduced each line, and a run of
|
|
;; comment lines arrives as one form per line.
|
|
(test-group "comment rendering"
|
|
(test-assert "the markers are stripped"
|
|
(emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
|
|
(test-assert "so none survive into the C"
|
|
(not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
|
|
(test-assert "consecutive lines are packed into one comment"
|
|
(emits? "(fn f () void\n ;; first\n ;; second\n (g))"
|
|
"/* first\n second */"))
|
|
;; Packing compares locations rather than just looking for adjacent
|
|
;; comment forms, so a blank line still separates them.
|
|
(test-assert "a blank line keeps them apart"
|
|
(emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
|
|
|
|
;; A `;' comment is a form, so one written inside a construct with
|
|
;; positional slots used to land in a slot and shift everything after
|
|
;; it -- silently. In an `if' the comment became the then-arm and the
|
|
;; then-arm became an `else if' condition, and it still compiled.
|
|
;; Comments are now taken out of the slots and emitted just before the
|
|
;; statement; comments in a body stay where they were written.
|
|
(test-group "comments in positional slots"
|
|
(test-assert "an if arm is not shifted"
|
|
(not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
|
|
(test-assert "and both arms survive"
|
|
(emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
|
|
(test-assert "the comment survives too"
|
|
(emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
|
|
(test-assert "a for header is not shifted"
|
|
(emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
|
|
"for (int i = 0; i < 2; ++i)"))
|
|
(test-assert "a while condition is not shifted"
|
|
(emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
|
|
(test-assert "a var is not shifted"
|
|
(emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
|
|
(test-assert "a cast is not shifted"
|
|
(emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
|
|
;; Bodies are a statement sequence, so comments there stay put.
|
|
(test-assert "a comment in a body stays in the body"
|
|
(emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
|
|
"while (a < b) {")))
|
|
|
|
(test-group "pub enum"
|
|
(test-assert "is emitted"
|
|
(emits? "(pub enum color (red green blue))" "enum color"))
|
|
(test-assert "with its values"
|
|
(emits? "(pub enum color (red green blue))" "red"))
|
|
(test-assert "and a non-pub enum still is too"
|
|
(emits? "(enum color (red green blue))" "enum color"))
|
|
;; Naming an enum as a type, rather than defining it, had no
|
|
;; walk-enum clause and died with `(match) no matching pattern'
|
|
(test-assert "and it can then be used as a type"
|
|
(emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
|
|
"enum color m = red"))
|
|
(test-assert "a malformed enum is rejected with its location"
|
|
(reports? "(enum)" "codegen.sex:1:"))
|
|
;; c-type handed the declarator's name to c-enum as the enum tag,
|
|
;; so this emitted `enum m { up, down }' with no variable at all
|
|
(test-assert "an anonymous enum keeps the variable"
|
|
(emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
|
|
(test-assert "and a named definition keeps both"
|
|
(emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
|
|
|
|
;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
|
|
;; no |symbol| syntax for them to collide with -- but fmt-c cannot
|
|
;; dispatch on a symbol whose name it cannot write in Scheme source,
|
|
;; so they used to fall through to the function-call path and emit
|
|
;; `|\||(a, b)'. The writer renames them to heads fmt-c spells with
|
|
;; a string.
|
|
(test-group "bitwise and logical operators"
|
|
(test-assert "bit-or"
|
|
(emits? (in-fn "(var x int (| a b))") "int x = a | b"))
|
|
(test-assert "logical or"
|
|
(emits? (in-fn "(var x int (|| a b))") "int x = a || b"))
|
|
(test-assert "or-assign"
|
|
(emits? (in-fn "(|= a b)") "a |= b"))
|
|
(test-assert "bit-and"
|
|
(emits? (in-fn "(var x int (& a b))") "int x = a & b"))
|
|
(test-assert "logical and"
|
|
(emits? (in-fn "(var x int (&& a b))") "int x = a && b"))
|
|
|
|
;; Precedence too: the operator reaches fmt-c as a string it looks
|
|
;; up, not as a symbol in its table
|
|
(test-assert "parenthesised where C needs it"
|
|
(emits? (in-fn "(var x int (& (| a b) a))") "(a | b) & a"))
|
|
(test-assert "and left alone where it does not"
|
|
(emits? (in-fn "(var x int (| a (& a b)))") "int x = a | a & b"))
|
|
|
|
;; The spelling from before they could be written directly
|
|
(test-assert "c-or is still accepted"
|
|
(emits? (in-fn "(var x int (c-or a b))") "a || b"))
|
|
(test-assert "c-bit-or is still accepted"
|
|
(emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
|
|
|
|
;; A `;' comment is a form. In a macro body `comment' is a no-op
|
|
;; that swallows the comment itself. Inside a quasiquoted payload
|
|
;; the same form is data, never evaluated, and reaches the writer
|
|
;; intact
|
|
(test-group "comments in macros"
|
|
(test-assert "a comment in the payload reaches the C"
|
|
(emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)"
|
|
"this survives"))
|
|
(test-assert "a comment about the macro does not"
|
|
(not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)"
|
|
"this vanishes")))
|
|
(test-assert "and the macro still expands"
|
|
(emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)"
|
|
"void f (void)")))
|
|
|
|
;; Diagnostics name also the place. Every form carries a (file
|
|
;; . line), so an error can cite it
|
|
(test-group "errors cite the source location"
|
|
(test-assert "unknown toplevel form"
|
|
(reports? "(include stdio.h)\n(wat 1 2)" "codegen.sex:2: unknown top level form"))
|
|
(test-assert "the offending form is shown too"
|
|
(reports? "(include stdio.h)\n(wat 1 2)" "(wat 1 2)"))
|
|
(test-assert "pub with nothing to define"
|
|
(reports? "(pub 1)" "codegen.sex:1:")))
|
|
|
|
;; A nested pointer chain used to silently lose a level:
|
|
;; (var p (* (* char))) emitted `char *p'
|
|
(test-group "malformed types are rejected"
|
|
(test-assert "nested pointer chain"
|
|
(reports? (in-fn "(var p (* (* char)))") "pointer chains are written flat"))
|
|
(test-assert "and names the line"
|
|
(reports? "(pub fn f () void\n (var p (* (* char))))" "codegen.sex:2:"))
|
|
;; A sublist that only groups has no `*' in it and must still work.
|
|
(test-assert "grouping sublist still accepted"
|
|
(emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
|
|
(test-assert "flat chain still accepted"
|
|
(emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
|
|
|
|
;; A string as the first body form (or after the name of a struct,
|
|
;; union or enum) is a docstring: it becomes a comment immediately
|
|
;; before the declaration, not a statement inside it.
|
|
(test-group "docstrings"
|
|
(test-assert "appears before the function"
|
|
(emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
|
|
"/* Greet NAME. */"))
|
|
(test-assert "and not inside the body as a statement"
|
|
(not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
|
|
"\"Greet NAME.\"")))
|
|
(test-assert "multiline keeps its paragraphs"
|
|
(emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
|
|
"Entry point."))
|
|
(test-assert "and the second paragraph too"
|
|
(emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
|
|
"ARGC and ARGV."))
|
|
(test-assert "a prototype with only a docstring stays a prototype"
|
|
(emits? "(fn helper ((a int)) int \"Forward.\")"
|
|
"helper (int a);"))
|
|
(test-assert "a string after the first statement is left alone"
|
|
(emits? "(fn f () void (g) \"not a docstring\")"
|
|
"\"not a docstring\""))
|
|
(test-assert "a struct docstring sits above the struct"
|
|
(emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
|
|
"/* A 2D point. */"))
|
|
(test-assert "and an enum docstring too"
|
|
(emits? "(enum color \"RGB.\" (red green blue))"
|
|
"/* RGB. */")))
|
|
|
|
;; `static-assert' is the keyword rather than the <assert.h> macro, so
|
|
;; a static assertion costs no include. Mapped in `atom-to-fmt-c'
|
|
;; because `unkebabify' alone would spell it `static_assert'.
|
|
(test-group "static-assert"
|
|
(test-assert "emits the C11 keyword"
|
|
(emits? (in-fn "(static-assert (== (sizeof int) 4) \"int is four bytes\")")
|
|
"_Static_assert(sizeof(int) == 4, \"int is four bytes\")"))
|
|
(test-assert "and not the header macro"
|
|
(not (emits? (in-fn "(static-assert (== (sizeof int) 4) \"x\")")
|
|
"static_assert("))))
|
|
|
|
;; A closure is a code pointer beside its captures. The struct is
|
|
;; named from the signature, so separate translation units agree on
|
|
;; it, and calling one goes through `code' with `env' passed first.
|
|
;;
|
|
;; A closure struct, and the helper its calls go through, are each
|
|
;; emitted once per signature; the registries deciding that are
|
|
;; compile-time state like the type databases, and outlive a single
|
|
;; `sex->c' here. So every case below that looks for a *definition*
|
|
;; uses a signature of its own -- cases looking at a call site can
|
|
;; share one.
|
|
(test-group "closures"
|
|
(test-assert "the type becomes a struct named for its signature"
|
|
(emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
|
|
"struct ƛint_int"))
|
|
;; The environment is one shared union, declared in the prelude --
|
|
;; its layout is part of the ABI two units agree on, so it cannot
|
|
;; depend on what either file contains. `sex->c' has no prelude, so
|
|
;; what is visible here is the member
|
|
(test-assert "whose environment is the shared union"
|
|
(emits? "(fn f ((c (closure ((float)) int))) int (return (c 1.0)))"
|
|
"union ƛenv env;"))
|
|
;; The receiver goes through a helper rather than being written
|
|
;; out twice, so that `[table (++ i)]' evaluates its index once,
|
|
;; exactly as it would for an array of function pointers
|
|
(test-assert "a call passes the receiver to a helper"
|
|
(emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
|
|
"ƛint_int_call(c, 1)"))
|
|
(test-assert "and the helper is what dereferences it"
|
|
(emits? "(fn f ((c (closure ((long)) int))) int (return (c 1)))"
|
|
"ƛc.code(&ƛc.env, ƛa0)"))
|
|
(test-assert "a subscript receiver is evaluated once"
|
|
(emits? "(fn f ((t (¤ (closure ((int)) int) 4)) (i int)) int (return ((¤ t (++ i)) 1)))"
|
|
"ƛint_int_call(t[++i], 1)"))
|
|
(test-assert "so is a member receiver"
|
|
(emits? "(struct h ((cb (closure ((int)) int))))
|
|
(fn f ((s (struct h))) int (return ((. s cb) 1)))"
|
|
"ƛint_int_call(s.cb, 1)"))
|
|
(test-assert "a captured name is rebound in the lifted body"
|
|
(emits? "(fn f ((n int)) (closure ((char)) int) (return (closure ((x char)) int (n) (return n))))"
|
|
"int n = ƛcaptures->n;"))
|
|
(test-assert "captures are checked against the environment"
|
|
(emits? "(fn f ((n int)) (closure ((short)) int) (return (closure ((x short)) int (n) (return n))))"
|
|
"_Static_assert(sizeof(struct"))
|
|
;; A closure over nothing has no record to point at, and C has no
|
|
;; empty struct to declare for it
|
|
(test-assert "no captures means no capture record"
|
|
(not (emits? "(fn f () (closure () int) (return (closure () int () (return 7))))"
|
|
"_captures {")))
|
|
;; The receiver is written twice, so a name used as an argument
|
|
;; must not be mistaken for a call of its own
|
|
(test-assert "a closure passed as an argument stays a value"
|
|
(emits? "(fn g ((c (closure ((int)) int))) int (return 0))
|
|
(fn f ((c (closure ((int)) int))) int (return (g c)))"
|
|
"g(c)")))
|
|
|
|
;; `(car res)' on the expansion assumed it was a pair, so a macro
|
|
;; computing a value rather than building a form crashed the compiler.
|
|
(test-group "macro expanding to an atom"
|
|
(test-assert "a number"
|
|
(emits? "(defmacro (two) 2) (fn f () int (return (two)))"
|
|
"return 2;"))
|
|
(test-assert "a string"
|
|
(emits? "(defmacro (who) \"sex\") (fn f () void (g (who)))"
|
|
"g(\"sex\")"))
|
|
;; a symbol expansion can stand where a type does, which is what
|
|
;; makes a macro able to compute one
|
|
(test-assert "a symbol, used as a type"
|
|
(emits? "(defmacro (ty) 'int) (fn f () void (var x (ty) 0))"
|
|
"int x = 0"))
|
|
;; ...and nothing at all, for a macro that only registers something
|
|
(test-assert "nothing, at toplevel"
|
|
(emits? "(defmacro (quiet) (list)) (quiet) (fn f () int (return 1))"
|
|
"return 1;"))
|
|
(test-assert "nothing, in a body"
|
|
(emits? "(defmacro (quiet) (list)) (fn f () int (quiet) (return 1))"
|
|
"return 1;"))
|
|
;; several forms need `$', which is what tells a splice from a call
|
|
(test-assert "$ splices"
|
|
(emits? "(defmacro (pair) (list '$ '(fn a () int (return 1))
|
|
'(fn b () int (return 2))))
|
|
(pair)"
|
|
"b (void)"))
|
|
(test-assert "and ($) is nothing at all"
|
|
(emits? "(defmacro (quiet) (list '$)) (quiet) (fn f () int (return 1))"
|
|
"return 1;")))
|
|
|
|
;; A unary expression parenthesised its operand rather than itself, so
|
|
;; the parens landed inside: `*(p).x', which C reads as `*(p.x)'.
|
|
(test-group "unary operand precedence"
|
|
(test-assert "member access through a dereference"
|
|
(emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
|
|
"(*p).x"))
|
|
(test-assert "and not with the parens inside"
|
|
(not (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
|
|
"*(p).x")))
|
|
(test-assert "member access through a cast"
|
|
(emits? (in-fn "(var n int (. (* (cast a (* (struct s)))) f))")
|
|
"(*(struct s*)a).f"))
|
|
;; ...without gaining parens where none are due
|
|
(test-assert "a bare dereference is left alone"
|
|
(emits? (in-fn "(var p (* int) 0) (= a (* p))") "a = *p"))
|
|
(test-assert "so is address-of in an argument"
|
|
(emits? (in-fn "(g (& a))") "g(&a)"))
|
|
(test-assert "and negation beside a binary operator"
|
|
(emits? (in-fn "(var n int (+ (- a) b))") "-a + b")))
|
|
|
|
;; An array bound was taken only when it was an integer literal, so a
|
|
;; symbolic one fell into the type: `(¤ int N)' came out `int N a[]'.
|
|
(test-group "array bounds"
|
|
(test-assert "a symbolic bound"
|
|
(emits? "(define N 4) (struct s ((a (¤ int N))))" "int a[N]"))
|
|
(test-assert "an expression bound"
|
|
(emits? "(define N 4) (struct s ((a (¤ char (* 2 N)))))" "char a[2 * N]"))
|
|
(test-assert "an integer bound still works"
|
|
(emits? "(struct s ((a (¤ int 4))))" "int a[4]"))
|
|
;; a multi-word type is keywords all the way down, so a trailing
|
|
;; keyword belongs to the type and leaves the array unsized
|
|
(test-assert "a multi-word type is not a bound"
|
|
(emits? "(struct s ((a (¤ unsigned int))))" "unsigned int a[]"))
|
|
;; ...and a tag always follows its keyword
|
|
(test-assert "nor is an aggregate tag"
|
|
(emits? "(struct t ((z int))) (struct s ((a (¤ struct t))))" "struct t a[]"))
|
|
(test-assert "nor one behind a pointer"
|
|
(emits? "(struct t ((z int))) (struct s ((a (¤ * struct t))))" "struct t* a[]"))))
|