still mess, probably obsolete anyways

begin-wrapped blocks are now creating lexical scopes

Makefile

@@ -1,4 +1,20 @@
 CHICKEN_C = csc
 
-sexc: sexc.scm
-	$(CHICKEN_C) $< -o $@
+MODULES = sexc sex-macros sex-modules sex-types utils fmt-c
+OBJ = $(MODULES:%=%.o)
+
+sexc: main.o $(OBJ)
+	$(CHICKEN_C) $^ -o $@
+
+main.o: main.scm
+	$(CHICKEN_C) $< -c -o $@
+
+%.o: %.scm
+	$(CHICKEN_C) $< -e -c -o $@
+
+sex-tests: $(OBJ) tests/*.scm
+	cd ./tests && $(CHICKEN_C) run.scm -c -o sex-tests.o
+	$(CHICKEN_C) $(OBJ) ./tests/sex-tests.o -o sex-tests
+
+clean:
+	rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o

Readme.org

@@ -1,30 +1,147 @@
 * The Sex language
-Sex is a S-expressions language, which transpiles to C.
+Sex is a S-expressions language. Sex is written in Chicken, which is a
+[[https://call-cc.org][R5RS Scheme]].
 
-* Compilation and usage
-Sex is written in Chicken Scheme, so first you'll need to get yourself
-a Chicken.
+* Compilation
+First, get yourself a Chicken, then, some Chicken deps. You also will
+need a C compiler.
+
+** Install Chicken Eggs
+Tip: there's a way to make Chicken install eggs non-globally. You need
+to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
+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~
 
 ** Compilation
 ~make~
 
-** Usage
-You'll also need a C compiler, so pick any.
+* Usage
+** Summary
 #+begin_src
-cat hello-world.sex | sexc > hello_world.c
-cc hello_world.c -o hello_world
+Usage: sexc [options] filename [-- options-for-c-compiler]
+Options:
+ --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
+ -E, --preprocess         Emit C code
+ --public-interface       Get module's public interface
+ -h, --help               Show this help
+ -m, --macro-expand       Emit macro-expanded Sex code
+ -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
+directory. Sex uses C under the hood, the default C compiler is ~cc~,
+but you can pass any using ~--c-compiler~ option, or by setting
+~SEX_CC~ environment variable.
+
+** Example
+An example of Sex source:
+#+begin_src scheme
+(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)
+  0)
+#+end_src
+
+Compile and run:
+#+begin_src shell
+~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
+~/dev/sex $ ./hello-world
+Hello from Sex!
+What is your name?
+Alex
+Hello, Alex!
 #+end_src
 
 * Features
 ** Full C interoperability
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
-have is C. For hardcore fans of traditional Lisp naming convention,
+have is C.
+
+** Auto unkebabification
+For hardcore fans of traditional Lisp naming convention,
 Sex offers automatic unkebabification of all symbols, i.e. no more
-ugly ~GL_ARRAY_BUFFER~'s in your code, they may be writted in their
+ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
+** Modules
+Each source file is a module. Module can provide public interface and
+be imported by using ~(import path/to/module)~ expression. Module
+search path consists of two parts: first is relative to the source
+being compiled location, and the second is ~SEX_MODULE_PATH~
+environment variable.
+
+Module's public interface consists of everything declared
+~pub~. Structures, function, macros, types, variables can be
+public.
+
+** Syntactic macros
+Sex has support for syntactic macros. Macro definitions look like
+functions: they have a name, an argument list and a body. Macro should
+return Sex code.
+
+*** Examples:
+**** Structure with templated value type
+#+begin_src scheme
+(pub defmacro (list-T type)
+  (let ((list-type (cat 'list- type)))
+    `(struct ,list-type
+       ((,type value)
+        ((* ,list-type) next)))))
+
+(list-T int)
+#+end_src
+->
+#+begin_src scheme
+(struct list_int
+ ((int value)
+  ((* list_int) next)))
+#+end_src
+
+**** Wrapper for checking return codes
+#+begin_src scheme
+(pub defmacro (check-sdl-return call message ret-code)
+  `((if (< 0 ,call)
+        (begin
+         (puts ,message)
+         (return ,ret-code)))))
+
+(pub fn int init ()
+  (check-sdl-return
+    (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
+...)
+#+end_src
+->
+#+begin_src c
+(%fun int init ()
+  (if (< 0 (SDL_Init SDL_INIT_VIDEO))
+    (%begin (puts "Failed to initialize SDL") (return 1)))
+  ...)
+}
+#+end_src
+
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
 best option.
 
-** COMING SOON: Polymorhpism
+*** 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
+(use-package sex-mode
+  :load-path "/path/to/sex"
+  :mode ("\\.sex\\'"))
+#+end_src

example/begin.sex

@@ -0,0 +1,8 @@
+(pub fn void other-fn ()
+  (begin (while true (begin 1 2 3 4)))
+  (switch a
+          ((1) (begin
+                (var (const char *) str "121232132")
+                (puts "str")))
+          ((2) (puts "2"))
+          (default (puts "more"))))

example/fn-no-args.sex

@@ -0,0 +1 @@
+(pub fn void no-args-fn () ())

example/hello-world.sex

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

example/list.sex

@@ -0,0 +1,47 @@
+(pub defmacro (list-T type)
+  (let ((list-type (cat 'list- type)))
+    `(struct ,list-type
+       ((,type value)
+        ((* ,list-type) next)))))
+
+(pub defmacro (make-list-T type is-public?)
+  (let ((list-type (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 (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 (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)
+    ((,(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/polymorphism.sex

@@ -0,0 +1,25 @@
+(include stdint.h)
+
+(struct vec2
+  ((uint32_t x)
+   (uint32_t y)))
+
+(trait gui
+  (fn void update ((float dt)))
+  (fn void render ())
+  (fn vec2 get-position ())
+  (fn void add-child ((gui *w))))
+
+(struct button
+  ((vector gui) children)
+  ((vec2 pos)))
+
+(impl gui button
+  (fn void update ((float dt))
+    ())
+  (fn void render ()
+    ())
+  (fn vec2 get-position ()
+    (return self->pos))
+  (fn void add-child ((gui *w))
+    (push self->children w)))

example/test-list.sex

@@ -0,0 +1,49 @@
+(include stdlib.h)
+(include stddef.h)
+(include stdio.h)
+
+(chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
+
+(import list)
+
+(chicken-define (imports-test a b c)
+  (fold + 0 (list 1 2 3 a b c)))
+
+(struct foo
+  ((float a-field)
+   (int b)
+   ((const char *) c)
+   ((fn bool ((bool val))) not)))
+
+(var foo f)
+
+(list-T int)
+(make-list-T int #f)
+(add-value-list-T int #f)
+(length-list-T int #f)
+(is-empty-list-T int #f)
+
+(extern fn void puk ((int a) (float b)))
+(fn int bar () (return ,(imports-test 10 20 30)))
+(pub fn bool baz () (return true))
+
+(extern var int i)
+(var int j)
+(pub var int k)
+
+(pub fn int main ()
+     (var (* list-int) l (make-list-int))
+     (printf "Size of the list: %lu\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))
+     (list-for-each list-int l int v
+       (printf "%d " v))
+     (printf "\n")
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (printf "%p\n" (cast void* l->next))
+     (return 0))
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each (const list-int) l int v (printf "%d " v))
+     (printf "\n"))

fmt-c.scm

@@ -0,0 +1,919 @@
+;;;; 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

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

main.scm

@@ -0,0 +1,6 @@
+;;; The purpose of this file is to compile it to the only
+;;; .o that has main entry point.
+
+(declare (uses sexc))
+
+(main)

sex-macros.scm

@@ -0,0 +1,30 @@
+(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 (macro? form)
+  (and (list? form)
+       (symbol? (car form))
+       (get (car form) 'sex-macro)))
+
+(define (defmacro form)
+  (let ((arglist (car form))
+        (body (cdr form)))
+    (register-macro (car arglist) (cdr arglist) body)))

sex-mode.el

@@ -0,0 +1,107 @@
+(require 'scheme)
+
+(defgroup sex-mode nil
+  "Major mode for Sex code."
+  :prefix 'sex-
+  :group 'languages)
+
+(define-abbrev-table 'sex-mode-abbrev-table ()
+  "Abbrev table for Sex mode.
+It has `scheme-mode-abbrev-table' as its parent."
+  :parents (list scheme-mode-abbrev-table))
+
+(defvar sex-mode-syntax-table
+  (let ((table (make-syntax-table lisp-data-mode-syntax-table)))
+    table))
+
+(defvar sex-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map lisp-mode-shared-map)
+    map)
+  "Keymap for Sex mode.
+All commands in `lisp-mode-shared-map' are inherited by this map.")
+
+(defvar sex-mode-line-process "")
+
+(defconst sex-font-lock-keywords
+  (eval-when-compile
+    (list
+     ;; Declarations
+     (list (concat "("
+                   (regexp-opt '("chicken-define"
+                                 "chicken-define-syntax"
+                                 "chicken-import"
+                                 "chicken-load"
+                                 "define"
+                                 "defmacro"
+                                 "extern"
+                                 "impl"
+                                 "import"
+                                 "include"
+                                 "fn"
+                                 "pub"
+                                 "struct"
+                                 "trait"
+                                 "var"
+                                 "union")
+                               'word)
+                   "\\>"
+                   "[[:space:]]*"
+                   "\\([[:word:]]*\\)")
+           '(1 font-lock-keyword-face)
+           '(2 font-lock-function-name-face))
+     ;; Keywords
+     (list (concat "("
+                   (regexp-opt '(
+                                 "case"
+                                 "do"
+                                 "if"
+                                 "for"
+                                 "goto"
+                                 "return"
+                                 "self"
+                                 "switch"
+                                 "var"
+                                 "while")
+                               'word)
+                   "\\>")
+           '(1 'font-lock-builtin-face)))))
+
+(defun sex-mode-set-variables ()
+  (set-syntax-table sex-mode-syntax-table)
+  (setq local-abbrev-table sex-mode-abbrev-table)
+  (setq mode-line-process '("" sex-mode-line-process))
+  (setq font-lock-defaults
+        '((sex-font-lock-keywords)
+          nil nil
+          (("+-*/.<>=!?$%_&:" . "w"))
+          nil
+          (font-lock-mark-block-function . mark-defun)))
+  (setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
+
+(put 'fn 'lisp-indent-function 'defun)
+(put 'pub 'lisp-indent-function 'defun)
+(put 'defmacro 'lisp-indent-function 'defun)
+(put 'struct 'lisp-indent-function 'defun)
+(put 'union 'lisp-indent-function 'defun)
+(put 'trait 'lisp-indent-function 'defun)
+(put 'impl '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"
+  "Major mode for editing Sex code.
+Editing commands are similar to those of `lisp-mode'.
+
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs.  Semicolons start comments.
+\\{sex-mode-map}"
+  :group 'sex-mode
+  (sex-mode-set-variables))
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.\\(sex\\|hsex\\)\\'" . sex-mode))
+
+(provide 'sex-mode)

sex-modules.scm

@@ -0,0 +1,86 @@
+; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
+; things start to break.
+(declare (unit sex-modules)
+         (uses utils))
+
+(import brev-separate
+        (chicken file)
+        (chicken load)
+        (chicken pathname)
+        (chicken process-context)
+        (chicken string)
+        fmt
+        srfi-1)
+
+(define +persistent-module-paths+ (list))
+
+(define (import-modules 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)))
+
+(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-types.scm

@@ -0,0 +1,23 @@
+(declare
+  (unit sex-types)
+  (uses fmt-c))
+
+(import fmt
+        srfi-69)
+
+(define +all-types+ (make-hash-table))
+
+(define (normalize-type type)
+  )
+
+(define (add-pointer type)
+  (list 'pointer type))
+
+(define (add-const type)
+  (list 'const type))
+
+(define (get-types-from-arglist arglist)
+  (list))
+
+(define (to-c-type type)
+  (fmt #f (c-type type)))

sexc.scm

@@ -1,33 +1,360 @@
-(import brev-separate fmt fmt-c tree (chicken string))
+(declare (unit sexc)
+         (uses fmt-c
+               sex-macros
+               sex-modules))
+
+(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
+        getopt-long
+        regex
+        srfi-1                          ; list routines
+        srfi-13                         ; string routines
+        tree)
 
 (define (unkebabify sym)
-  (string->symbol
-   (string-translate (symbol->string sym) #\- #\_)))
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
+     (string->symbol
+      (string-substitute "-(?!>)" "_"
+                         (symbol->string sym) #t)))))
 
-(define (loop)
+(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)))))
+
+(require-library chicken-syntax)
+
+(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 - macro
+   ((macro? form)
+    (append (fold-right
+             walk-generic
+             (list)
+             (apply (get-macro (car form)) (cdr 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 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))
+    ((define defmacro import include struct typedef union var)
+     ;; ignore here, used in generating public interface
+     (process-form (cdr form) acc))
+    (else
+     (error "Pub what?" (cadr form)))))
+
+(define (walk-sex-tree form acc)
+  (if (list? form)
+      (if (macro? form)
+          (fold-right (fn (walk-sex-tree x y))
+                      acc
+                      (list (apply (get-macro (car form)) (cdr 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)
+    ((defmacro) (defmacro (cdr form)) acc)
+    ((chicken-load)
+     (load (cadr form)) acc)
+    ((chicken-import)
+     (eval (cons 'import (cdr form))) acc)
+    ((import)
+     (append (process-raw-forms
+              (import-modules (cdr form)) (list))
+             acc))
+    (else
+     (walk-sex-tree form acc))))
+
+(define (process-raw-forms raw-forms acc)
+  "First processing pass"
+  (if (null? raw-forms)
+      (reverse acc)
+      (process-raw-forms (cdr raw-forms)
+                         (process-form (car raw-forms) acc))))
+
+;;; Second pass
+
+(define (process-sex-forms forms)
+  "Second processing pass.
+
+In this pass we do form-rearranging manipulations, like docstring extraction."
+  forms)
+
+;;; Aux functions
+
+(define (read-forms acc)
   (let ((r (read)))
-    (unless (eof-object? r)
-      (cond ((eqv? (car r) 'define) (eval r))
-            (#t
-             (fmt #t
-                  (c-expr
-                   (tree-map
-                    (fn
-	             (case x
-                       ((fn) '%fun)
-                       ((var) '%var)
-                       ((begin) '%begin)
-	               ((pointer) '%pointer)
-                       ((array) '%array)
-                       (([]) 'vector-ref)
-                       ((include) '%include)
-	               ((cast) '%cast)
-                       (else
-                        (if (symbol? x)
-                            (unkebabify x)
-                            x))))
-                    r)))
-             (fmt #t "\n")))
-      (loop))))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
 
-(loop)
+(define (emit-c forms)
+  "Final conversion to C"
+  (for-each (lambda (form)
+              (fmt #t (c-expr form) nl))
+            forms))
+
+;;; Main function facilities
+
+(define opts-grammar
+  (let ((padding 26))
+    `((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))
+      (compile-object "Compile object file instead of executable program"
+                      (required #f)
+                      (value #f)
+                      (single-char #\c))
+      (preprocess "Emit C code"
+                  (required #f)
+                  (value #f)
+                  (single-char #\E))
+      (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 Sex code"
+                    (required #f)
+                    (value #f)
+                    (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 "Options:\n")
+  (fmt #t (usage opts-grammar))
+  (fmt #t ""))
+
+(define (help-arg? args)
+  (assoc 'help args))
+
+(define (get-arg args arg-name default)
+  (let ((arg (assoc arg-name args)))
+    (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)))
+    (if (null? rest-args)
+        'stdin
+        (car rest-args))))
+
+(define (read-from-file file)
+  (with-directory file
+   (with-input-from-file (pathname-strip-directory file)
+     (fn (read-forms (list))))))
+
+(define (write-to-file-or-stdout output what)
+  (if (eq? output 'default)
+      (what)
+      (with-output-to-file output
+        (fn (what)))))
+
+(define (preprocess-or-macroexpand sex-forms output args)
+  (write-to-file-or-stdout
+   output
+   (lambda ()
+    (if (get-arg args 'macro-expand #f)
+        (map pp sex-forms)
+        (emit-c sex-forms)))))
+
+(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 "-std=c89" "-pedantic" "-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 (process-input input raw-forms)
+  (let ((current-dir (current-directory)))
+    (unless (eq? input 'stdin)
+      (set-working-directory input))
+    (prog1
+     (process-raw-forms raw-forms (list))
+     (change-directory current-dir))))
+
+(define (main)
+  (let* ((raw-args (command-line-arguments))
+         (args (getopt-long raw-args
+                            opts-grammar))
+         (output (get-arg args 'output 'default))
+         (help (help-arg? args))
+
+         (input (get-input-file args))
+         (current-dir (current-directory)))
+    (call/cc
+     (lambda (return)
+       (when help
+         (print-help)
+         (return #f))
+       (when (get-arg args 'public-interface #f)
+         (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
+
+         (write-to-file-or-stdout
+          output
+          (fn
+           (map pp (reverse
+                    (read-public-interface input)))))
+         (return #f))
+       (load-persistent-module-paths)
+
+       (let* ((raw-forms
+               (if (eq? input 'stdin)
+                   (read-forms (list))
+                   (read-from-file input)))
+              (sex-forms
+               (process-sex-forms
+                (process-input input raw-forms))))
+         (if (or (get-arg args 'macro-expand #f)
+                 (get-arg args 'preprocess #f))
+             ;; Preprocess or macroexpand
+             (preprocess-or-macroexpand sex-forms output args)
+             ;; Compile file!
+             (compile-to-file sex-forms output args)))))))

tests/Makefile

@@ -0,0 +1 @@
+

tests/basic.scm

@@ -0,0 +1,31 @@
+;;; 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)))

tests/run.scm

@@ -0,0 +1,13 @@
+(declare (uses sexc))
+
+(import
+  (chicken process)
+  (chicken process-context)
+  srfi-1
+  test)
+
+(include "basic.scm")
+(include "types.scm")
+
+;;; Should be the last in the test suite
+(test-exit)

tests/types.scm

@@ -0,0 +1 @@
+(test "char *" (to-c-type '(%pointer char)))

utils.macros.scm

@@ -0,0 +1,15 @@
+(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

@@ -0,0 +1,19 @@
+(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))))))