Make Sex templates more pleasant syntactically

No more unquotes to instantiate templates.
Also no need to pass quoted substitution lists, just use them as
regular lisp macros.

.gitignore

@@ -1,3 +0,0 @@
-*.o
-sexc
-sex-tests

Makefile

@@ -1,21 +1,19 @@
 CHICKEN_C = csc
-CSC_FLAGS = -K prefix
 
-MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
+MODULES = sexc templates main
 OBJ = $(MODULES:%=%.o)
 
-sexc: main.o $(OBJ)
+# chicken flags
-	$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
+CFLAGS = -compile-syntax
+
+sexc: $(OBJ)
+	$(CHICKEN_C) $^ -o $@
 
 main.o: main.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@
+	$(CHICKEN_C) $< -c -o $@
 
 %.o: %.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@
+	$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
-
-sex-tests: $(OBJ) tests/*.scm
-	cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests
 
 clean:
-	rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o
+	rm -f $(OBJ) sexc

Readme.org

@@ -1,71 +1,66 @@
 * The Sex language
-Sex is a S-expressions language. Sex is written in Chicken, which is a
+Sex is a S-expressions language, which transpiles to C.
-[[https://call-cc.org][R5RS Scheme]].
-Sex is statically typed, compiled general purpose language.
 
-* Compilation
+Sex is also Chicken, since all source processing and compile-time
-First, get yourself a Chicken, then, some Chicken deps. You also will
+computations are written in Chicken.
-need a C compiler.
+
+And Chicken is [[https://call-cc.org][R5RS Scheme]].
+
+* Compilation and usage
+First, get yourself a Chicken. Second, some Chicken deps.
 
 ** Install Chicken Eggs
-Tip: there's a way to make Chicken install eggs non-globally. You need
+By the way, there's a way to make Chicken install eggs non-globally. Refer to
-to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
+the documentation for more info:
-environment variables. Refer to the documentation for more info:
 https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
 
-~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable~
+~chicken-install fmt getopt-long brev-separate~
 
 ** Compilation
 ~make~
 
-* Usage
+** Usage
-** Summary
+You'll also need a C compiler, so pick any.
 #+begin_src
-Usage: sexc [options] filename [-- options-for-c-compiler]
+cat hello-world.sex | sexc > hello_world.c
-Options:
+cc hello_world.c -o hello_world
- --c-compiler=ARG         Select C compiler. Defaults to value of SEX_CC
-                          environment variable, or if it is empty, to cc
- -c, --compile-object     Compile object file instead of executable program
- -C, --preprocess         Emit C code
- --public-interface       Get module's public interface
- -h, --help               Show this help
- -m, --macro-expand       Emit macro-expanded semantically processed Sex code
-                          (sort of IR). May be useful for debugging
- -o, --output=ARG         Write output to file. Default file name is a.out.
-                          If -E or -m options are provided, defaults to stdout
-#+end_src
-** Compiling Hello World
-#+begin_src shell
-sexc ./examples/hello-world.sex -o hello
 #+end_src
 
-That's it. Now you should have executable named ~hello~ in your
+* Example
-directory. Sex uses C under the hood, the default C compiler is ~cc~,
+Here is an example, demonstrating what Sex source looks like, and what
-but you can pass any using ~--c-compiler~ option, or by setting
+it compiles too. An avid reader also shall notice how we call Chicken
-~SEX_CC~ environment variable.
+procedures in Sex source.
 
-** Example
+The Sex source:
-An example of Sex source:
+#+begin_src
-#+begin_src scheme
 (include stdio.h)
 
+(define (foo)
+  "Hello from Chicken code!\n")
+
 (pub fn int main ((int argc) (char **argv))
     (puts "Hello from Sex!")
     (var (array char 512) name)
     (puts "What is your name?")
-  (scanf "%s" (cast char* &name))
+    (scanf "%s" &name)
     (printf "Hello, %s!\n" name)
+    (printf ,(foo))
     0)
 #+end_src
 
-Compile and run:
+The resulting C source:
-#+begin_src shell
+#+begin_src
-~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
+#include <stdio.h>
-~/dev/sex $ ./hello-world
+
-Hello from Sex!
+int main (int argc, char **argv) {
-What is your name?
+    puts("Hello from Sex!");
-Alex
+    char name[512];
-Hello, Alex!
+    puts("What is your name?");
+    scanf("%s", &name);
+    printf("Hello, %s!\n", name);
+    printf("Hello from Chicken code!\n");
+    return 0;
+}
 #+end_src
 
 * Features
@@ -73,65 +68,143 @@ Hello, Alex!
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
 have is C.
 
-*** Auto kebabification
 For hardcore fans of traditional Lisp naming convention,
-Sex offers automatic kebabification of all symbols, i.e. no more
+Sex offers automatic unkebabification of all symbols, i.e. no more
 ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
-** Modules
+** Auto typedef for structs
-Each source file is a module. Module can provide public interface and
+Probably harmless idk. Example:
-be imported by using ~(import path/to/module)~ expression. Module
+#+begin_src
-search path consists of two parts: first is relative to the source
+(struct foo
-being compiled location, and the second is ~SEX_MODULE_PATH~
+  ((float a)
-environment variable.
+   (int b)))
+#+end_src
+expands to
+#+begin_src
+typedef struct foo foo;
 
-Module's public interface consists of everything declared
+struct foo {
-~pub~. Structures, function, macros, types, variables can be
+    float a;
-public.
+    int b;
+};
+#+end_src
 
-** Syntactic macros
+** Syntactic templates
-Sex has support for syntactic macros. Macro definitions look like
+Sex has support for template substitutions. Any piece of code can be
-functions: they have a name, an argument list and a body. Macro should
+templated. Template declarations look like functions: they have a
-return Sex code.
+name, an argument list and a body. When declared template is
+encountered during reading of Sex code, its body will udergo syntactic
+rewriting using the provided values by the following rules:
+1. If the value is a symbol, all arguments in a body are replaced with
+   the value, and also all /parts/ of any other symbol equal to the
+   value also get replaced.
+2. If the value is a non-symbolic form, all arguments in a body are
+   replaced with it, but no symbolic substitution is performed.
+
+Formally, template declaration has the following syntax:
+#+begin_src
+(template (name . substitute-args) . body)
+#+end_src
 
 *** Examples:
 **** Structure with templated value type
-#+begin_src scheme
+#+begin_src
-(pub defmacro (list-T type)
+(template (foo ?T)
-  (let ((list-type (cat 'list- type)))
+  (struct foo-?T
-    `(struct ,list-type
+    ((?T value))))
-       ((,type value)
-        ((* ,list-type) next)))))
 
-(list-T int)
+(foo float)
 #+end_src
 ->
-#+begin_src scheme
+#+begin_src
-(struct list_int
+typedef struct foo_float foo_float;
- ((int value)
+
-  ((* list_int) next)))
+struct foo_float {
+    float value;
+};
 #+end_src
 
-**** Wrapper for checking return codes
+Note that ~?~ at the start of template argument is not syntax, just
-#+begin_src scheme
+convention.
-(pub defmacro (check-sdl-return call message ret-code)
-  `(if (< 0 ,call)
-       (begin
-         (puts ,message)
-         (return ,ret-code)))))
 
-(pub fn int init ()
+**** Wrapper for checking return codes
+#+begin_src
+(template (check-sdl-return call message ret-code)
+  (if (< 0 call)
+      (begin
+       (puts message)
+       (return ret-code))))
+
+(fn int init ()
   (check-sdl-return
     (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
 ...)
 #+end_src
 ->
-#+begin_src c
+#+begin_src
-(%fun int init ()
+static int init () {
-  (if (< 0 (SDL_Init SDL_INIT_VIDEO))
+    if (0 < SDL_Init(SDL_INIT_VIDEO)) {
-    (%begin (puts "Failed to initialize SDL") (return 1)))
+        puts("Failed to initialize SDL");
-  ...)
+        return 1;
+    }
+    return 0;
+}
+#+end_src
+
+**** A bit of everything
+#+begin_src
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
+     (printf "\n"))
+#+end_src
+Then will be expanded in the following code:
+#+begin_src
+(typedef struct list_int list_int)
+(struct list_int ((int value) ((* list_int) next)))
+(%fun void
+      print_list
+      (((const list_int) *l))
+      (%var int v (-> l value))
+      (while (!= (-> l next) NULL)
+             (printf "%d " v)
+             (= l (-> l next))
+             (= v (-> l value)))
+      (printf "\n"))
+#+end_src
+
+And then translated to:
+#+begin_src
+typedef struct list_int list_int;
+
+struct list_int {
+    int value;
+    list_int *next;
+};
+
+void print_list (const list_int *l) {
+    int v = l->value;
+    while (l->next != NULL) {
+        printf("%d ", v);
+        l = l->next;
+        v = l->value;
+    }
+    printf("\n");
 }
 #+end_src
 
@@ -142,8 +215,10 @@ best option.
 *** sex-mode.el
 To harness the power of sex-mode, add the following lines to your
 ~$HOME/.config/emacs/init.el~:
-#+begin_src emacs-lisp
+#+begin_src
 (use-package sex-mode
   :load-path "/path/to/sex"
-  :mode ("\\.sex\\'"))
+  :mode ("\\.sex\\'" "\\.seh\\'"))
 #+end_src
+
+** COMING SOON?: Polymorphism

example/fns.sex

@@ -1,10 +0,0 @@
-;;; Prototypes
-(fn void puk ())
-
-(pub fn void plak ())
-
-;;; Functions
-(fn int foo () (return 1))
-
-(pub fn void bar ((int a) (int b))
-  (printf "%d\n" (+ a b)))

example/hello-world.sex

@@ -1,9 +0,0 @@
-(include stdio.h)
-
-(pub fn int main ((int argc) (char **argv))
-  (puts "Hello from Sex!")
-  (var (array char 512) name)
-  (puts "What is your name?")
-  (scanf "%s" (cast char* &name))
-  (printf "Hello, %s!\n" name)
-  (return 0))

example/lambdas.sex

@@ -1,38 +0,0 @@
-(include stdio.h)
-
-(fn int sum ((int a) (int b))
-  (return (+ a b)))
-
-(pub fn int main ()
-  (var int a 10)
-  (var int b 20)
-  (var (fn int ((int) (int))) sum-fn sum)
-
-  (var (fn int ((int) (int))) sum-lambda
-
-       (lambda int ((int a) (int b)) ()
-         (return (+ a b))))
-
-  (var (fn int ((int))) sum-lambda-2
-
-       (lambda int ((int a)) ()
-         (return (+ a 20))))
-
-  (printf "Hello from main fn!\n")
-  (printf "We will now perform some function calling.\n")
-
-  (printf "Calling fn ptr: %d\n" (sum-fn a b))
-  (printf "Calling lambda: %d\n" (sum-lambda a b))
-  (printf "Calling other lambda: %d\n" (sum-lambda-2 a))
-  (printf "Calling lambda inplace: %d\n" ((lambda int ((int a) (int b)) ()
-                                            (return (+ a b 100)))
-                                          a b))
-
-  (var (fn int ((int))) l-1
-       (lambda int ((int a)) ()
-         (var (fn int ((int))) l-2
-              (lambda int ((int a)) ()
-                (return (+ 60 a))))
-         (return (+ 600 (l-2 a)))))
-  (printf "Calling nested lambdas: %d\n" (l-1 6))
-  (return 0))

example/list.seh

@@ -0,0 +1,36 @@
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (make-list-T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn (* list-?T) make-list-?T ()
+   (var (* list-?T) list (cast (* list-?T) (malloc (sizeof list-?T))))
+   (= (-> list next) NULL)
+   list))
+
+(template (add-value-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn void add-value-list-?T ((list-?T *list) (T value))
+       (while (!= (-> list next) NULL)
+         (= list (-> list next)))
+       (= (-> list next) (make-list-?T))
+       (= (-> list value) value)))
+
+(template (length-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn size-t length-list-?T ((list-?T *list))
+   (var size-t n 0)
+   (while (!= (-> list next) NULL)
+     (= list (-> list next))
+     (++ n))
+   n))
+
+(template (is-empty-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn bool is-empty-list-?T ((list-?T *list))
+    (== (-> list next) NULL)))
+
+(template (list-for-each list-var elt-var what-do)
+  (var int elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    what-do
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))

example/list.sex

@@ -1,47 +0,0 @@
-(pub defmacro (list-T type)
-  (let ((list-type (cat 'list- type)))
-    `(struct ,list-type
-       ((,type value)
-        ((* (struct ,list-type)) next)))))
-
-(pub defmacro (make-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'make-list- type)))
-    `(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
-      (var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type))))
-      (= (-> list next) NULL)
-      (return list))))
-
-(pub defmacro (add-value-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'add-value-list- type)))
-    `(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
-      (while (!= (-> list next) NULL)
-        (= list (-> list next)))
-      (= (-> list next) (,(cat 'make-list- type)))
-      (= (-> list value) value))))
-
-(pub defmacro (length-list-T type is-public?)
-  (let ((fn-name (cat 'length-list- type))
-        (list-type (list 'struct (cat 'list- type))))
-    `(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list))
-      (var size-t n 0)
-      (while (!= (-> list next) NULL)
-        (= list (-> list next))
-        (++ n))
-      (return n))))
-
-(pub defmacro (is-empty-list-T type is-public?)
-  `(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type)
-    ((,(list 'struct (cat 'list- type)) *list))
-    (return (== (-> list next) NULL))))
-
-(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
-  (let ((list-var-2 (cat list-var '-2)))
-    `(begin
-      (var (pointer ,list-type) ,list-var-2 ,list-var)
-      (var ,elt-type ,elt-var (-> ,list-var-2 value))
-      (while (!= (-> ,list-var-2 next) NULL)
-        ,what-do
-        (= ,list-var-2 (-> ,list-var-2 next))
-        (= ,elt-var (-> ,list-var-2 value))))))

example/test-list.sex

@@ -1,8 +1,14 @@
 (include stdlib.h)
 (include stddef.h)
+(include stdbool.h)
 (include stdio.h)
 
-(import list)
+(chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
+
+(chicken-load "list.seh")
+
+(chicken-define (imports-test a b c)
+  (fold + 0 (list 1 2 3 a b c)))
 
 (struct foo
   ((float a-field)
@@ -10,34 +16,54 @@
    ((const char *) c)
    ((fn bool ((bool val))) not)))
 
-(var (struct foo) f)
+(var foo f #((= .a-field 1.2)))
 
 (list-T int)
-(make-list-T int #f)
+(make-list-T int)
-(add-value-list-T int #f)
+(add-value-list-T int)
-(length-list-T int #f)
+(length-list-T int)
-(is-empty-list-T int #f)
+(is-empty-list-T int)
 
 (extern fn void puk ((int a) (float b)))
-(pub fn bool baz () (return true))
+(fn int bar () ,(imports-test 10 20 30))
+(pub fn void baz () true)
 
 (extern var int i)
 (var int j)
 (pub var int k)
 
 (pub fn int main ()
-     (var (struct list-int) *l (make-list-int))
+     (var (* list-int) l (make-list-int))
-     (printf "Size of the list: %lu\n" (length-list-int l))
+     (printf "Size of the list: %zu\n" (length-list-int l))
      (add-value-list-int l 3)
      (add-value-list-int l 4)
-     (printf "Size of the list: %lu\n" (length-list-int l))
+     (printf "Size of the list: %zu\n" (length-list-int l))
-     (list-for-each (struct list-int) l int v
+     (list-for-each l v
        (printf "%d " v))
      (printf "\n")
-     (printf "Size of the list: %lu\n" (length-list-int l))
+     (printf "%zu\n" l->next)
-     (printf "%p\n" (cast void* l->next))
+     0)
-     (return 0))
 
-(pub fn void print-list (((const struct list-int) *l))
+(pub fn segs-renderer* create-renderer ())
-     (list-for-each (const struct list-int) l int v (printf "%d " v))
+(pub fn void clear-command-buffer ((segs-renderer *r)))
+(pub fn void add-render-command ((segs-renderer *r) ((fn void ()) command)))
+(pub fn void commit-command-buffer ((segs-renderer *r)))
+
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
      (printf "\n"))

fmt-c-writer.scm

@@ -1,128 +0,0 @@
-;;; Sex fmt-c output writer
-
-(declare (unit fmt-c-writer)
-         (uses fmt-c
-               semen))
-
-(import (chicken string)
-        brev-separate
-        fmt
-        regex
-        srfi-1                          ; lists
-        srfi-13                         ; strings
-        )
-
-(define (unkebabify sym)
-  (case sym
-    ((-) sym)
-    ((--) sym)
-    ((->) sym)
-    ((-=) sym)
-    (else
-     (string->symbol
-      (string-substitute "-(?!>)" "_"
-                         (symbol->string sym) #t)))))
-
-(define (atom-to-fmt-c atom)
-  (case atom
-    ((fn) '%fun)
-    ((prototype) '%prototype)
-    ((var) '%var)
-    ((begin) '%block-begin)
-    ((define) '%define)
-    ((pointer) '%pointer)
-    ((array) '%array)
-    ((attribute) '%attribute)
-    ((@) 'vector-ref)
-    ((include) '%include)
-    ((cast) '%cast)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
-    (else
-     (if (symbol? atom)
-         (unkebabify atom)
-         atom))))
-
-(define (make-field-access form)
-  (assert
-   (= 2 (length form)) "Wrong field access format")
-  (unkebabify
-   (string->symbol
-    (fmt #f (cadr form) (car form)))))
-
-(define (walk-generic form acc)
-  (cond
-   ((null? form) (cons '() acc))
-
-   ;; vector, e.g. {}-initializer
-   ((vector? form)
-    (cons
-     (list->vector
-      (car (walk-generic (vector->list form) (list))))
-     acc))
-
-   ;; atom (hopefully)
-   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
-
-   ;; another special case - field access
-   ((and (symbol? (car form))
-         (char=? #\. (string-ref (symbol->string (car form)) 0)))
-    (cons (make-field-access form) acc))
-
-   ;; toplevel, or a start of a regular list form
-   (else
-    (let ((new-acc (list)))
-      (cons (fold-right
-             walk-generic
-             new-acc
-             form)
-            acc)))))
-
-(define (normalize-fn-form form)
-  ;; (fn ret-type name arglist body) -> normal function
-  ;; (fn ret-type name arglist) -> prototype
-  (if (>= (length form) 5)
-      form
-      (cons 'prototype (cdr form))))
-
-(define (walk-function form static)
-  (if static
-      (walk-generic (list 'static (normalize-fn-form form))
-                    (list))
-      (walk-generic (normalize-fn-form (cdr form))
-                    (list))))
-
-(define (walk-extern form)
-  (case (cadr form)
-    ((fn)
-     (list (cons 'extern (walk-function form #f))))
-    ((var)
-     (list (cons 'extern (walk-generic (cdr form) (list)))))
-    (else (error "Extern what?"))))
-
-(define (walk-public form)
-  (case (cadr form)
-    ((fn)
-     (walk-function form #f))
-    ((var)
-     (walk-generic (list 'static (cdr form)) (list)))
-    ((define defmacro import include struct typedef union var)
-     ;; ignore here, used in generating public interface
-     (process-toplevel-form (cdr form)))
-    (else
-     (error "Pub what?" (cadr form)))))
-
-(define (process-toplevel-form form)
-  ;; todo: rewrite to match
-  (case (car form)
-    ((fn) (walk-function form #t))
-    ((extern) (walk-extern form))
-    ((pub) (walk-public form))
-    (else (walk-generic form (list)))))
-
-(define (emit-c sex-forms)
-  (for-each (lambda (form)
-              (fmt #t (c-expr (car (process-toplevel-form form))) nl))
-            sex-forms))

fmt-c.scm

@@ -1,919 +0,0 @@
-;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
-;;
-;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
-;; BSD-style license: http://synthcode.com/license.txt
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; additional state information
-
-(declare (unit fmt-c))
-
-(import fmt
-        srfi-13)
-
-(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
-(define (fmt-macro-params st) (fmt-ref st 'macro-params))
-(define (fmt-expression? st) (fmt-ref st 'expression?))
-(define (fmt-return? st) (fmt-ref st 'return?))
-(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
-(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
-(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
-(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
-(define (fmt-indent-space st) (fmt-ref st 'indent-space))
-(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
-(define (fmt-op st) (fmt-ref st 'op 'stmt))
-(define (fmt-gen st) (fmt-ref st 'gen))
-
-(define (c-in-expr proc) (fmt-let 'expression? #t proc))
-(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
-(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc))
-
-(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
-(define (c-with-op op proc) (fmt-let 'op op proc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; be smart about operator precedence
-
-(define (c-op-precedence x)
-  (if (string? x)
-      (cond
-        ((or (string=? x ".") (string=? x "->")) 10)
-        ((or (string=? x "++") (string=? x "--")) 20)
-        ((string=? x "&") 55)
-        ((string=? x "|") 65)
-        ((string=? x "&&") 70)
-        ((string=? x "||") 75)
-        ((string=? x "|=") 85)
-        ((or (string=? x "+=") (string=? x "-=")) 85)
-        (else 95))
-      (case x
-        ;;((|::|) 5) ; C++
-        ((dot arrow post-decrement post-increment) 10)
-        ((**) 15)                       ; Perl
-        ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
-        ((=~ !~) 25)                    ; Perl
-        ((* / %) 30)
-        ((+ -) 35)
-        ((<< >>) 40)
-        ((< > <= >=) 45)
-        ((lt gt le ge) 45)              ; Perl
-        ((== !=) 50)
-        ((eq ne cmp) 50)                ; Perl
-        ((&) 55)
-        ((^) 60)
-        ;;((|\||) 65)
-        ((&& %and) 70)
-        ((%or) 75)
-        ;;((|\|\||) 75)
-        ;;((.. ...) 77)                   ; Perl
-        ((?) 80)
-        ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ;  += -=
-        ((comma) 90)
-        ((=>) 90)                       ; Perl
-        ((not) 92)                      ; Perl
-        ((and) 93)                      ; Perl
-        ((or xor) 94)                   ; Perl
-        ((paren bracket) 100)
-        (else 95))))
-
-(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y)))
-(define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y)))
-
-(define (c-paren x) (cat "(" (c-expr x) ")"))
-
-(define (c-maybe-paren op x)
-  (lambda (st)
-    ((fmt-let 'op op
-              (if (c-op<= (fmt-op st) op)
-                  (c-paren x)
-                  x))
-     st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; default literals writer
-
-(define (c-control-operator? x)
-  (memq x '(if while switch repeat do for fun begin)))
-
-(define (c-literal? x)
-  (or (number? x) (string? x) (char? x) (boolean? x)))
-
-(define (char->c-char c)
-  (string-append "'" (c-escape-char c #\') "'"))
-
-(define (c-escape-char c quote-char)
-  (let ((n (char->integer c)))
-    (if (<= 32 n 126)
-        (if (or (eqv? c quote-char) (eqv? c #\\))
-            (string #\\ c)
-            (string c))
-        (case n
-          ((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
-          ((11) "\\v") ((12) "\\f") ((13) "\\r")
-          (else (string-append "\\x" (number->string (char->integer c) 16)))))))
-
-(define (c-format-number x)
-  (if (and (integer? x) (exact? x))
-      (lambda (st)
-        ((case (fmt-radix st)
-           ((16) (cat "0x" (string-upcase (number->string x 16))))
-           ((8) (cat "0" (number->string x 8)))
-           (else (dsp (number->string x))))
-         st))
-      (dsp (number->string x))))
-
-(define (c-format-string x)
-  (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))
-
-(define (c-string-escaped x)
-  (let loop ((parts '()) (idx (string-length x)))
-    (cond ((string-index-right x c-needs-string-escape? 0 idx)
-           => (lambda (special-idx)
-                (loop (cons (c-escape-char (string-ref x special-idx) #\")
-                            (cons (substring/shared x (+ special-idx 1) idx)
-                                  parts))
-                      special-idx)))
-          (else
-           (cons (substring/shared x 0 idx) parts)))))
-
-(define (c-needs-string-escape? c)
-  (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))
-
-(define (c-simple-literal x)
-  (c-wrap-stmt
-   (cond ((char? x) (dsp (char->c-char x)))
-         ((boolean? x) (dsp (if x "1" "0")))
-         ((number? x) (c-format-number x))
-         ((string? x) (c-format-string x))
-         ((null? x) (dsp "NULL"))
-         ((eof-object? x) (dsp "EOF"))
-         (else (dsp (write-to-string x))))))
-
-(define (c-literal x)
-  (lambda (st)
-    ((if (and (symbol? x) (memq x (or (fmt-macro-params st) '())))
-         (c-paren (c-simple-literal x))
-         (c-simple-literal x))
-     st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; default expression generator
-
-(define (c-expr/sexp x)
-  (if (procedure? x)
-      x
-      (lambda (st)
-        (cond
-         ((pair? x)
-          (case (car x)
-            ((if) ((apply c-if (cdr x)) st))
-            ((for) ((apply c-for (cdr x)) st))
-            ((while) ((apply c-while (cdr x)) st))
-            ((switch) ((apply c-switch (cdr x)) st))
-            ((case) ((apply c-case (cdr x)) st))
-            ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
-            ((default) ((apply c-default (cdr x)) st))
-            ((break) (c-break st))
-            ((continue) (c-continue st))
-            ((return) ((apply c-return (cdr x)) st))
-            ((goto) ((apply c-goto (cdr x)) st))
-            ((typedef) ((apply c-typedef (cdr x)) st))
-            ((struct union class) ((apply c-struct/aux x) st))
-            ((enum) ((apply c-enum (cdr x)) st))
-            ((inline auto restrict register volatile extern static)
-             ((cat (car x) " " (apply c-begin (cdr x))) st))
-            ;; non C-keywords must have some character invalid in a C
-            ;; identifier to avoid conflicts - by default we prefix %
-            ((vector-ref)
-             ((c-wrap-stmt
-               (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
-              st))
-            ((vector-set!)
-             ((c= (c-in-expr
-                   (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
-                  (c-expr (cadddr x)))
-              st))
-            ((extern/C) ((apply c-extern/C (cdr x)) st))
-            ((%apply) ((apply c-apply (cdr x)) st))
-            ((%define) ((apply cpp-define (cdr x)) st))
-            ((%include) ((apply cpp-include (cdr x)) st))
-            ((%fun) ((apply c-fun (cdr x)) st))
-            ((%cond)
-             (let lp ((ls (cdr x)) (res '()))
-               (if (null? ls)
-                   ((apply c-if (reverse res)) st)
-                   (lp (cdr ls)
-                       (cons (if (pair? (cddar ls))
-                                 (apply c-begin (cdar ls))
-                                 (cadar ls))
-                             (cons (caar ls) res))))))
-            ((%prototype) ((apply c-prototype (cdr x)) st))
-            ((%var) ((apply c-var (cdr x)) st))
-            ((%begin) ((apply c-begin (cdr x)) st))
-            ((%attribute) ((apply c-attribute (cdr x)) st))
-            ((%line) ((apply cpp-line (cdr x)) st))
-            ((%pragma %error %warning)
-             ((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
-                     (cdr x)) st))
-            ((%if %ifdef %ifndef %elif)
-             ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
-                     (cdr x)) st))
-            ((%endif) ((apply cpp-endif (cdr x)) st))
-            ((%block-begin) ((apply c-braced-block #f (cdr x)) st))
-            ((%block) ((apply c-braced-block (cdr x)) st))
-            ((%comment) ((apply c-comment (cdr x)) st))
-            ((:) ((apply c-label (cdr x)) st))
-            ((%cast) ((apply c-cast (cdr x)) st))
-            ((+ - & * / % ! ~ ^ && < > <= >= == != << >>
-                = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
-             ((apply c-op x) st))
-            ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
-            ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
-            ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
-            ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
-            ((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
-            ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
-            ((%and) ((apply c-op "&&" (cdr x)) st))
-            ((%or) ((apply c-op "||" (cdr x)) st))
-            ((%. %field) ((apply c-op "." (cdr x)) st))
-            ((%->) ((apply c-op "->" (cdr x)) st))
-            (else
-             (cond
-              ((eq? (car x) (string->symbol "."))
-               ((apply c-op "." (cdr x)) st))
-              ((eq? (car x) (string->symbol "->"))
-               ((apply c-op "->" (cdr x)) st))
-              ((eq? (car x) (string->symbol "++"))
-               ((apply c-op "++" (cdr x)) st))
-              ((eq? (car x) (string->symbol "--"))
-               ((apply c-op "--" (cdr x)) st))
-              ((eq? (car x) (string->symbol "+="))
-               ((apply c-op "+=" (cdr x)) st))
-              ((eq? (car x) (string->symbol "-="))
-               ((apply c-op "-=" (cdr x)) st))
-              (else ((c-apply x) st))))))
-         ((vector? x)
-          ((c-wrap-stmt
-            (fmt-try-fit
-             (fmt-let 'no-wrap? #t
-                      (cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
-             (lambda (st)
-               (let* ((col (fmt-col st))
-                      (sep (string-append "," (make-nl-space col))))
-                 ((cat "{" (fmt-join c-expr (vector->list x) sep)
-                       "}" nl)
-                  st)))))
-           st))
-         (else
-          ((c-literal x) st))))))
-
-(define (c-apply ls)
-  (c-wrap-stmt
-   (c-with-op
-    'paren
-    (cat (c-expr (car ls))
-         (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
-           (fmt-if
-            fmt-no-wrap?
-            (c-paren flat)
-            (c-paren
-             (fmt-try-fit
-              flat
-              (lambda (st)
-                (let* ((col (fmt-col st))
-                       (sep (string-append "," (make-nl-space col))))
-                  ((fmt-join c-expr (cdr ls) sep) st)))))))))))
-
-(define (c-expr x)
-  (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; comments, with Emacs-friendly escaping of nested comments
-
-(define (make-comment-writer st)
-  (let ((output (fmt-ref st 'writer)))
-    (lambda (str st)
-      (let ((lim (- (string-length str) 1)))
-        (let lp ((i 0) (st st))
-          (let ((j (string-index str #\/ i)))
-            (if j
-                (let ((st (if (and (> j 0)
-                                   (eqv? #\* (string-ref str (- j 1))))
-                              (output
-                               "\\/"
-                               (output (substring/shared str i j) st))
-                              (output (substring/shared str i (+ j 1)) st))))
-                  (lp (+ j 1)
-                      (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
-                          (output "\\" st)
-                          st)))
-                (output (substring/shared str i) st))))))))
-
-(define (c-comment . args)
-  (lambda (st)
-    ((cat "/*" (fmt-let 'writer (make-comment-writer st)
-                        (apply-cat args))
-          "*/")
-     st)))
-
-(define (make-block-comment-writer st)
-  (let ((output (make-comment-writer st))
-        (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
-    (lambda (str st)
-      (let ((lim (string-length str)))
-        (let lp ((i 0) (st st))
-          (let ((j (string-index str #\newline i)))
-            (if j
-                (lp (+ j 1)
-                    (output indent (output (substring/shared str i j) st)))
-                (output (substring/shared str i) st))))))))
-
-(define (c-block-comment . args)
-  (lambda (st)
-    (let ((col (fmt-col st))
-          (row (fmt-row st))
-          (indent (c-current-indent-string st)))
-      ((cat "/* "
-            (fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
-            (lambda (st)
-              (cond
-                ((= row (fmt-row st)) ((dsp " */") st))
-                ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
-                (else ((cat fl indent " */") st)))))
-       st))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; preprocessor
-
-(define (make-cpp-writer st)
-  (let ((output (fmt-ref st 'writer)))
-    (lambda (str st)
-      (let lp ((i 0) (st st))
-        (let ((j (string-index str #\newline i)))
-          (if j
-              (lp (+ j 1)
-                  (output
-                   nl-str
-                   (output " \\" (output (substring/shared str i j) st))))
-              (output (substring/shared str i) st)))))))
-
-(define (cpp-include file)
-  (if (string? file)
-      (cat fl "#include " (wrt file) fl)
-      (cat fl "#include <" file ">" fl)))
-
-(define (list-dot x)
-  (cond ((pair? x) (list-dot (cdr x)))
-        ((null? x) #f)
-        (else x)))
-
-(define (flatten-list ls)
-  (let lp ((ls ls) (res '()))
-    (cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
-          ((null? ls) (reverse res))
-          (else (reverse (cons ls res))))))
-
-(define (replace-tree from to x)
-  (let replace ((x x))
-    (cond ((eq? x from) to)
-          ((pair? x) (cons (replace (car x)) (replace (cdr x))))
-          (else x))))
-
-(define (cpp-define x . body)
-  (define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
-  (lambda (st)
-    (let* ((body (cond
-                   ((and (pair? x) (list-dot x))
-                    => (lambda (dot)
-                         (if (eq? dot '...)
-                             body
-                             (replace-tree dot '__VA_ARGS__ body))))
-                   (else body)))
-           (params (map (lambda (x) (if (pair? x) (cadr x) x))
-                        (flatten-list (if (pair? x) (cdr x) '()))))
-           (tail
-            (if (pair? body)
-                (cat " "
-                     (fmt-let 'writer (make-cpp-writer st)
-                              (fmt-let 'macro-params params
-                                       ((if (or (not (pair? x))
-                                                (and (null? (cdr body))
-                                                     (c-literal? (car body))))
-                                            (lambda (x) x)
-                                            c-paren)
-                                        (c-in-expr (apply c-begin body))))))
-                (lambda (x) x))))
-      ((c-in-expr
-        (if (pair? x)
-            (cat fl "#define " (name-of (car x))
-                 (c-paren
-                  (fmt-join/dot name-of
-                                (lambda (dot) (dsp "..."))
-                                (cdr x)
-                                ", "))
-                 tail fl)
-            (cat fl "#define " (c-expr x) tail fl)))
-       st))))
-
-(define (cpp-expr x)
-  (if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))
-
-(define (cpp-if/aux name check . o)
-  (let* ((pass (and (pair? o) (car o)))
-         (comment (if (member name '("ifdef" "ifndef"))
-                      (cat "  "
-                           (c-comment
-                            " " (if (equal? name "ifndef") "! " "")
-                            check " "))
-                      ""))
-         (endif (if pass (cat fl "#endif" comment) ""))
-         (tail (cond
-                ((and (pair? o) (pair? (cdr o)))
-                 (if (pair? (cddr o))
-                     (apply cpp-elif (cdr o))
-                     (cat (cpp-else) (cadr o) endif)))
-                (else endif))))
-    (lambda (st)
-      (let ((indent (c-current-indent-string st)))
-        ((cat fl "#" name " " (cpp-expr check) fl
-              (if pass (cat indent pass) "") fl
-              tail fl)
-         st)))))
-
-(define (cpp-if check . o)
-  (apply cpp-if/aux "if" check o))
-(define (cpp-ifdef check . o)
-  (apply cpp-if/aux "ifdef" check o))
-(define (cpp-ifndef check . o)
-  (apply cpp-if/aux "ifndef" check o))
-(define (cpp-elif check . o)
-  (apply cpp-if/aux "elif" check o))
-(define (cpp-else . o)
-  (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
-(define (cpp-endif . o)
-  (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))
-
-(define (cpp-wrap-header name . body)
-  (let ((name name)) ; consider auto-mangling
-    (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))
-
-(define (cpp-line num . o)
-  (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))
-
-(define (cpp-generic name . ls)
-  (cat fl "#" name (apply-cat ls) fl))
-
-(define (cpp-undef . args) (apply cpp-generic "undef" args))
-(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
-(define (cpp-error . args) (apply cpp-generic "error" args))
-(define (cpp-warning . args) (apply cpp-generic "warning" args))
-
-(define (cpp-stringify x)
-  (cat "#" x))
-
-(define (cpp-sym-cat . args)
-  (fmt-join dsp args " ## "))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; general indentation and brace rules
-
-(define (c-current-indent-string st . o)
-  (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))
-
-(define (c-indent st . o)
-  (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
-                             (if (pair? o) (car o) 0))))))
-
-(define (c-indent/switch st)
-  (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))
-
-(define (c-open-brace st)
-  (if (fmt-newline-before-brace? st)
-      (begin
-        (fmt-set! st 'newline-before-brace? #t)
-        (cat "{" nl))
-      (begin
-        (fmt-set! st 'newline-before-brace? #t)
-        (cat " {" nl))))
-
-(define (c-close-brace st)
-  (dsp "}"))
-
-(define (c-wrap-stmt x)
-  (fmt-if fmt-expression?
-          (c-expr x)
-          (cat (c-in-expr (c-expr x)) ";" nl)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; code blocks
-
-(define (c-block . args)
-  (apply c-block/aux 0 args))
-
-(define (c-block/aux offset header body0 . body)
-   (let ((inner (apply c-begin body0 body)))
-     (if (or (pair? body)
-             (not (or (c-literal? body0)
-                      (and (pair? body0)
-                           (not (c-control-operator? (car body0)))))))
-         (c-braced-block/aux offset header inner)
-         (lambda (st)
-           (if (fmt-braceless-bodies? st)
-               ((cat header fl (c-indent st offset) inner fl) st)
-               ((c-braced-block/aux offset header inner) st))))))
-
-(define (c-braced-block . args)
-  (apply c-braced-block/aux 0 args))
-
-(define (c-braced-block/aux offset header . body)
-   (lambda (st)
-     ((cat (if header header "") (c-open-brace st) (c-indent st offset)
-           (apply c-begin body) fl
-           (c-current-indent-string st offset) (c-close-brace st))
-      st)))
-
-(define (c-begin . args)
-  (apply c-begin/aux #f args))
-
-(define (c-begin/aux ret? body0 . body)
-   (if (null? body)
-       (c-expr body0)
-       (lambda (st)
-         (if (fmt-expression? st)
-             ((fmt-try-fit
-               (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
-               (lambda (st)
-                 (let ((indent (c-current-indent-string st)))
-                   ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
-              st)
-             (let ((orig-ret? (fmt-return? st)))
-               ((fmt-join/last c-expr
-                               (lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
-                               (cons body0 body)
-                               (cat fl (c-current-indent-string st)))
-                (fmt-set! st 'return? (and ret? orig-ret?))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; data structures
-
-(define (c-struct/aux type x . o)
-  (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-         (body (if name (if (not (null? o)) (car o) '()) x))
-         (o (if (null? o) o (cdr o))))
-    (if (not (null? body))
-        (c-wrap-stmt
-         (cat
-          (c-braced-block
-           (cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
-           (cat
-            (c-in-stmt
-             (if (list? body)
-                 (apply c-begin (map c-wrap-stmt (map c-field body)))
-                 (c-wrap-stmt (c-expr body))))))
-          (if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))
-        (c-wrap-stmt
-         (cat type (if (and name (not (equal? name ""))) (cat " " name) ""))))))
-
-(define (c-struct . args) (apply c-struct/aux "struct" args))
-(define (c-union . args) (apply c-struct/aux "union" args))
-(define (c-class . args) (apply c-struct/aux "class" args))
-
-(define (c-enum x . o)
-  (define (c-enum-one x)
-    (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
-  (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-         (vals (if name (car o) x)))
-    (c-wrap-stmt
-     (cat
-      (c-braced-block
-       (if name (cat "enum " name) (dsp "enum"))
-       (c-in-expr (apply c-begin (map c-enum-one vals))))))))
-
-(define (c-attribute . args)
-  (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; basic control structures
-
-(define (c-while check . body)
-  (c-reset-newline
-   (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
-                 (c-in-stmt (apply c-begin body)))
-        fl)))
-
-(define (c-for init check update . body)
-  (c-reset-newline
-   (cat
-    (c-block
-     (c-in-expr
-      (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
-           (c-expr update ) ")"))
-     (c-in-stmt (apply c-begin body)))
-    fl)))
-
-(define (c-param x)
-  (cond
-    ((procedure? x) x)
-    ((pair? x) (c-type (car x) (cadr x)))
-    (else (error "missing type" x))))
-
-(define (c-field x)
-  (cond
-    ((procedure? x) x)
-    ((pair? x)
-     (if (list? (car x))
-         (case (caar x)
-           ((union struct class)
-            (if (> (length x) 1)
-                (c-type (car x)
-                        (cadr x))
-                (c-type (car x))))
-           (else (c-type (car x) (cadr x))))
-         (c-type (car x)
-                 (fmt-join c-expr (cdr x) ", "))))
-    (else (error "missing type" x))))
-
-(define (c-param-list ls)
-  (if (null? ls)
-      (c-type 'void)
-      (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))))
-
-(define (c-fun type name params . body)
-  (cat (c-block (c-in-expr (c-prototype type name params))
-                (c-in-stmt (apply c-begin body)))
-       fl))
-
-(define (c-prototype type name params . o)
-  (c-wrap-stmt
-   (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
-        (fmt-join/prefix c-expr o " "))))
-
-(define (c-static x) (cat "static " (c-expr x)))
-(define (c-const x) (cat "const " (c-expr x)))
-(define (c-restrict x) (cat "restrict " (c-expr x)))
-(define (c-volatile x) (cat "volatile " (c-expr x)))
-(define (c-auto x) (cat "auto " (c-expr x)))
-(define (c-inline x) (cat "inline " (c-expr x)))
-(define (c-extern x) (cat "extern " (c-expr x)))
-(define (c-extern/C . body)
-  (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
-
-(define (c-type type . o)
-  (let ((name (and (pair? o) (car o))))
-    (cond
-     ((pair? type)
-      (case (car type)
-        ((%fun)
-         (cat (c-type (cadr type) #f)
-              " (*" (or name "") ")("
-              (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
-        ((%array)
-         (let ((name (cat name "[" (if (pair? (cddr type))
-                                       (c-expr (caddr type))
-                                       "")
-                          "]")))
-           (c-type (cadr type) name)))
-        ((%pointer *)
-         (let ((name (cat "*" (if name (c-expr name) ""))))
-           (c-type (cadr type)
-                   (if (and (pair? (cadr type)) (eq? '%array (caadr type)))
-                       (c-paren name)
-                       name))))
-        ((enum) (apply c-enum name (cdr type)))
-        ((struct union class)
-         (cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
-        (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
-     ((not type)
-      (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
-     (else
-      (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
-
-(define (c-var type name . init)
-  (c-wrap-stmt
-   (if (pair? init)
-       (cat (c-type type name) " = " (c-expr (car init)))
-       (c-type type (if (pair? name)
-                        (fmt-join c-expr name ", ")
-                        (c-expr name))))))
-
-(define (c-cast type expr)
-  (cat "(" (c-type type) ")" (c-expr expr)))
-
-(define (c-typedef type alias . o)
-  (c-wrap-stmt
-   (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Generalized IF: allows multiple tail forms for if/else if/.../else
-;; blocks.  A final ELSE can be signified with a test of #t or 'else,
-;; or by simply using an odd number of expressions (by which the
-;; normal 2 or 3 clause IF forms are special cases).
-
-(define (c-if/stmt c p . rest)
-  (lambda (st)
-    (let ((indent (c-current-indent-string st)))
-      ((let lp ((c c) (p p) (ls rest))
-         (if (or (eq? c 'else) (eq? c #t))
-             (if (not (null? ls))
-                 (error "forms after else clause in IF" c p ls)
-                 (cat (c-block/aux -1 " else" p) fl))
-             (let ((tail (if (pair? ls)
-                             (if (pair? (cdr ls))
-                                 (lp (car ls) (cadr ls) (cddr ls))
-                                 (lp 'else (car ls) '()))
-                             fl)))
-               (cat (c-block/aux
-                     (if (eq? ls rest) 0 -1)
-                     (cat (if (eq? ls rest) (lambda (x) x) " else ")
-                          "if (" (c-in-test (c-expr c)) ")") p)
-                    tail))))
-       st))))
-
-(define (c-if/expr c p . rest)
-  (let lp ((c c) (p p) (ls rest))
-    (cond
-      ((or (eq? c 'else) (eq? c #t))
-       (if (not (null? ls))
-           (error "forms after else clause in IF" c p ls)
-           (c-expr p)))
-      ((pair? ls)
-       (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : "
-            (if (pair? (cdr ls))
-                (lp (car ls) (cadr ls) (cddr ls))
-                (lp 'else (car ls) '()))))
-      (else
-       (c-or (c-in-test (c-expr c)) (c-expr p))))))
-
-(define (c-if . args)
-  (fmt-if fmt-expression?
-          (apply c-if/expr args)
-          (apply c-if/stmt args)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; switch statements, automatic break handling
-
-(define (c-label name)
-  (lambda (st)
-    (let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
-      ((cat fl indent name ":" fl) st))))
-
-(define c-break
-  (c-wrap-stmt (dsp "break")))
-(define c-continue
-  (c-wrap-stmt (dsp "continue")))
-(define (c-return . result)
-  (if (pair? result)
-      (c-wrap-stmt (cat "return " (c-expr (car result))))
-      (c-wrap-stmt (dsp "return"))))
-(define (c-goto label)
-  (c-wrap-stmt (cat "goto " (c-expr label))))
-
-(define (c-switch val . clauses)
-  (c-reset-newline
-   (lambda (st)
-     ((cat "switch (" (c-in-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)
-      st))))
-
-(define (c-switch-clause/breaks x)
-  (lambda (st)
-    (let* ((break?
-            (and (car x)
-                 (not (member (cadr x) '(case/fallthrough
-                                         default/fallthrough
-                                         else/fallthrough)))))
-           (explicit-case? (member (cadr x) '(case case/fallthrough)))
-           (indent (c-current-indent-string st))
-           (indent-body (c-indent st))
-           (sep (string-append ":" nl-str indent)))
-      ((cat (c-in-expr
-             (fmt-join/suffix
-              dsp
-              (cond
-               ((pair? (cadr x))
-                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
-                     (cadr x)))
-               (explicit-case?
-                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
-                     (if (list? (caddr x))
-                         (caddr x)
-                         (list (caddr x)))))
-               ((member (cadr x)
-                        '(default else default/fallthrough else/fallthrough))
-                (list (dsp "default")))
-               (else
-                (error
-                 "unknown switch clause, expected a list or default but got"
-                 (cadr x))))
-              sep))
-            (make-space (or (fmt-indent-space st) 4))
-            (fmt-join c-expr
-                      (if explicit-case? (cdddr x) (cddr x))
-                      indent-body)
-            (if (and break? (not (fmt-return? st)))
-                (cat fl indent-body c-break)
-                ""))
-       st))))
-
-(define (c-switch-clause x)
-  (if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
-(define (c-switch-clause/no-break x)
-  (if (procedure? x) x (c-switch-clause/breaks (cons #f x))))
-
-(define (c-case x . body)
-  (c-switch-clause (cons (if (pair? x) x (list x)) body)))
-(define (c-case/fallthrough x . body)
-  (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
-(define (c-default . body)
-  (c-switch-clause/breaks (cons #t (cons 'else body))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; operators
-
-(define (c-op op first . rest)
-  (if (null? rest)
-      (c-unary-op op first)
-      (apply c-binary-op op first rest)))
-
-(define (c-binary-op op . ls)
-  (define (lit-op? x) (or (c-literal? x) (symbol? x)))
-  (let ((str (display-to-string op)))
-    (c-wrap-stmt
-     (c-maybe-paren
-      op
-      (if (or (equal? str ".") (equal? str "->"))
-          (fmt-join c-expr ls str)
-          (let ((flat
-                 (fmt-let 'no-wrap? #t
-                          (lambda (st)
-                            ((fmt-join c-expr
-                                       ls
-                                       (if (and (fmt-non-spaced-ops? st)
-                                                (every lit-op? ls))
-                                           str
-                                           (string-append " " str " ")))
-                             st)))))
-            (fmt-if
-             fmt-no-wrap?
-             flat
-             (fmt-try-fit
-              flat
-              (lambda (st)
-                   ((fmt-join c-expr
-                              ls
-                              (cat nl (make-space (+ 2 (fmt-col st))) str " "))
-                    st))))))))))
-
-(define (c-unary-op op x)
-  (c-wrap-stmt
-   (cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
-
-;; some convenience definitions
-
-(define (c++ . args) (apply c-op "++" args))
-(define (c-- . args) (apply c-op "--" args))
-(define (c+ . args) (apply c-op '+ args))
-(define (c- . args) (apply c-op '- args))
-(define (c* . args) (apply c-op '* args))
-(define (c/ . args) (apply c-op '/ args))
-(define (c% . args) (apply c-op '% args))
-(define (c& . args) (apply c-op '& args))
-;; (define (|c\|| . args) (apply c-op '|\|| args))
-(define (c^ . args) (apply c-op '^ args))
-(define (c~ . args) (apply c-op '~ args))
-(define (c! . args) (apply c-op '! args))
-(define (c&& . args) (apply c-op '&& args))
-;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
-(define (c<< . args) (apply c-op '<< args))
-(define (c>> . args) (apply c-op '>> args))
-(define (c== . args) (apply c-op '== args))
-(define (c!= . args) (apply c-op '!= args))
-(define (c< . args) (apply c-op '< args))
-(define (c> . args) (apply c-op '> args))
-(define (c<= . args) (apply c-op '<= args))
-(define (c>= . args) (apply c-op '>= args))
-(define (c= . args) (apply c-op '= args))
-(define (c+= . args) (apply c-op "+=" args))
-(define (c-= . args) (apply c-op "-=" args))
-(define (c*= . args) (apply c-op '*= args))
-(define (c/= . args) (apply c-op '/= args))
-(define (c%= . args) (apply c-op '%= args))
-(define (c&= . args) (apply c-op '&= args))
-;; (define (|c\|=| . args) (apply c-op '|\|=| args))
-(define (c^= . args) (apply c-op '^= args))
-(define (c<<= . args) (apply c-op '<<= args))
-(define (c>>= . args) (apply c-op '>>= args))
-
-(define (c. . args) (apply c-op "." args))
-(define (c-> . args) (apply c-op "->" args))
-
-(define (c-bit-or . args) (apply c-op "|" args))
-(define (c-or . args) (apply c-op "||" args))
-(define (c-bit-or= . args) (apply c-op "|=" args))
-
-(define (c++/post x)
-  (cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
-(define (c--/post x)
-  (cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))

hello-world.sex

@@ -0,0 +1,18 @@
+(include stdio.h)
+
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(struct foo
+  ((int a)
+   (float b)))
+
+(pub fn int main ((int argc) (char **argv))
+    (var int a 10)
+    (puts "Hello from Sex!")
+    (var (array char 512) name)
+    (puts "What is your name?")
+    (scanf "%s" &name)
+    (printf "Hello, %s!\n" name)
+    (printf ,(foo))
+    0)

semen.scm

@@ -1,214 +0,0 @@
-;;; Sex semantic engine
-
-(declare (unit semen)
-         (uses sex-macros
-               sex-modules))
-
-(import
-  (chicken string)
-  fmt
-  matchable                             ; pattern matching
-  srfi-1                                ; list routines
-  srfi-69                               ; hash tables
-  )
-
-;;; for lambda extraction, docstring processing, macro expansion,
-;;; injection of module headers, i.e. all things that rearrange code
-;;; structurally, add or remove forms
-;;;
-;;; The algorithm: feed toplevel forms to appropriate handlers, then
-;;; append their return to the resulting list. Each handler can return
-;;; multiple forms, e.g. lambdas collected from a function may result
-;;; in auxiliary structures and functions.
-(define (semen-process raw-sex-forms)
-  (semen-process-rec raw-sex-forms (list)))
-
-(define (semen-process-rec forms acc)
-  (cond
-   ((null? forms) (reverse acc))
-   ((sex-macro? (car forms))
-    (semen-process-rec
-     (semen-apply-macro (car forms) (cdr forms))
-     acc))
-   (else
-    (semen-process-rec (cdr forms)
-                       (match-sex-form (car forms) acc)))))
-
-(define (semen-apply-macro macro-form rest-forms)
-;; We want to replace macro with its expansion. The problem is,
-;; top-level macro can return either a single form, or a list of
-;; forms, when it for example generates some aux
-;; structures/functions/typedefs.
-;;
-;; Single form we just cons to the top of rest-forms, but multiple
-;; forms have to be appended to the rest-forms.
-  (let ((res (apply-macro macro-form)))
-    (if (list? (car res))
-        (append res rest-forms)
-        (cons res rest-forms))))
-
-(define (match-sex-form sex-form acc)
-  (match sex-form
-    ((or ('fn . _)
-         ('pub 'fn . _)
-         ('extern 'fn . _)) (process-fn sex-form acc))
-    ((or ('struct . _)
-         ('pub struct . _)) (process-struct sex-form acc))
-    ((or ('union . _)
-         ('pub 'union . _)) (process-struct sex-form acc))
-    ((or ('var . _)
-         ('pub 'var . _)
-         ('extern 'var . _)) (process-global-var sex-form acc))
-    (('include _) (cons sex-form acc))
-
-    (('import . modules)
-     (semen-process-imports (get-public-forms modules) acc))
-
-    ((or ('defmacro . rest)
-         ('pub 'defmacro . rest)) (defmacro rest) acc)
-
-    (else (assert #f (fmt #f "Unknown top level form " sex-form)))))
-
-(define (semen-process-imports module-public-forms acc)
-  ;; Recursively process imports: register public macros, cons all
-  ;; other public things to our acc
-  (if (null? module-public-forms) acc
-      (match (car module-public-forms)
-        (('defmacro . rest)
-         (defmacro rest)
-         (semen-process-imports (cdr module-public-forms) acc))
-        (else
-         (semen-process-imports (cdr module-public-forms)
-                                (cons (car module-public-forms)
-                                      acc))))))
-
-(define (semen-macro-expand form)
-  "Walk the form recursively and expand all macros, unitl none is left."
-  (semen-walk-form
-   form
-   (lambda (subform env)
-     (if (sex-macro? subform)
-         (apply-macro subform)
-         subform))
-   #f))
-
-;;; TODO: for greater inspiration, see SBCL's walk.lisp and their
-;;; template system. Maybe it is worth it to implement something
-;;; similar here
-(define (semen-walk-form form walk-fn env)
-  (if (atom? form) form
-      (let ((new-form (walk-fn form env)))
-        (cond ((not (eq? form new-form))
-               (semen-walk-form new-form walk-fn env))
-              (else (recons
-                     new-form
-                     (semen-walk-form (car new-form) walk-fn env)
-                     (semen-walk-form (cdr new-form) walk-fn env)))))))
-
-(define (recons old-cons new-car new-cdr)
-  (if (and (eq? new-car (car old-cons))
-           (eq? new-cdr (cdr old-cons)))
-      old-cons
-      (cons new-car new-cdr)))
-
-;;; Fn processing
-
-(define (process-fn sex-fn acc)
-  (let* ((expanded (semen-macro-expand sex-fn))
-         (env (make-hash-table))
-         (processed
-          (semen-walk-form
-           expanded
-           semen-fn-walker
-           (begin
-             (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
-             (set! (hash-table-ref env :lambda-counter) 0)
-             (set! (hash-table-ref env :lambda-aux-code) (list))
-             env))))
-
-    (cons processed
-          (append (hash-table-ref env :lambda-aux-code) acc))))
-
-(define (semen-fn-walker form env)
-  (if (eq? 'lambda (car form))
-      (let ((lambda-name (semen-make-lambda-name (hash-table-ref env :fn-name)
-                                                 (hash-table-ref env :lambda-counter))))
-        (set! (hash-table-ref env :lambda-aux-code)
-          (append (semen-make-aux-lambda-struct lambda-name form)
-                  (hash-table-ref env :lambda-aux-code)))
-        (set! (hash-table-ref env :lambda-counter)
-          (+ (hash-table-ref env :lambda-counter) 1))
-        lambda-name)
-    form))
-
-(define (semen-make-lambda-name enclosing-fn-name counter)
-  (string->symbol
-   (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
-
-(define (semen-make-aux-lambda-struct name form)
-  (match form
-    (('lambda ret-type arglist captures . body)
-     ;; Captures are ignored for now, but
-     ;; we'll need them for TODO: closures support
-     (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
-    (else (assert #f (fmt #f "Malformed lambda " form)))))
-
-;;; Struct
-
-(define (process-struct sex-struct acc)
-  (cons sex-struct acc))
-
-(define (process-global-var sex-var acc)
-  (cons sex-var acc))
-
-;;; Utils
-(define (non-empty-list? form)
-  (and (list? form)
-       (not (null? form))))
-
-(define (sex-fn? form)
-  "The `form` must be toplevel.
-Returns #f if the form is not a function, returns the form otherwise"
-  (match form
-    ((fn . _) form)
-    ((pub fn . _) form)
-    (else #f)))
-
-(define (sex-fn-public? fn-form)
-  (eq? (car fn-form) 'pub))
-
-(define (sex-fn-return-type fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (third fn-form)
-      (second fn-form)))
-
-(define (sex-fn-name fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fourth fn-form)
-      (third fn-form)))
-
-(define (sex-fn-arglist fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fifth fn-form)
-      (fourth fn-form)))
-
-(define (sex-fn-prototype fn-form)
-  "Returns all except body"
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (take fn-form 5)
-      (take fn-form 4)))
-
-(define (sex-fn-body fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (drop fn-form 5)
-      (drop fn-form 4)))

sex-macros.scm

@@ -1,36 +0,0 @@
-(declare (unit sex-macros))
-
-(import
-  (chicken plist)
-  (chicken string))
-
-(define (cat-syms s-1 s-2)
-  (import fmt)
-  (fmt #f s-1 s-2))
-
-(define (cat sym-1 sym-2)
-  (string->symbol (cat-syms sym-1 sym-2)))
-
-(define (register-macro name arglist body)
-  (put! name 'sex-macro
-        `(lambda ,arglist
-           ,@body)))
-
-(define (get-macro name)
-  (eval (get name 'sex-macro)))
-
-(define (sex-macro? form)
-  (and (list? form)
-       (symbol? (car form))
-       (get (car form) 'sex-macro)))
-
-(define (apply-macro form)
-  (assert (sex-macro? form)
-          (fmt #f (car form) " is not a macro"))
-  (apply (get-macro (car form))
-         (cdr form)))
-
-(define (defmacro form)
-  (let ((arglist (car form))
-        (body (cdr form)))
-    (register-macro (car arglist) (cdr arglist) body)))

sex-mode.el

@@ -33,13 +33,12 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
                                  "chicken-import"
                                  "chicken-load"
                                  "define"
-                                 "defmacro"
                                  "extern"
-                                 "import"
                                  "include"
                                  "fn"
                                  "pub"
                                  "struct"
+                                 "template"
                                  "var"
                                  "union")
                                'word)
@@ -77,12 +76,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
   (setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
 
 (put 'fn 'lisp-indent-function 'defun)
-(put 'pub 'lisp-indent-function 'defun)
+(put 'template 'lisp-indent-function 'defun)
-(put 'defmacro 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
-(put 'union 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
-(put 'import 'lisp-indent-function 1)
 
 ;;;###autoload
 (define-derived-mode sex-mode lisp-data-mode "Sex"

sex-modules.scm

@@ -1,88 +0,0 @@
-; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
-; things start to break.
-(declare (unit sex-modules)
-         (uses sex-reader
-               utils))
-
-(import brev-separate
-        (chicken file)
-        (chicken load)
-        (chicken pathname)
-        (chicken process-context)
-        (chicken string)
-        fmt
-        srfi-1)
-
-(define +persistent-module-paths+ (list))
-
-(define (get-public-forms module-list)
-  ;; Module list is a list of symbols
-  ;; How Sex handles modules:
-  ;; For each module in a list, construct path, find module by path in
-  ;; module path directories, extract public definitions from the
-  ;; module, paste them in current one in emulation of C include
-  ;; directives.
-  (fold-right append (list)
-              (map (fn (import-module (symbol->string x)))
-                   module-list)))
-
-(define (import-module name)
-  (let ((module-path (locate-module name)))
-    (assert module-path (fmt #f "Failed to find module " name " in "
-                             (get-module-paths)))
-    (read-public-interface module-path)))
-
-(define (get-module-paths)
-  (cons (current-directory)
-        +persistent-module-paths+))
-
-(define (locate-module name)
-  ;; Module locations: relative to file being compiled, or in what was
-  ;; in SEX_MODULE_PATH env var at the start of the process (see
-  ;; load-persistent-module-paths function)
-
-  (let ((search-paths (get-module-paths)))
-    (let loop ((paths search-paths))
-      (if (null? paths)
-          #f
-          (or (module-exists? name (car paths))
-              (loop (cdr paths)))))))
-
-(define (module-exists? name module-dir)
-  ;; returns absolute path to module, if it exists
-  (and (directory-exists? module-dir)
-       (let ((module-path (make-absolute-pathname module-dir name "sex")))
-         (and (file-exists? module-path)
-              (file-readable? module-path)
-              module-path))))
-
-(define (read-public-interface module-path)
-  ;; pub fns are reduced to prototypes, other pub forms are just pasted
-  (let ((raw-forms (read-from-file module-path)))
-    (fold
-     process-public-interface-form
-     (list)
-     raw-forms)))
-
-;;; TODO: use semen facilities to analyze modules
-(define (process-public-interface-form form acc)
-  (case (car form)
-    ((pub)
-     (case (cadr form)
-       ((fn) ; replace with prototype
-        ;; fn type name (arg-list) (body)
-        ;; 1    2   3       4 - we need first 4
-        (cons (take (cdr form) 4) acc))
-       ((define defmacro import include struct typedef union var)
-        (cons (cdr form) acc))
-       (else (error "Pub what? " (cadr form)))))
-    (else acc)))
-
-(define (load-persistent-module-paths)
-  (let ((sex-module-path-env-var
-         (get-env-var "SEX_MODULE_PATH")))
-    (when sex-module-path-env-var
-      (set! +persistent-module-paths+
-        (map (lambda (p)
-               (make-absolute-pathname p #f #f))
-             (string-split sex-module-path-env-var ":"))))))

sex-reader.scm

@@ -1,22 +0,0 @@
-(declare (unit sex-reader))
-
-(include "utils.macros.scm")
-
-(import (chicken pathname)
-        brev-separate
-        fmt)
-
-(define (read-forms acc)
-  (let ((r (read)))
-    (if (eof-object? r) (reverse acc)
-        (read-forms (cons r acc)))))
-
-(define (read-from-file file)
-  (with-directory file
-    (with-input-from-file (pathname-strip-directory file)
-      (fn (read-forms (list))))))
-
-(define (read-raw-forms input-source)
-  (if (eq? input-source 'stdin)
-      (read-forms (list))
-      (read-from-file input-source)))

sexc.scm

@@ -1,61 +1,221 @@
 (declare (unit sexc)
-         (uses fmt-c-writer
+         (uses templates))
-               sex-reader
-               semen))
-
-(include "utils.macros.scm")
 
 (import brev-separate
-        (chicken file)
+        (chicken pathname)
         (chicken plist)
         (chicken pretty-print)
-        (chicken process)
         (chicken process-context)
-        (chicken port)
+        (chicken string)
         fmt
+        fmt-c
         getopt-long
+        regex
         srfi-1                          ; list routines
-        srfi-13
         tree)
 
+(define +debug+ #f)
+
+(define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
+     (string->symbol
+      (string-substitute "-(?!>)" "_"
+                         (symbol->string sym) #t)))))
+
+(define (atom-to-fmt-c atom)
+  (case atom
+    ((fn) '%fun)
+    ((prototype) '%prototype)
+    ((var) '%var)
+    ((begin) '%begin)
+    ((define) '%define)
+    ((pointer) '%pointer)
+    ((array) '%array)
+    ((@) 'vector-ref)
+    ((include) '%include)
+    ((cast) '%cast)
+    (else
+     (if (symbol? atom)
+         (unkebabify atom)
+         atom))))
+
+(define (tree-finder symbol)
+  (lambda (node)
+    (or (and (tree? node)
+             (eq? (car node) symbol))
+        #f)))
+
+(define (make-field-access form)
+  (assert (= 2 (length form)) "Wrong field access format")
+  (unkebabify
+   (string->symbol
+    (fmt #f (cadr form) (car form)))))
+
+(define (walk-generic form acc)
+  (cond
+   ((null? form) (cons '() acc))
+
+   ;; vector, e.g. {}-initializer
+   ((vector? form)
+    (cons
+     (list->vector
+      (car (walk-sex-tree (vector->list form) (list))))
+     acc))
+
+   ;; atom (hopefully)
+   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
+
+   ;; special case - replace unquote with its expansion
+   ((eq? (car form) 'unquote)
+    (fold
+     cons
+     acc
+     (car                               ; bc walk-sex-tree always
+                                        ; wraps its result
+      (walk-sex-tree (eval (cadr form)) (list)))))
+
+   ;; another special case - field access
+   ((and (symbol? (car form))
+         (char=? #\. (string-ref (symbol->string (car form)) 0)))
+    (cons (make-field-access form) acc))
+
+   ;; another special case - template
+   ((template? form)
+    (append (fold
+             walk-generic
+             (list)
+             (eval form))
+            acc))
+
+   ;; toplevel, or a start of a regular list form
+   (else
+    (let ((new-acc (list)))
+      (cons (reverse
+             (fold
+              walk-generic
+              new-acc
+              form))
+            acc)))))
+
+(define (normalize-fn-form form)
+  ;; (fn ret-type name arglist body) -> normal function
+  ;; (fn ret-type name arglist) -> prototype
+  (if (>= (length form) 5)
+      form
+      (cons 'prototype (cdr form))))
+
+(define (walk-function form static acc)
+  (if static
+      (append (walk-generic (list 'static (normalize-fn-form form))
+                            (list))
+              acc)
+      (append (walk-generic (normalize-fn-form (cdr form))
+                            (list))
+              acc)))
+
+(define (walk-struct form acc)
+  (let ((name (unkebabify (cadr form))))
+    (append (walk-generic form (list))
+          (cons `(typedef struct ,name ,name) acc))))
+
+(define (walk-extern form acc)
+  (case (cadr form)
+    ((fn)
+     (append
+      (list (cons 'extern (walk-function form #f (list))))
+      acc))
+    ((var)
+     (append
+      (list (cons 'extern (walk-generic (cdr form) (list))))
+      acc))
+    (else (error "Extern what?"))))
+
+(define (walk-public form acc)
+  (case (cadr form)
+    ((fn)
+     (walk-function form #f acc))
+    ((var)
+     (append (walk-generic (list 'static (cdr form)) (list)) acc))
+    (else (error "Pub what?"))))
+
+(define (template? form)
+  (and (list? form)
+       (symbol? (car form))
+       (get (car form) 'sex-template)))
+
+(define (walk-sex-tree form acc)
+  (if (list? form)
+      (if (template? form)
+          (fold (fn (walk-sex-tree x y))
+                acc
+                (eval form))
+          (case (car form)
+            ((fn) (walk-function form #t acc))
+            ((extern) (walk-extern form acc))
+            ((pub) (walk-public form acc))
+            ((struct union) (walk-struct form acc))
+            ((unquote) (fold (fn (walk-sex-tree x y))
+                             acc
+                             (eval (cadr form))))
+            (else (append (walk-generic form (list)) acc))))
+      ;; only for unquote support
+      (list (list (atom-to-fmt-c form)))))
+
+(define (process-form form acc)
+  (case (car form)
+    ((chicken-define) (eval (cons 'define (cdr form))) acc)
+    ((template) (eval form) acc)
+    ((chicken-load)
+     (load (cadr form)) acc)
+    ((chicken-import)
+     (eval (cons 'import (cdr form))) acc)
+    (else
+     (walk-sex-tree form acc))))
+
+
+(define (process-raw-forms raw-forms acc)
+  (if (null? raw-forms)
+      (reverse acc)
+      (process-raw-forms (cdr raw-forms)
+                         (process-form (car raw-forms) acc))))
+
+(define (read-forms acc)
+  (let ((r (read)))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
+
+(define (emit-c forms)
+  (for-each (lambda (form)
+              (fmt #t (c-expr form))
+              (fmt #t "\n"))
+            forms))
+
 ;;; Main function facilities
 
 (define opts-grammar
-  (let ((padding 26))
+  `((output "Write output to file"
-    `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl
-                        (pad padding) "environment variable, or if it is empty, to cc")
             (required #f)
-                  (value #t))
+            (value #t)
-      (compile-object "Compile object file instead of executable program"
+            (single-char #\o))
-                      (required #f)
-                      (value #f)
-                      (single-char #\c))
-      (emit-c "Emit C code"
-                  (required #f)
-                  (value #f)
-                  (single-char #\C))
-      (public-interface "Get module's public interface"
-                        (required #f)
-                        (value #f))
     (help "Show this help"
           (required #f)
           (value #f)
           (single-char #\h))
-      (macro-expand "Emit macro-expanded semantically processed Sex code"
+    (macro-expand "Emit macro-expanded Sex code instead of C"
                   (required #f)
                   (value #f)
-                    (single-char #\m))
+                  (single-char #\m))))
-      (output ,(fmt #f "Write output to file. Default file name is a.out." nl
-                    (pad padding) "If -E or -m options are provided, defaults to stdout")
-              (required #f)
-              (value #t)
-              (single-char #\o)))))
 
 (define (print-help)
-  (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
+  (fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
-  (fmt #t "Options:\n")
+  (fmt #t "Options: -o, --output <file>        Write output to file. If omitted, write to stdout\n")
-  (fmt #t (usage opts-grammar))
+  (fmt #t "         -h, --help                 Show this help\n")
-  (fmt #t ""))
+  (fmt #t "         -m, --macro-expand         Emit macro-expanded Sex code instead of C\n"))
 
 (define (help-arg? args)
   (assoc 'help args))
@@ -65,88 +225,44 @@
     (if arg (cdr arg)
         default)))
 
-(define (get-rest-args args)
-  (cdr (assoc '@ args)))
-
-(define (get-c-compiler-args args)
-  (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
-
 (define (get-input-file args)
-  (let ((rest-args (get-rest-args args)))
+  (let ((rest-args (assoc '@ args)))
-    (if (null? rest-args)
+    (if (= 1 (length rest-args))
         'stdin
-        (car rest-args))))
+        (cadr rest-args))))
 
-(define (write-to-file-or-stdout output what)
+(define (read-from-file file)
-  (if (eq? output 'default)
+  (with-input-from-file (pathname-strip-directory file)
-      (what)
+    (fn (read-forms (list)))))
-      (with-output-to-file output
-        (fn (what)))))
 
-(define (emit-c-or-sex sex-forms output args)
+(define (set-working-directory file)
-  (write-to-file-or-stdout output
+  (change-directory
-   (lambda ()
+   (normalize-pathname
-    (if (get-arg args 'macro-expand #f)
+    (make-absolute-pathname
-        (map pp sex-forms)
+     (current-directory)
-        (emit-c sex-forms)))))
+     (pathname-directory file)))))
-
-(define (compile-to-file sex-forms output args)
-  (let ((compiler (or (get-arg args 'c-compiler #f)
-                      (get-env-var "SEX_CC")
-                      "cc"))
-        (out-file (if (eq? output 'default)
-                      "a.out"
-                      output)))
-    (call-with-values
-        (lambda ()
-          (process compiler (append (list "-o" out-file "-x" "c")
-                                    (if (get-arg args 'compile-object #f)
-                                        (list "-c")
-                                        (list))
-                                    (list "-")  ; read stdin
-                                    (get-c-compiler-args args))))
-      (lambda (out-port in-port pid)
-        (with-output-to-port in-port
-          (lambda () (emit-c sex-forms)))
-        (close-output-port in-port)
-        (process-wait pid)))))
-
-(define (semantic-process-forms raw-forms input-source)
-  (if (eq? input-source 'stdin)
-      (semen-process raw-forms)
-      (with-directory input-source
-        (semen-process raw-forms))))
 
 (define (main)
   (let* ((raw-args (command-line-arguments))
+         (current-dir (current-directory))
          (args (getopt-long raw-args
                             opts-grammar))
-         (output (get-arg args 'output 'default))
+         (output (get-arg args 'output 'stdout))
          (help (help-arg? args))
-
+         (input (get-input-file args)))
-         (input (get-input-file args))
+    (if help (print-help)
-         (current-dir (current-directory)))
+        (let* ((raw-forms
-    (call/cc
+                (if (eq? input 'stdin)
-     (lambda (return)
+                    (read-forms (list))
-       (when help
+                    (begin
-         (print-help)
+                      (set-working-directory input)
-         (return #f))
+                      (read-from-file input))))
-       (when (get-arg args 'public-interface #f)
+               (sex-forms (process-raw-forms raw-forms (list))))
-         (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
+          (change-directory current-dir)
-
+          (if (get-arg args 'macro-expand #f)
-         (write-to-file-or-stdout
+              (map pp sex-forms)
-          output
+              (if (not (eq? output 'stdout))
-          (fn
+                  (with-output-to-file output
-           (map pp (reverse
+                    (lambda ()
-                    (read-public-interface input)))))
+                      (emit-c sex-forms)))
-         (return #f))
+                  (emit-c sex-forms)))))))
-       (load-persistent-module-paths)
-
-       (let* ((raw-forms (read-raw-forms input))
-              (sex-forms (semantic-process-forms raw-forms input)))
-         (if (or (get-arg args 'macro-expand #f)
-                 (get-arg args 'emit-c #f))
-             ;; Emit processed and macro-expanded sex code, or emit C code
-             (emit-c-or-sex sex-forms output args)
-             ;; Compile file!
-             (compile-to-file sex-forms output args)))))))

templates.scm

@@ -0,0 +1,66 @@
+(declare (unit templates))
+
+(import
+  (chicken plist)
+  brev-separate
+  fmt
+  regex
+  srfi-1                                ; list routines
+  tree)
+
+(define (register-template name)
+  (put! name 'sex-template #t))
+
+(define-syntax template
+  (syntax-rules ()
+    ((template (name . args) . body)
+     (begin
+       (register-template 'name)
+       (define-syntax name
+         (syntax-rules ()
+           ((name . applied-args)
+            (let* ((subst-alist (map cons 'args 'applied-args))
+                   (replaced-body (apply-substitution `body subst-alist)))
+              replaced-body))))))))
+
+(define (apply-symbol-substitution sym subst-alist)
+  ;; All non-symbol substitutions will be filtered.
+  ;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
+  ;; only ((U . w) (W . e)) will be applied to symbols.
+  (let ((str (symbol->string sym))
+        (subst-map (map (fn
+                         (if (symbol? (car x))
+                             (cons
+                              (fmt #f "([^\\-]?)"
+                                   (regexp-escape (symbol->string (car x)))
+                                   "([\\-$]?)")
+                              (fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
+                             x))
+                        (filter (fn (symbol? (cdr x))) subst-alist))))
+    (string->symbol
+     (string-substitute* str subst-map))))
+
+(define (maybe-replace-symbol sym subst-alist)
+  (call/cc
+   (lambda (return)
+     (for-each (fn (when (eq? (car x) sym)
+                     (return (cdr x))))
+               subst-alist)
+     (return sym))))
+
+(define (apply-substitution target subst-alist)
+  ;; Subsitute free symbols and -/$/^ separated parts
+  ;; of symbols with provided forms.
+  ;; E.g. with substitution (T int):
+  ;; list-T -> list-int ; by apply-symbol-substitution
+  ;; (var T data) -> (var int data) ; by maybe-replace-symbol
+  ;; see respective functions for further details.
+  (tree-map
+   (fn
+    (if (symbol? x)
+        (let ((st (maybe-replace-symbol x subst-alist)))
+          (if (eq? st x)
+              (apply-symbol-substitution x subst-alist)
+              st))
+        x))
+   target))

tests/Makefile

@@ -1 +0,0 @@
-

tests/basic.scm

@@ -1,35 +0,0 @@
-(test-begin "basic")
-
-;;; unkebabify
-(test '- (unkebabify '-))
-(test '-- (unkebabify '--))
-(test '-> (unkebabify '->))
-(test '-= (unkebabify '-=))
-(test 'kebab_case (unkebabify 'kebab-case))
-(test '_what_ (unkebabify '-what-))
-(test 'this->member (unkebabify 'this->member))
-(test '_this_->_member_ (unkebabify '-this-->-member-))
-(test '__->>> (unkebabify '--->>>))
-
-;;; atom-to-fmt-c
-(test '%fun (atom-to-fmt-c 'fn))
-(test '%prototype (atom-to-fmt-c 'prototype))
-(test '%var (atom-to-fmt-c 'var))
-(test '%block-begin (atom-to-fmt-c 'begin))
-(test '%define (atom-to-fmt-c 'define))
-(test '%pointer (atom-to-fmt-c 'pointer))
-(test '%array (atom-to-fmt-c 'array))
-(test 'vector-ref (atom-to-fmt-c '@))
-(test '%include (atom-to-fmt-c 'include))
-(test '%cast (atom-to-fmt-c 'cast))
-
-;;; c89 stuff
-(test 'int (atom-to-fmt-c 'bool))
-(test 1 (atom-to-fmt-c 'true))
-(test 0 (atom-to-fmt-c 'false))
-
-;;; make-field-access
-(test 'a.b (make-field-access '(.b a)))
-(test 'a.b.c (make-field-access '(.c a.b)))
-
-(test-end)

tests/run.scm

@@ -1,14 +0,0 @@
-(declare (uses fmt-c-writer
-               semen))
-
-(import
-  (chicken process)
-  (chicken process-context)
-  srfi-1
-  test)
-
-(include "basic.scm")
-(include "semen.scm")
-
-;;; Should be the last in the test suite
-(test-exit)

tests/semen.scm

@@ -1,53 +0,0 @@
-(define print-str-fn
-  '(fn void print-str ((string s))
-       (printf "%s" s)))
-
-(define sum-fn
-  '(pub fn float sum ((int a) (int b))
-        (return (cast float (+ a b)))))
-
-(test-begin "semen")
-(test-assert (sex-fn? print-str-fn))
-(test #f (sex-fn-public? print-str-fn))
-(test 'void (sex-fn-return-type print-str-fn))
-(test 'print-str (sex-fn-name print-str-fn))
-(test '((string s)) (sex-fn-arglist print-str-fn))
-(test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn))
-(test '((printf "%s" s)) (sex-fn-body print-str-fn))
-
-(test-assert (sex-fn? sum-fn))
-(test #t (sex-fn-public? sum-fn))
-(test 'float (sex-fn-return-type sum-fn))
-(test 'sum (sex-fn-name sum-fn))
-(test '((int a) (int b)) (sex-fn-arglist sum-fn))
-(test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
-(test '((return (cast float (+ a b)))) (sex-fn-body sum-fn))
-
-(let ((sex-code
-       '((defmacro (sum-var name a b c)
-           `(var ,name ,(+ a b c)))
-
-         (sum-var v 1 2 3))))
-
-  (test '((var v 6)) (semen-process sex-code)))
-
-;;; Macro expansion
-
-(test 'a (semen-walk-form 'a identity))
-(test '(a b c) (semen-walk-form '(a b c) identity))
-
-(test 'a (semen-macro-expand 'a))
-(test '(a b c) (semen-macro-expand '(a b c)))
-
-(let ((sex-code-macro
-       '((defmacro (x10 a)
-           `(* 10 ,a))
-
-         (fn void foo ((int a) (int b))
-             (return (+ a (x10 b)))))))
-
-  (test '((fn void foo ((int a) (int b))
-              (return (+ a (* 10 b)))))
-        (semen-process sex-code-macro)))
-
-(test-end)

utils.macros.scm

@@ -1,17 +0,0 @@
-(import (chicken process-context))
-
-(define-syntax prog1
-  (syntax-rules ()
-    ((prog1 form . forms)
-     (let ((res form))
-       (begin . forms)
-       res))))
-
-(define-syntax with-directory
-  (syntax-rules ()
-    ((with-directory path form . forms)
-     (let ((current-dir (current-directory)))
-       (set-working-directory path)
-       (prog1
-        (begin form . forms)
-        (change-directory current-dir))))))

utils.scm

@@ -1,19 +0,0 @@
-(declare (unit utils))
-
-(include "utils.macros.scm")
-
-(import
-  (chicken pathname)
-  (chicken process-context))
-
-(define (get-env-var name)
-  (get-environment-variable name))
-
-(define (set-working-directory file)
-  (change-directory
-   (normalize-pathname
-    (if (absolute-pathname? file)
-        (pathname-directory file)
-        (make-absolute-pathname
-         (current-directory)
-         (pathname-directory file))))))