dump

.gitignore

@@ -1,3 +1,4 @@
 *.o
+*.import.scm
 sexc
 sex-tests

Makefile

@@ -1,21 +1,53 @@
 CHICKEN_C = csc
 CSC_FLAGS += -K prefix
 
-MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
+# Order matters, since module check correctness on compilation
+MODULES = utils macros reader module-system semen sex-fmt-c fmt-c-writer sexc
 OBJ = $(MODULES:%=%.o)
+IMPORTS = $(MODULES:%=%.import.scm)
+LINK = $(MODULES:%=%.link)
 
-sexc: main.o $(OBJ)
+sexc: $(OBJ) main.o
 	$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
 
 main.o: main.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@
+	$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ -link sexc
 
+#------------------------------------------------------------------
+
+utils.o: utils.scm
+	$(CHICKEN_C) $(CSC_FLAGS) utils.scm -e -c -J -o utils.o -unit utils
+
+macros.o: macros.scm
+	$(CHICKEN_C) $(CSC_FLAGS) macros.scm -e -c -J -o macros.o -unit macros
+
+reader.o:
+	$(CHICKEN_C) $(CSC_FLAGS) reader.scm -e -c -J -o reader.o -unit reader
+
+module-system.o: module-system.scm reader.import.scm utils.import.scm
+	$(CHICKEN_C) $(CSC_FLAGS) module-system.scm -e -c -J -o module-system.o -unit module-system -link reader,utils
+
+semen.o: semen.scm macros.import.scm module-system.import.scm utils.import.scm
+	$(CHICKEN_C) $(CSC_FLAGS) semen.scm -e -c -J -o semen.o -unit semen -link macros,module-system,utils
+
+fmt-c-writer.o: fmt-c-writer.scm sex-fmt-c.import.scm utils.import.scm
+	$(CHICKEN_C) $(CSC_FLAGS) fmt-c-writer.scm -e -c -J -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
+
+sexc.o: sexc.scm fmt-c-writer.import.scm macros.import.scm module-system.import.scm reader.import.scm semen.import.scm utils.import.scm
+	$(CHICKEN_C) $(CSC_FLAGS) sexc.scm -e -c -J -o sexc.o -unit sexc -link fmt-c-writer,macros,module-system,reader,semen,utils
+
+%.link: %.o
+%.import.scm: %.o
 %.o: %.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@
+	$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%)
+
 
 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) main.o ./tests/sex-tests.o
+	rm -f $(IMPORTS)
+	rm -f $(LINK) main.link
+	rm -f sexc sex-tests

example/mini-test.sex

@@ -0,0 +1,2 @@
+(pub fn main () int
+  (var l (* (struct list-int)) (make-list-int)))

example/our-reader.sex

@@ -0,0 +1,25 @@
+(include stdio.h)
+
+(defmacro (plus . rest)
+  `(+ ,@rest))
+
+(struct vertex
+  ((pos (struct ((x u32) (y u32))))
+   (color (struct ((r float) (g float) (b float))))
+   (mask u32)))
+
+(enum
+ (B A R))
+
+;;; Main entry point
+;;; Multi line comments should be packed
+(pub fn main () int
+  ;; the vertex
+  (var a (struct vertex) #(#(10 20)
+                           #(0.3 0.5 0.7)
+                           (c-bit-or B A R)))
+  (printf "%d %f %d\n" ; the printf
+          (plus a.pos.x a.pos.y)
+          (plus a.color.r a.color.g a.color.b)
+          a.mask)
+  (return 0))

example/structs.sex

@@ -0,0 +1,6 @@
+(struct settings
+  ((b-x u32)
+   (l r t b x y w h u32)
+   (color (struct
+            ((r g b a float))))
+   (colors [struct color ((r g b a float))])))

fmt-c-writer.scm

@@ -1,283 +1,285 @@
 ;;; Sex fmt-c output writer
 
-(declare (unit fmt-c-writer)
+(module fmt-c-writer (emit-c
-         (uses fmt-c
+                      sex-fmt-current-file)
-               semen
+  (import
-               utils))
+    scheme
+    (chicken base)
+    (chicken string)
+    (chicken syntax)
+    brev-separate
+    fmt
+    sex-fmt-c
+    matchable
+    regex
+    srfi-1                                ; lists
+    srfi-13                               ; strings
+    srfi-39                               ; parameters
+    tree
+    utils)
 
-(import (chicken string)
+  (define (unkebabify sym)
-        (chicken syntax)
+    (case sym
-        brev-separate
+      ((-) sym)
-        fmt
+      ((--) sym)
-        matchable
+      ((->) sym)
-        regex
+      ((-=) sym)
-        srfi-1                          ; lists
+      (else
-        srfi-13                         ; strings
+       (string->symbol
-        srfi-39                         ; parameters
+        (string-substitute "-(?!>)" "_"
-        tree)
+                           (symbol->string sym) #t)))))
 
-(define (unkebabify sym)
+  (define (atom-to-fmt-c atom)
-  (case sym
+    (case atom
-    ((-) sym)
+      ((fn) '%fun)
-    ((--) sym)
+      ((prototype) '%prototype)
-    ((->) sym)
+      ((begin) '%block-begin)
-    ((-=) sym)
+      ((define) '%define)
-    (else
+      ((pointer) '%pointer)
+      ((array) '%array)
+      ((attribute) '%attribute)
+      ((¤) 'vector-ref)
+      ((include) '%include)
+      ;; uh things we do for c89 compatibility
+      ((bool) 'int)
+      ((true) 1)
+      ((false) 0)
+      (else
+       (if (symbol? atom)
+           (unkebabify atom)
+           atom))))
+
+  (define (maybe-unwrap-type type)
+    (if (and (list? type)
+             (= 1 (length type)))
+        (car type)
+        type))
+
+  (define (make-field-access form)
+    (assert
+     (= 2 (length form)) "Wrong field access format")
+    (unkebabify
      (string->symbol
-      (string-substitute "-(?!>)" "_"
+      (fmt #f (cadr form) (car form)))))
-                         (symbol->string sym) #t)))))
 
-(define (atom-to-fmt-c atom)
+  (define (walk-generic-toplevel form)
-  (case atom
+    (cond ((atom? form) (atom-to-fmt-c form))
-    ((fn) '%fun)
+          ((list? form) (map walk-generic-toplevel form))
-    ((prototype) '%prototype)
+          (else (error "Malformed form " form))))
-    ((begin) '%block-begin)
-    ((define) '%define)
-    ((pointer) '%pointer)
-    ((array) '%array)
-    ((attribute) '%attribute)
-    ((¤) 'vector-ref)
-    ((include) '%include)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
-    (else
-     (if (symbol? atom)
-         (unkebabify atom)
-         atom))))
 
-(define (maybe-unwrap-type type)
+  (define (field-access-form? form)
-  (if (and (list? type)
+    (and (symbol? (car form))
-           (= 1 (length type)))
+         (char=? #\. (string-ref (symbol->string (car form)) 0))))
-      (car type)
-      type))
 
-(define (make-field-access form)
+  (define (walk-expr form)
-  (assert
+    (match form
-   (= 2 (length form)) "Wrong field access format")
+      ((? vector?)
-  (unkebabify
+       (list->vector
-   (string->symbol
+        (walk-expr (vector->list form))))
-    (fmt #f (cadr form) (car form)))))
+      ((? atom?)
+       (atom-to-fmt-c form))
+      ((? field-access-form?)
+       (make-field-access form))
+      (('var . _) (walk-var form))
+      (('cast expr type) (list '%cast
+                               (walk-type type)
+                               (walk-expr expr)))
+      (('enum . _) (walk-enum form))
+      ;; | is problematic... And c-or/bit-or/etc are actually
+      ;; procedures, so we have to call the procedure itself
+      (('c-or . rest) (apply c-or (map walk-expr rest)))
+      (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
+      (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))
+      (else (map walk-expr form))))
 
-(define (walk-generic-toplevel form)
+  (define (walk-var form)
-  (cond ((atom? form) (atom-to-fmt-c form))
+    ;; (var a int) -> (%var int a)
-        ((list? form) (map walk-generic-toplevel form))
+    ;; (var a (const int) 32) -> (%var (const int) a 32)
-        (else (error "Malformed form " form))))
+    ;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
+    ;; note: [...] is actually (¤ ...) after reading
+    ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
+    `(%var
+      ,(walk-type (third form))
+      ,(atom-to-fmt-c (second form))
+      .
+      ,(if (null? (drop form 3))
+           (list)
+           (walk-expr (drop form 3)))      ; optional init expression
+      ))
 
-(define (field-access-form? form)
+  (define (walk-type form)
-  (and (symbol? (car form))
+    ;; int -> int
-       (char=? #\. (string-ref (symbol->string (car form)) 0))))
+    ;; (const int) -> const int
+    ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
+    ;; [float 8] -> (%array float 8)
+    ;; (* const char) -> (const char *)
+    ;; (const * const * const char) -> (const char * const * const)
+    ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
+    (match form
+      (('¤ . array-type)
+       (if (integer? (last array-type))
+           ;; sized array
+           (let* ((type-list (drop-right array-type 1))
+                  (type (maybe-unwrap-type type-list))
+                  (size (last array-type)))
+             `(%array ,(walk-type type)
+                      ,size))
+           ;; sugar for pointer... Do we really need it? Guess why not,
+           ;; it's a strong semantic cue
+           `(%array ,(walk-type (maybe-unwrap-type array-type)))))
+      (('fn arglist ret-type)
+       `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
+      (('fn . _)
+       (assert #f "Malformed function type form"))
 
-(define (walk-expr form)
+      ;; Special case: nested structs/unions
-  (match form
+      ((or ('struct . _)
-    ((? vector?)
+           ('union . _)) (walk-struct form))
-     (list->vector
-      (walk-expr (vector->list form))))
-    ((? atom?)
-     (atom-to-fmt-c form))
-    ((? field-access-form?)
-     (make-field-access form))
-    (('var . _) (walk-var form))
-    (('cast expr type) (list '%cast
-                             (walk-type type)
-                             (walk-expr expr)))
-    (('enum . _) (walk-enum form))
-    ;; | is problematic... And c-or/bit-or/etc are actually
-    ;; procedures, so we have to call the procedure itself
-    (('c-or . rest) (apply c-or (map walk-expr rest)))
-    (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
-    (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))
-    (else (map walk-expr form))))
 
-(define (walk-var form)
+      (('enum . _) (walk-enum form))
-  ;; (var a int) -> (%var int a)
+      (else
-  ;; (var a (const int) 32) -> (%var (const int) a 32)
+       (type-convert-to-c form))))
-  ;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
-  ;; note: [...] is actually (¤ ...) after reading
-  ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
-  `(%var
-    ,(walk-type (third form))
-    ,(atom-to-fmt-c (second form))
-    .
-    ,(if (null? (drop form 3))
-         (list)
-         (walk-expr (drop form 3)))      ; optional init expression
-    ))
 
-(define (walk-type form)
+  (define (type-convert-to-c type)
-  ;; int -> int
+    ;; Our pointers to C pointers
-  ;; (const int) -> const int
+    ;; int -> int
-  ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
+    ;; * const char -> const char *
-  ;; [float 8] -> (%array float 8)
+    ;; const * const char -> const char * const
-  ;; (* const char) -> (const char *)
+    (if (atom? type) (atom-to-fmt-c type)
-  ;; (const * const * const char) -> (const char * const * const)
+        (flatten
-  ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
+         (tree-map atom-to-fmt-c
-  (match form
+                   (flatten
-    (('¤ . array-type)
+                    (list-join (reverse (list-split type '*))
-     (if (integer? (last array-type))
+                               '(*)))))))
-         ;; sized array
-         (let* ((type-list (drop-right array-type 1))
-                (type (maybe-unwrap-type type-list))
-                (size (last array-type)))
-           `(%array ,(walk-type type)
-                    ,size))
-         ;; sugar for pointer... Do we really need it? Guess why not,
-         ;; it's a strong semantic cue
-         `(%array ,(walk-type (maybe-unwrap-type array-type)))))
-    (('fn arglist ret-type)
-     `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
-    (('fn . _)
-     (assert #f "Malformed function type form"))
 
-    ;; Special case: nested structs/unions
+  (define (walk-fn-def form)
-    ((or ('struct . _)
+    (match form
-         ('union . _)) (walk-struct form))
+      (('fn name args ret-type . maybe-body)
-
+       `(%fun
-    (('enum . _) (walk-enum form))
+         ,(walk-type ret-type)
-    (else
+         ,(atom-to-fmt-c name)
-     (type-convert-to-c form))))
+         ,(walk-arglist args)
-
+         .
-(define (type-convert-to-c type)
+         ,(walk-expr maybe-body)))))
-  ;; Our pointers to C pointers
-  ;; int -> int
-  ;; * const char -> const char *
-  ;; const * const char -> const char * const
-  (if (atom? type) (atom-to-fmt-c type)
-      (flatten
-       (tree-map atom-to-fmt-c
-                 (flatten
-                  (list-join (reverse (list-split type '*))
-                             '(*)))))))
-
-(define (walk-fn-def form)
-  (match form
-    (('fn name args ret-type . maybe-body)
-     `(%fun
-       ,(walk-type ret-type)
-       ,(atom-to-fmt-c name)
-       ,(walk-arglist args)
-       .
-       ,(walk-expr maybe-body)))))
 
 ;;; TODO: isn't there a better way?
-(define (is-probably-type form)
+  (define (is-probably-type form)
-  (case (car form)
+    (case (car form)
-    ((¤ * const volatile struct union) #t)
+      ((¤ * const volatile struct union) #t)
-    (else #f)))
+      (else #f)))
 
-(define (walk-arglist form)
+  (define (walk-arglist form)
-  ;; E.g.:
+    ;; E.g.:
-  ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
+    ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
-  ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
+    ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
-  (map (fn
+    (map (fn
-        (match x
+          (match x
-          (('¤ . _) (walk-type x))
+            (('¤ . _) (walk-type x))
 
-          ;; yeah shitty, but I don't know yet how to determine if the
+            ;; yeah shitty, but I don't know yet how to determine if the
-          ;; first entry is part of the type and not an argument name
+            ;; first entry is part of the type and not an argument name
-          ;; :(
+            ;; :(
-          ((? is-probably-type) (walk-type x))
+            ((? is-probably-type) (walk-type x))
 
-          ;; 1 element args are always type
+            ;; 1 element args are always type
-          ((_) (walk-type x))
+            ((_) (walk-type x))
 
-          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
+            ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
-                                (list (walk-type var))))))
+                                  (list (walk-type var))))))
-       form))
+         form))
 
-(define (walk-function form)
+  (define (walk-function form)
-  ;; (fn ret-type name arglist body) -> normal function
+    ;; (fn ret-type name arglist body) -> normal function
-  ;; (fn ret-type name arglist) -> prototype
+    ;; (fn ret-type name arglist) -> prototype
-  (if (>= (length form) 5)
+    (if (>= (length form) 5)
-      (walk-fn-def form)
+        (walk-fn-def form)
-      (cons '%prototype (cdr (walk-fn-def form)))))
+        (cons '%prototype (cdr (walk-fn-def form)))))
 
-(define (process-struct-fields fields)
+  (define (process-struct-fields fields)
-  (map (fn
+    (map (fn
-        (let ((type (walk-type (last x))))
+          (let ((type (walk-type (last x))))
-          (cons type (map atom-to-fmt-c (drop-right x 1)))))
+            (cons type (map atom-to-fmt-c (drop-right x 1)))))
-       fields))
+         fields))
 
-(define (walk-struct form)
+  (define (walk-struct form)
-  (match form
+    (match form
-    ((type (fields ...) . attrs)        ; anonymous struct
+      ((type (fields ...) . attrs)        ; anonymous struct
-     `(,type ,(process-struct-fields fields)
+       `(,type ,(process-struct-fields fields)
-             . ,(tree-map atom-to-fmt-c attrs)))
+               . ,(tree-map atom-to-fmt-c attrs)))
-    ((type name)                        ; simple 'struct whatever', like in variable def
+      ((type name)                        ; simple 'struct whatever', like in variable def
-     `(,type ,(atom-to-fmt-c name)))
+       `(,type ,(atom-to-fmt-c name)))
-    ((type name (fields ...) . attrs)
+      ((type name (fields ...) . attrs)
-     `(,type ,(atom-to-fmt-c name)
+       `(,type ,(atom-to-fmt-c name)
-             ,(process-struct-fields fields)
+               ,(process-struct-fields fields)
-             . ,(tree-map atom-to-fmt-c attrs)))
+               . ,(tree-map atom-to-fmt-c attrs)))
-    (else (error "Malformed aggregate definition " form))))
+      (else (error "Malformed aggregate definition " form))))
 
-(define (walk-enum form)
+  (define (walk-enum form)
-  (match form
+    (match form
-    (('enum (values ...))
+      (('enum (values ...))
-     `(enum ,(map atom-to-fmt-c values)))
+       `(enum ,(map atom-to-fmt-c values)))
-    (('enum name (values ...))
+      (('enum name (values ...))
-     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
+       `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
 
-(define (walk-extern form)
+  (define (walk-extern form)
-  (match form
+    (match form
-    (('fn . _)
+      (('fn . _)
-     ;; extern function?.. What
+       ;; extern function?.. What
-     (list 'extern (walk-function form)))
+       (list 'extern (walk-function form)))
-    (('var . _)
+      (('var . _)
-     (list 'extern (walk-var form)))
+       (list 'extern (walk-var form)))
-    (else (error "Extern what?"))))
+      (else (error "Extern what?"))))
 
-(define (walk-public form)
+  (define (walk-public form)
-  (match form
+    (match form
-    (('fn . _)
+      (('fn . _)
-     (walk-function form))
+       (walk-function form))
-    (('var . _)
+      (('var . _)
-     (walk-var form))
+       (walk-var form))
-    ((or ('define . _)
+      ((or ('define . _)
-         ('defmacro . _)
+           ('defmacro . _)
 
-         ('import . _)
+           ('import . _)
-         ('include . _)
+           ('include . _)
 
-         ('struct . _)
+           ('struct . _)
-         ('union . _)
+           ('union . _)
 
-         ('typedef . _))
+           ('typedef . _))
-     ;; ignore here, used in generating public interface
+       ;; ignore here, used in generating public interface
-     (process-toplevel-form form))
+       (process-toplevel-form form))
-    (else
+      (else
-     (error "Pub what?" (cadr form)))))
+       (error "Pub what?" (cadr form)))))
 
-(define (process-toplevel-form form)
+  (define (process-toplevel-form form)
-  (match form
+    (match form
-    (('fn . _) (list 'static (walk-function form)))
+      (('fn . _) (list 'static (walk-function form)))
-    (('var . _) (list 'static (walk-var form)))
+      (('var . _) (list 'static (walk-var form)))
-    (('extern . rest) (walk-extern rest))
+      (('extern . rest) (walk-extern rest))
-    (('pub . rest) (walk-public rest))
+      (('pub . rest) (walk-public rest))
-    ((or ('struct . _)
+      ((or ('struct . _)
-         ('union . _)) (walk-struct form))
+           ('union . _)) (walk-struct form))
-    (('enum . _) (walk-enum form))
+      (('enum . _) (walk-enum form))
-    (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
+      (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
-    (else (walk-expr form))))
+      (else (walk-expr form))))
 
-(define (get-line-num form)
+  (define (get-line-num form)
-  (let ((num (get-line-number form)))
+    (let ((num (get-line-number form)))
-    (if (string? num)
+      (if (string? num)
-        (last (string-split num ":"))
+          (last (string-split num ":"))
-        #f)))
+          #f)))
 
-(define sex-fmt-current-file (make-parameter "/dev/null"))
+  (define sex-fmt-current-file (make-parameter "/dev/null"))
-(define sex-fmt-line-num (make-parameter 0))
+  (define sex-fmt-line-num (make-parameter 0))
 
-(define (line-directive-string)
+  (define (line-directive-string)
-  (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
+    (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
 
-(define (emit-c sex-forms)
+  (define (emit-c sex-forms)
-  (for-each (lambda (form)
+    (for-each (lambda (form)
-              (let ((start-line (get-line-num form)))
+                (let ((start-line (get-line-num form)))
-                (when start-line
+                  (when start-line
-                  (sex-fmt-line-num start-line)
+                    (sex-fmt-line-num start-line)
-                  (fmt #t (line-directive-string) nl)))
+                    (fmt #t (line-directive-string) nl)))
-              (fmt #t (c-expr (process-toplevel-form form)) nl))
+                (fmt #t (c-expr (process-toplevel-form form)) nl))
-            sex-forms))
+              sex-forms)))

fmt-c.scm

@@ -1,959 +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-1
-        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 (and (c-op<= (fmt-op st) op)
-                       (not (vector? st)))
-                  (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)
-  ;; can be just pointer to SUC, need to support such case:
-  ;; struct whatever * - body is just '*'
-  (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 (and (not (null? body))
-             (not (eq? '* 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)
-                  "")
-              (if (not (null? body))
-                  (cat body)
-                  ""))))))
-
-(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
-   (if (null? body)
-       (cat "while (" (c-in-test (c-expr check)) ");")
-       (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-param-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-param-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))))
-        (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)) "--"))

macros.scm

@@ -0,0 +1,45 @@
+(module macros
+    (register-macro
+     cat
+     get-macro
+     macro?
+     apply-macro
+     defmacro)
+  (import
+    scheme
+    (only fmt fmt)
+    (chicken base)
+    (chicken plist)
+    (chicken string))
+
+  (define (cat-syms s-1 s-2)
+    (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
+             (import scheme
+                     (only macros cat))
+             ,@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 (apply-macro form)
+    (assert (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))))

main.scm

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

module-system.scm

@@ -0,0 +1,92 @@
+(module module-system
+    (get-modules-public-forms
+     load-persistent-module-paths
+     read-public-interface)
+
+  (import
+    scheme
+    brev-separate
+    (chicken base)
+    (chicken file)
+    (chicken load)
+    (chicken pathname)
+    (chicken process-context)
+    (chicken string)
+    fmt
+    reader
+    srfi-1
+    utils)
+
+  (define +persistent-module-paths+ (list))
+
+  (define (get-modules-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 ":")))))))

reader.scm

@@ -0,0 +1,64 @@
+(module reader (read-from-file
+                read-raw-forms)
+  (import
+    scheme
+    (chicken base)
+    (chicken io)
+    (chicken pathname)
+    (chicken port)
+    (chicken read-syntax)
+    (chicken string)
+    (chicken syntax)
+    brev-separate
+    fmt)
+
+  (import-syntax utils)
+
+  (define (read-forms acc)
+    (let ((r (read-with-source-info (current-input-port))))
+      (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-bracket port)
+    (let loop ((c (read-char port))
+               (str (string)))
+      (cond ((char=? c #\])
+             (cons '¤
+                   (with-input-from-string str
+                     (fn (port-map identity read)))))
+            ((char=? c #\[)
+             (loop port (conc )))
+            (else
+             (loop (read-char port)
+                   (conc str c))))))
+
+  (define open-bracket-counter (make-parameter 0))
+
+  (define (read-raw-forms input-source)
+    (let ((bracket-end (gensym)))
+      (set-read-syntax!
+       #\]
+       (lambda (port)
+         (when (= 0 (open-bracket-counter))
+           (error "Unmatched closing bracket"))
+         (open-bracket-counter (- (open-bracket-counter) 1))
+         bracket-end))
+
+      (set-read-syntax!
+       #\[
+       (lambda (port)
+         (open-bracket-counter (+ (open-bracket-counter) 1))
+         (let loop ((r (read port))
+                    (acc (list)))
+           (if (eq? r bracket-end)
+               (cons '¤ (reverse acc))
+               (loop (read port)
+                     (cons r acc)))))))
+    (if (eq? input-source 'stdin)
+        (read-forms (list))
+        (read-from-file input-source))))

semen.scm

@@ -1,17 +1,22 @@
 ;;; Sex semantic engine
 
-(declare (unit semen)
+(module semen ()
-         (uses sex-macros
+  (import
-               sex-modules
+    scheme
-               utils))
+    (chicken base)
+    (chicken keyword)
+    (chicken string)
+    (chicken module)
+    fmt
+    macros
+    matchable                         ; pattern matching
+    module-system
+    srfi-1                            ; list routines
+    srfi-69                           ; hash tables
+    utils
+    )
 
-(import
+  (export/rename (process semen-process))
-  (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
@@ -21,86 +26,86 @@
 ;;; 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)
+  (define (process raw-sex-forms)
-  (semen-process-rec raw-sex-forms (list)))
+    (process-rec raw-sex-forms (list)))
 
-(define (semen-process-rec forms acc)
+  (define (process-rec forms acc)
-  (cond
+    (cond
-   ((null? forms) (reverse acc))
+     ((null? forms) (reverse acc))
-   ((sex-macro? (car forms))
+     ((macro? (car forms))
-    (semen-process-rec
+      (process-rec
-     (semen-apply-macro (car forms) (cdr forms))
+       (macroexpand (car forms) (cdr forms))
-     acc))
+       acc))
-   (else
+     (else
-    (semen-process-rec (cdr forms)
+      (process-rec (cdr forms)
-                       (match-sex-form (car forms) acc)))))
+                   (match-sex-form (car forms) acc)))))
 
-(define (semen-apply-macro macro-form rest-forms)
+  (define (macroexpand macro-form rest-forms)
-;; We want to replace macro with its expansion. The problem is,
+    ;; We want to replace macro with its expansion. The problem is,
-;; top-level macro can return either a single form, or a list of
+    ;; top-level macro can return either a single form, or a list of
-;; forms, when it for example generates some aux
+    ;; forms, when it for example generates some aux
-;; structures/functions/typedefs.
+    ;; structures/functions/typedefs.
-;;
+    ;;
-;; Single form we just cons to the top of rest-forms, but multiple
+    ;; Single form we just cons to the top of rest-forms, but multiple
-;; forms have to be appended to the rest-forms.
+    ;; forms have to be appended to the rest-forms.
-  (let ((res (apply-macro macro-form)))
+    (let ((res (apply-macro macro-form)))
-    (if (list? (car res))
+      (if (list? (car res))
-        (append res rest-forms)
+          (append res rest-forms)
-        (cons res rest-forms))))
+          (cons res rest-forms))))
 
-(define (match-sex-form sex-form acc)
+  (define (match-sex-form sex-form acc)
-  (match sex-form
+    (match sex-form
-    ((or ('fn . _)
+      ((or ('fn . _)
-         ('pub 'fn . _)
+           ('pub 'fn . _)
-         ('extern 'fn . _)) (process-fn sex-form acc))
+           ('extern 'fn . _)) (process-fn sex-form acc))
-    ((or ('struct . _)
+      ((or ('struct . _)
-         ('pub 'struct . _)) (process-struct sex-form acc))
+           ('pub 'struct . _)) (process-struct sex-form acc))
-    ((or ('union . _)
+      ((or ('union . _)
-         ('pub 'union . _)) (process-struct sex-form acc))
+           ('pub 'union . _)) (process-struct sex-form acc))
-    ((or ('enum . _)
+      ((or ('enum . _)
-         ('pub 'enum . _)) (process-struct sex-form acc))
+           ('pub 'enum . _)) (process-struct sex-form acc))
-    ((or ('var . _)
+      ((or ('var . _)
-         ('pub 'var . _)
+           ('pub 'var . _)
-         ('extern 'var . _)) (process-global-var sex-form acc))
+           ('extern 'var . _)) (process-global-var sex-form acc))
-    (('include _) (cons sex-form acc))
+      (('include _) (cons sex-form acc))
-    (('define . _) (cons sex-form acc))
+      (('define . _) (cons sex-form acc))
 
-    (('import . modules)
+      (('import . modules)
-     (semen-process-imports (get-public-forms modules) acc))
+       (process-imports (get-modules-public-forms modules) acc))
 
-    ((or ('defmacro . rest)
+      ((or ('defmacro . rest)
-         ('pub 'defmacro . rest)) (defmacro rest) acc)
+           ('pub 'defmacro . rest)) (defmacro rest) acc)
 
-    ((or ('typedef new-type target)
+      ((or ('typedef new-type target)
-         ('pub 'typedef new-type target))
+           ('pub 'typedef new-type target))
-     (process-typedef new-type target acc))
+       (process-typedef new-type target acc))
 
-    (else (assert #f (fmt #f "Unknown top level form " sex-form)))))
+      (else (assert #f (fmt #f "Unknown top level form " sex-form)))))
 
-(define (semen-process-imports module-public-forms acc)
+  (define (process-imports module-public-forms acc)
-  ;; Recursively process imports: register public macros, cons all
+    ;; Recursively process imports: register public macros, cons all
-  ;; other public things to our acc
+    ;; other public things to our acc
-  (if (null? module-public-forms) acc
+    (if (null? module-public-forms) acc
-      (match (car module-public-forms)
+        (match (car module-public-forms)
-        (('defmacro . rest)
+          (('defmacro . rest)
-         (defmacro rest)
+           (defmacro rest)
-         (semen-process-imports (cdr module-public-forms) acc))
+           (process-imports (cdr module-public-forms) acc))
-        (else
+          (else
-         (semen-process-imports (cdr module-public-forms)
+           (process-imports (cdr module-public-forms)
-                                (cons (car module-public-forms)
+                            (cons (car module-public-forms)
-                                      acc))))))
+                                  acc))))))
 
-(define (semen-macro-expand form)
+  (define (macro-expand form)
-  "Walk the form recursively and expand all macros, until none is left."
+    "Walk the form recursively and expand all macros, until none is left."
-  (semen-walk-form
+    (walk-form
-   form
+     form
-   (lambda (subform env)
+     (lambda (subform env)
-     (if (sex-macro? subform)
+       (if (macro? subform)
-         (cons semen-walk-embed-result (semen-apply-macro subform (list)))
+           (cons walk-embed-result (macroexpand subform (list)))
-         subform))
+           subform))
-   #f))
+     #f))
 
-;;; semen-walk-form and friends: form walker with various abilities.
+;;; walk-form and friends: form walker with various abilities.
 ;;; By default, replaces walked form with walk-fn result But may
 ;;; perform additional operations depending of what the walk function
 ;;; has requested.
@@ -108,128 +113,129 @@
 ;;; For inspiration, see SBCL's walk.lisp and their template
 ;;; system.
 
-(define semen-walk-embed-result (gensym)
+  (define walk-embed-result (gensym)
-  ;; For cases when result is a list which must be embedded in the
+    ;; For cases when result is a list which must be embedded in the
-  ;; form, e.g. when it returned from a macro
+    ;; form, e.g. when it returned from a macro
-  )
+    )
 
-(define (semen-walk-form form walk-fn env)
+  (define (walk-form form walk-fn env)
-  (if (atom? form) form
+    (if (atom? form) form
-      (let ((new-form (walk-fn form env)))
+        (let ((new-form (walk-fn form env)))
-        (cond ((not (eq? form new-form))
+          (cond ((not (eq? form new-form))
-               (semen-walk-form new-form walk-fn env))
+                 (walk-form new-form walk-fn env))
-              (else
+                (else
-               (let ((new-car (semen-walk-form (car new-form) walk-fn env))
+                 (let ((new-car (walk-form (car new-form) walk-fn env))
-                     (new-cdr (semen-walk-form (cdr new-form) walk-fn env)))
+                       (new-cdr (walk-form (cdr new-form) walk-fn env)))
-                 (cond ((and (pair? new-car)
+                   (cond ((and (pair? new-car)
-                             (eq? (car new-car) semen-walk-embed-result))
+                               (eq? (car new-car) walk-embed-result))
-                        (append (cdr new-car) new-cdr))
+                          (append (cdr new-car) new-cdr))
-                       (else
+                         (else
-                        (recons new-form new-car new-cdr)))))))))
+                          (recons new-form new-car new-cdr)))))))))
 
 ;;; Typdef
 
-(define (process-typedef new-type target acc)
+  (define (process-typedef new-type target acc)
-  (cons `(typedef ,target ,new-type) acc))
+    (cons `(typedef ,target ,new-type) acc))
 
 ;;; Fn processing
 
-(define (process-fn sex-fn acc)
+  (define (process-fn sex-fn acc)
-  (let* ((expanded (semen-macro-expand sex-fn))
+    (let* ((expanded (macro-expand sex-fn))
-         (env (make-hash-table))
+           (env (make-hash-table))
-         (processed
+           (processed
-          (semen-walk-form
+            (walk-form
-           expanded
+             expanded
-           semen-fn-walker
+             fn-walker
-           (begin
+             (begin
-             (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
+               (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-counter) 0)
-             (set! (hash-table-ref env :lambda-aux-code) (list))
+               (set! (hash-table-ref env :lambda-aux-code) (list))
-             env))))
+               env))))
 
-    (cons processed
+      (cons processed
-          (append (hash-table-ref env :lambda-aux-code) acc))))
+            (append (hash-table-ref env :lambda-aux-code) acc))))
 
-(define (semen-fn-walker form env)
+  (define (fn-walker form env)
-  (if (eq? 'lambda (car form))
+    (if (eq? 'lambda (car form))
-      (let ((lambda-name (semen-make-lambda-name (hash-table-ref env :fn-name)
+        (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
-                                                 (hash-table-ref env :lambda-counter))))
+                                             (hash-table-ref env :lambda-counter))))
-        (set! (hash-table-ref env :lambda-aux-code)
+          (set! (hash-table-ref env :lambda-aux-code)
-          (append (semen-make-aux-lambda-struct lambda-name form)
+            (append (make-aux-lambda-struct lambda-name form)
-                  (hash-table-ref env :lambda-aux-code)))
+                    (hash-table-ref env :lambda-aux-code)))
-        (set! (hash-table-ref env :lambda-counter)
+          (set! (hash-table-ref env :lambda-counter)
-          (+ (hash-table-ref env :lambda-counter) 1))
+            (+ (hash-table-ref env :lambda-counter) 1))
-        lambda-name)
+          lambda-name)
-    form))
+        form))
 
-(define (semen-make-lambda-name enclosing-fn-name counter)
+  (define (make-lambda-name enclosing-fn-name counter)
-  (string->symbol
+    (string->symbol
-   (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
+     (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
 
-(define (semen-make-aux-lambda-struct name form)
+  (define (make-aux-lambda-struct name form)
-  (match form
+    (match form
-    (('lambda ret-type arglist captures . body)
+      (('lambda ret-type arglist captures . body)
-     ;; Captures are ignored for now, but
+       ;; Captures are ignored for now, but
-     ;; we'll need them for TODO: closures support
+       ;; we'll need them for TODO: closures support
-     (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
+       (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
-    (else (assert #f (fmt #f "Malformed lambda " form)))))
+      (else (assert #f (fmt #f "Malformed lambda " form)))))
 
 ;;; Structs
 
-(define (process-struct sex-struct acc)
+  (define (process-struct sex-struct acc)
-  (cons sex-struct acc))
+    (cons sex-struct acc))
 
-(define (process-global-var sex-var acc)
+  (define (process-global-var sex-var acc)
-  (cons sex-var acc))
+    (cons sex-var acc))
 
 ;;; Utils
-(define (non-empty-list? form)
+  (define (non-empty-list? form)
-  (and (list? form)
+    (and (list? form)
-       (not (null? form))))
+         (not (null? form))))
 
-(define (sex-fn? form)
+  (define (sex-fn? form)
-  "The `form` must be toplevel.
+    "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
-  (match form
+    (match form
-    ((fn . _) form)
+      ((fn . _) form)
-    ((pub fn . _) form)
+      ((pub fn . _) form)
-    (else #f)))
+      (else #f)))
 
-(define (sex-fn-public? fn-form)
+  (define (sex-fn-public? fn-form)
-  (eq? (car fn-form) 'pub))
+    (eq? (car fn-form) 'pub))
 
-(define (sex-fn-return-type fn-form)
+  (define (sex-fn-return-type fn-form)
-  (assert (sex-fn? fn-form)
+    (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
+            (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
+    (if (sex-fn-public? fn-form)
-      (third fn-form)
+        (third fn-form)
-      (second fn-form)))
+        (second fn-form)))
 
-(define (sex-fn-name fn-form)
+  (define (sex-fn-name fn-form)
-  (assert (sex-fn? fn-form)
+    (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
+            (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
+    (if (sex-fn-public? fn-form)
-      (fourth fn-form)
+        (fourth fn-form)
-      (third fn-form)))
+        (third fn-form)))
 
-(define (sex-fn-arglist fn-form)
+  (define (sex-fn-arglist fn-form)
-  (assert (sex-fn? fn-form)
+    (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
+            (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
+    (if (sex-fn-public? fn-form)
-      (fifth fn-form)
+        (fifth fn-form)
-      (fourth fn-form)))
+        (fourth fn-form)))
 
-(define (sex-fn-prototype fn-form)
+  (define (sex-fn-prototype fn-form)
-  "Returns all except body"
+    "Returns all except body"
-  (assert (sex-fn? fn-form)
+    (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
+            (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
+    (if (sex-fn-public? fn-form)
-      (take fn-form 5)
+        (take fn-form 5)
-      (take fn-form 4)))
+        (take fn-form 4)))
 
-(define (sex-fn-body fn-form)
+  (define (sex-fn-body fn-form)
-  (assert (sex-fn? fn-form)
+    (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
+            (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
+    (if (sex-fn-public? fn-form)
-      (drop fn-form 5)
+        (drop fn-form 5)
-      (drop fn-form 4)))
+        (drop fn-form 4)))
+  )

sex-fmt-c.scm

@@ -0,0 +1,986 @@
+;;;; 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
+
+(module sex-fmt-c
+    (
+     fmt-in-macro? fmt-expression? fmt-return?
+     fmt-newline-before-brace? fmt-braceless-bodies?
+     fmt-indent-space fmt-switch-indent-space fmt-op fmt-gen
+     c-in-expr c-in-stmt c-in-test
+     c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
+     c-struct c-union c-class c-enum c-typedef c-cast
+     c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
+     c-wrap-stmt c-open-brace c-close-brace
+     c-block c-braced-block c-begin
+     c-fun c-var c-prototype c-param c-param-list
+     c-while c-for c-if c-switch
+     c-case c-case/fallthrough c-default
+     c-break c-continue c-return c-goto c-label
+     c-static c-const c-extern c-volatile c-auto c-restrict c-inline
+     c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= ;  |c\||  |c\|\||
+     c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= ;++c --c ;  |c\|=|
+     c++/post c--/post c. c->
+     c-bit-or c-or c-bit-or=
+     cpp-if cpp-ifdef cpp-ifndef cpp-elif cpp-endif cpp-else cpp-undef
+     cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line
+     cpp-error cpp-warning cpp-stringify cpp-sym-cat
+     c-comment c-block-comment c-attribute)
+
+  (import
+    scheme
+    (chicken base)
+    fmt
+    srfi-1
+    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-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 (and (c-op<= (fmt-op st) op)
+                         (not (vector? x)))
+                    (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)
+    ;; can be just pointer to SUC, need to support such case:
+    ;; struct whatever * - body is just '*'
+    (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 (and (not (null? body))
+               (not (eq? '* 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)
+                    "")
+                (if (not (null? body))
+                    (cat body)
+                    ""))))))
+
+  (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
+     (if (null? body)
+         (cat "while (" (c-in-test (c-expr check)) ");")
+         (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-param-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 'int name) st)))
+       (else
+        (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
+
+  (define (c-param-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))))
+          (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
+       ((not type)
+        (lambda (st) ((c-type '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)) "--")))

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

@@ -51,7 +51,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
      ;; Keywords
      (list (concat "("
                    (regexp-opt '(
+                                 "begin"
                                  "case"
+                                 "default"
                                  "do"
                                  "if"
                                  "for"
@@ -83,6 +85,8 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
 (put 'union 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
 (put 'import 'lisp-indent-function 1)
+(put 'switch 'lisp-indent-function 1)
+(put 'case '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,63 +0,0 @@
-(declare (unit sex-reader))
-
-(include "utils.macros.scm")
-
-(import
-  (chicken base)
-  (chicken io)
-  (chicken pathname)
-  (chicken port)
-  (chicken read-syntax)
-  (chicken string)
-  (chicken syntax)
-  brev-separate
-  fmt)
-
-(define (read-forms acc)
-  (let ((r (read-with-source-info (current-input-port))))
-    (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-bracket port)
-  (let loop ((c (read-char port))
-             (str (string)))
-    (cond ((char=? c #\])
-           (cons '¤
-                 (with-input-from-string str
-                   (fn (port-map identity read)))))
-          ((char=? c #\[)
-           (loop port (conc )))
-          (else
-           (loop (read-char port)
-                 (conc str c))))))
-
-(define open-bracket-counter (make-parameter 0))
-
-(define (read-raw-forms input-source)
-  (let ((bracket-end (gensym)))
-   (set-read-syntax!
-    #\]
-    (lambda (port)
-      (when (= 0 (open-bracket-counter))
-        (error "Unmatched closing bracket"))
-      (open-bracket-counter (- (open-bracket-counter) 1))
-      bracket-end))
-
-   (set-read-syntax!
-    #\[
-    (lambda (port)
-      (open-bracket-counter (+ (open-bracket-counter) 1))
-      (let loop ((r (read port))
-                 (acc (list)))
-        (if (eq? r bracket-end)
-            (cons '¤ (reverse acc))
-            (loop (read port)
-                  (cons r acc)))))))
-  (if (eq? input-source 'stdin)
-      (read-forms (list))
-      (read-from-file input-source)))

sexc.scm

@@ -1,166 +1,167 @@
-(declare (unit sexc)
+(module sexc (main)
-         (uses fmt-c-writer
+  (import scheme
-               sex-reader
+          brev-separate
-               utils
+          (chicken base)
-               semen))
+          (chicken file)
-
+          (chicken plist)
-(include "utils.macros.scm")
+          (chicken pretty-print)
-
+          (chicken process)
-(import brev-separate
+          (chicken process-context)
-        (chicken file)
+          (chicken port)
-        (chicken plist)
+          fmt
-        (chicken pretty-print)
+          fmt-c-writer
-        (chicken process)
+          getopt-long
-        (chicken process-context)
+          macros
-        (chicken port)
+          module-system
-        fmt
+          reader
-        getopt-long
+          semen
-        srfi-1                          ; list routines
+          srfi-1                          ; list routines
-        srfi-13
+          srfi-13
-        tree)
+          tree
+          utils)
 
 ;;; Main function facilities
 
-(define opts-grammar
+  (define opts-grammar
-  (let ((padding 26))
+    (let ((padding 26))
-    `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl
+      `((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")
+                          (pad padding) "environment variable, or if it is empty, to cc")
-                  (required #f)
+                    (required #f)
-                  (value #t))
+                    (value #t))
-      (compile-object "Compile object file instead of executable program"
+        (compile-object "Compile object file instead of executable program"
+                        (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"
                       (required #f)
                       (value #f)
-                      (single-char #\c))
+                      (single-char #\m))
-      (emit-c "Emit C code"
+        (output ,(fmt #f "Write output to file. Default file name is a.out." nl
-                  (required #f)
+                      (pad padding) "If -E or -m options are provided, defaults to stdout")
-                  (value #f)
+                (required #f)
-                  (single-char #\C))
+                (value #t)
-      (public-interface "Get module's public interface"
+                (single-char #\o)))))
-                        (required #f)
-                        (value #f))
-      (help "Show this help"
-            (required #f)
-            (value #f)
-            (single-char #\h))
-      (macro-expand "Emit macro-expanded semantically processed 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)
+  (define (print-help)
-  (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
+    (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
-  (fmt #t "Options:\n")
+    (fmt #t "Options:\n")
-  (fmt #t (usage opts-grammar))
+    (fmt #t (usage opts-grammar))
-  (fmt #t ""))
+    (fmt #t ""))
 
-(define (help-arg? args)
+  (define (help-arg? args)
-  (assoc 'help args))
+    (assoc 'help args))
 
-(define (get-arg args arg-name default)
+  (define (get-arg args arg-name default)
-  (let ((arg (assoc arg-name args)))
+    (let ((arg (assoc arg-name args)))
-    (if arg (cdr arg)
+      (if arg (cdr arg)
-        default)))
+          default)))
 
-(define (get-rest-args args)
+  (define (get-rest-args args)
-  (cdr (assoc '@ args)))
+    (cdr (assoc '@ args)))
 
-(define (get-c-compiler-args args)
+  (define (get-c-compiler-args args)
-  (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
+    (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
 
-(define (get-input-file args)
+  (define (get-input-file args)
-  (let ((rest-args (get-rest-args args)))
+    (let ((rest-args (get-rest-args args)))
-    (if (null? rest-args)
+      (if (null? rest-args)
-        'stdin
+          'stdin
-        (car rest-args))))
+          (car rest-args))))
 
-(define (write-to-file-or-stdout output what)
+  (define (write-to-file-or-stdout output what)
-  (if (eq? output 'default)
+    (if (eq? output 'default)
-      (what)
+        (what)
-      (with-output-to-file output
+        (with-output-to-file output
-        (fn (what)))))
+          (fn (what)))))
 
-(define (emit-c-or-sex sex-forms output args)
+  (define (emit-c-or-sex sex-forms output args)
-  (write-to-file-or-stdout output
+    (write-to-file-or-stdout output
-   (lambda ()
+                             (lambda ()
-    (if (get-arg args 'macro-expand #f)
+                               (if (get-arg args 'macro-expand #f)
-        (map pp sex-forms)
+                                   (map pp sex-forms)
-        (emit-c sex-forms)))))
+                                   (emit-c sex-forms)))))
 
-(define (compile-to-file sex-forms output args)
+  (define (compile-to-file sex-forms output args)
-  (let ((compiler (or (get-arg args 'c-compiler #f)
+    (let ((compiler (or (get-arg args 'c-compiler #f)
-                      (get-env-var "SEX_CC")
+                        (get-env-var "SEX_CC")
-                      "cc"))
+                        "cc"))
-        (out-file (if (eq? output 'default)
+          (out-file (if (eq? output 'default)
-                      "a.out"
+                        "a.out"
-                      output)))
+                        output)))
-    (call-with-values
+      (call-with-values
-        (lambda ()
+          (lambda ()
-          (process compiler (append (list "-o" out-file "-x" "c")
+            (process compiler (append (list "-o" out-file "-x" "c")
-                                    (if (get-arg args 'compile-object #f)
+                                      (if (get-arg args 'compile-object #f)
-                                        (list "-c")
+                                          (list "-c")
-                                        (list))
+                                          (list))
-                                    (list "-")  ; read stdin
+                                      (list "-")  ; read stdin
-                                    (get-c-compiler-args args))))
+                                      (get-c-compiler-args args))))
-      (lambda (out-port in-port pid)
+        (lambda (out-port in-port pid)
-        (with-output-to-port in-port
+          (with-output-to-port in-port
-          (lambda () (emit-c sex-forms)))
+            (lambda () (emit-c sex-forms)))
-        (close-output-port in-port)
+          (close-output-port in-port)
-        (process-wait pid)))))
+          (process-wait pid)))))
 
-(define (semantic-process-forms raw-forms input-source)
+  (define (semantic-process-forms raw-forms input-source)
-  (if (eq? input-source 'stdin)
+    (if (eq? input-source 'stdin)
-      (semen-process raw-forms)
+        (semen-process raw-forms)
-      (with-directory input-source
+        (with-directory input-source
-        (semen-process raw-forms))))
+                        (semen-process raw-forms))))
 
-(define prelude
+  (define prelude
-  '((include inttypes.h)
+    '((include inttypes.h)
 
-    (typedef u8 uint8-t)
+      (typedef u8 uint8-t)
-    (typedef i8 int8-t)
+      (typedef i8 int8-t)
-    (typedef u16 uint16-t)
+      (typedef u16 uint16-t)
-    (typedef i16 int16-t)
+      (typedef i16 int16-t)
-    (typedef u32 uint32-t)
+      (typedef u32 uint32-t)
-    (typedef i32 int32-t)
+      (typedef i32 int32-t)
-    (typedef u64 uint64-t)
+      (typedef u64 uint64-t)
-    (typedef i64 int64-t)))
+      (typedef i64 int64-t)))
 
-(define (main)
+  (define (main)
-  (let* ((raw-args (command-line-arguments))
+    (let* ((raw-args (command-line-arguments))
-         (args (getopt-long raw-args
+           (args (getopt-long raw-args
-                            opts-grammar))
+                              opts-grammar))
-         (output (get-arg args 'output 'default))
+           (output (get-arg args 'output 'default))
-         (help (help-arg? args))
+           (help (help-arg? args))
 
-         (input (get-input-file args))
+           (input (get-input-file args))
-         (current-dir (current-directory)))
+           (current-dir (current-directory)))
-    (call/cc
+      (call/cc
-     (lambda (return)
+       (lambda (return)
-       (when help
+         (when help
-         (print-help)
+           (print-help)
-         (return #f))
+           (return #f))
-       (when (get-arg args 'public-interface #f)
+         (when (get-arg args 'public-interface #f)
-         (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
+           (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
 
-         (write-to-file-or-stdout
+           (write-to-file-or-stdout
-          output
+            output
-          (fn
+            (fn
-           (map pp (reverse
+             (map pp (reverse
-                    (read-public-interface input)))))
+                      (read-public-interface input)))))
-         (return #f))
+           (return #f))
-       (load-persistent-module-paths)
+         (load-persistent-module-paths)
 
-       (sex-fmt-current-file (to-absolute-pathname input))
+         (sex-fmt-current-file (to-absolute-pathname input))
-       (let* ((raw-forms (append prelude (read-raw-forms input)))
+         (let* ((raw-forms (append prelude (read-raw-forms input)))
-              (sex-forms (semantic-process-forms raw-forms input)))
+                (sex-forms (semantic-process-forms raw-forms input)))
-         (if (or (get-arg args 'macro-expand #f)
+           (if (or (get-arg args 'macro-expand #f)
-                 (get-arg args 'emit-c #f))
+                   (get-arg args 'emit-c #f))
-             ;; Emit processed and macro-expanded sex code, or emit C code
+               ;; Emit processed and macro-expanded sex code, or emit C code
-             (emit-c-or-sex sex-forms output args)
+               (emit-c-or-sex sex-forms output args)
-             ;; Compile file!
+               ;; Compile file!
-             (compile-to-file sex-forms output args)))))))
+               (compile-to-file sex-forms output args))))))))

tools/sextest/README.org

@@ -0,0 +1,34 @@
+* Sextest
+
+A tool for testing sex compilator by using test programs.
+The tools compiles them using the compiler, then runs with provided
+input, then checks that the output and return code matches the test
+specification.
+
+* Test format
+The test program consists of two sections: prelude and the test
+program itself. Prelude contains four sections: compilation
+parameters, such as flags to compiler; string to be
+passed to program's stdin; output to match against
+program's stdout; return code to match against what
+program returns.
+All sections start with respective name: :compilation, :stdout,
+:stdin, :return.
+Section names must be present, but all can be empty. Return code
+defaults to 0 in such case.
+
+* Example
+some-test.sex:
+#+begin_src
+; :compilation
+; :stdin
+; :stdout Hello world!
+; :return
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "Hello World!")
+  (printf "Hello, %s!\n" name)
+  (return 0))
+#+end_src

tools/sextest/sextest.sex

@@ -0,0 +1,73 @@
+(include stdio.h)
+(include unistd.h)
+(include string.h)
+
+(var COMP (* const char) ":compilation")
+(var STDIN (* const char) ":stdin")
+(var STDOUT (* const char) ":stdout")
+(var RET (* const char) ":return")
+
+(var test-file-path (* const char) NULL)
+
+(var prelude-comp [const char 1024])
+(var prelude-stdin [const char 1024])
+(var prelude-stdout [const char 1024])
+(var prelude-ret [const char 1024])
+
+(fn print-usage () void
+  (printf "Usage: sextest ./path/to/test-file.sex\n"))
+
+(fn read-file ((file-path (* const char))) void
+  (var f (* FILE) (fopen file-path "r"))
+  (if (== f NULL)
+      (begin
+       (printf "Failed to read file %s\n" file-path)
+       (return)))
+  ;; should be more than enough
+  (var buffer [const char 1024])
+  (var i int 0)
+
+  (var c char)
+
+  (var section (* const char))
+  (while (!= EOF (= c (getc f)))
+    (switch c
+      (case (#\space #\newline #\tab #\return)
+        (= [buffer i] #\null)
+
+        (if (!= NULL section)
+            (begin
+             (memcpy i section buffer)))
+
+
+        (if (== 0 (strncmp buffer COMP 8ul)))
+        (= i 0))
+      (default
+       (if (== i (sizeof buffer))
+           (printf "Blast! The section is longer than %d, not going to work with this" (++/post i)))
+
+       (if (< i (sizeof buffer))
+           (= [buffer (++/post i)] c))))))
+
+(fn get-section ((section-name (* const char))) (* const char)
+  ;; Get section from test file by name.
+  ;; Name must be one of: :compilation, :stdin, :stdout, :return
+  (if (== 0 (strncmp section-name COMP 8ul))
+      (return prelude-comp))
+  (if (== 0 (strncmp section-name STDIN 6ul))
+      (return prelude-stdin))
+  (if (== 0 (strncmp section-name STDOUT 7ul))
+      (return prelude-stdout))
+  (if (== 0 (strncmp section-name RET 7ul))
+      (return prelude-ret))
+  (printf "Expected section name, got %s\n" section-name)
+  (return NULL))
+
+(pub fn main ((argc int) (argv [* const char])) int
+  (if (!= argc 2)
+      (begin
+       (print-usage)
+       (return 1)))
+  (var test-file-path (* const char) [argv 1])
+  (read-file test-file-path)
+  (return 0))

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,52 +1,77 @@
-(declare (unit utils))
+(module utils
+    (get-env-var
+     set-working-directory
+     to-absolute-pathname
+     list-split
+     list-join
+     recons
+     with-directory
+     )
 
-(include "utils.macros.scm")
+  (import
+    scheme
+    (chicken base)
+    (chicken pathname)
+    (chicken process-context)
+    srfi-1)
 
-(import
+  (define-syntax prog1
-  (chicken pathname)
+    (syntax-rules ()
-  (chicken process-context)
+      ((prog1 form . forms)
-  srfi-1)
+       (let ((res form))
+         (begin . forms)
+         res))))
 
-(define (get-env-var name)
+  (define-syntax with-directory
-  (get-environment-variable name))
+    (syntax-rules ()
+      ((with-directory path form . forms)
+       (let ((current-dir (current-directory)))
+         (set-working-directory path)
+         (prog1
+          (begin form . forms)
+          (change-directory current-dir))))))
 
-(define (set-working-directory file)
+  (define (get-env-var name)
-  (change-directory
+    (get-environment-variable name))
-   (normalize-pathname
+
-    (if (absolute-pathname? file)
+  (define (set-working-directory file)
-        (pathname-directory file)
+    (change-directory
+     (normalize-pathname
+      (if (absolute-pathname? file)
+          (pathname-directory file)
+          (make-absolute-pathname
+           (current-directory)
+           (pathname-directory file))))))
+
+  (define (to-absolute-pathname pathname)
+    (if (absolute-pathname? pathname)
+        pathname
         (make-absolute-pathname
          (current-directory)
-         (pathname-directory file))))))
+         pathname)))
 
-(define (to-absolute-pathname pathname)
+  (define (list-split src-list split-elt)
-  (if (absolute-pathname? pathname)
+    ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
-      pathname
+    (fold (lambda (elt acc)
-      (make-absolute-pathname
+            (if (eq? elt split-elt)
-       (current-directory)
+                (append acc (list (list)))
-       pathname)))
+                (append (drop-right acc 1)
+                        (list (append (last acc) (list elt))))))
+          (list (list))
+          src-list))
 
-(define (list-split src-list split-elt)
+  (define (list-join lists join-by)
-  ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
+    (drop-right
-  (fold (lambda (elt acc)
+     (fold (lambda (elt acc)
-          (if (eq? elt split-elt)
+             (append acc (list elt) (list join-by)))
-              (append acc (list (list)))
+           (list)
-              (append (drop-right acc 1)
+           lists)
-                      (list (append (last acc) (list elt))))))
+     1))
-        (list (list))
-        src-list))
-
-(define (list-join lists join-by)
-  (drop-right
-   (fold (lambda (elt acc)
-           (append acc (list elt) (list join-by)))
-         (list)
-         lists)
-   1))
 
 ;;; Reconstruct form
-(define (recons old-cons new-car new-cdr)
+  (define (recons old-cons new-car new-cdr)
-  (if (and (eq? new-car (car old-cons))
+    (if (and (eq? new-car (car old-cons))
-           (eq? new-cdr (cdr old-cons)))
+             (eq? new-cdr (cdr old-cons)))
-      old-cons
+        old-cons
-      (cons new-car new-cdr)))
+        (cons new-car new-cdr)))
+  )