WIP

Prior to the fix, the Sex code
`(while (!= EOF (= c (getc f))) ...)` expanded wrongly to
`while (EOF != c = getc(f)) { ...`, instead of
`while (EOF != (c = getc(f))) { ...`

.gitignore

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

Makefile

@@ -1,53 +1,60 @@
 CHICKEN_C = csc
-CSC_FLAGS += -K prefix
+CSC_FLAGS += -K prefix -static
+# What and why:
+# -emit-all-import-libraries: Emit import-libraries for all defined modules.
+#    Used to generate .import.scm files so compiler would know how to use the modules.
+#    Without it, csc fails with "cannot import from undefined module" error.
+# -module-registration: Always  generate  module registration code, even when
+#    import libraries are emitted. Enables us to import from our modules at run time.
+#    Used in macros, where we inject `(import (only sex-macros cat))' before the macro body.
+#    Without it, sexc compiles scuccessfully, but is unable to process macros, failing with
+#    "during expansion of (import ...) - cannot import from undefined module: sex-macros"
+#     error.
+# -c: Stop after compilation to object files. This one is obvious.
+
+MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
 # Order matters, since module check correctness on compilation
-MODULES = utils macros reader module-system semen sex-fmt-c fmt-c-writer sexc
+MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 OBJ = $(MODULES:%=%.o)
-IMPORTS = $(MODULES:%=%.import.scm)
-LINK = $(MODULES:%=%.link)
 
-sexc: $(OBJ) main.o
-	$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
-
-main.o: main.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ -link sexc
+sexc: $(OBJ) main.scm
+	$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
+        # otherwise csc hangs, probably because it tries to compile to sexc.o first
+	mv sexc-tmp sexc
 
 #------------------------------------------------------------------
 
-utils.o: utils.scm
-	$(CHICKEN_C) $(CSC_FLAGS) utils.scm -e -c -J -o utils.o -unit utils
+utils.o: utils.module.scm utils.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
 
-macros.o: macros.scm
-	$(CHICKEN_C) $(CSC_FLAGS) macros.scm -e -c -J -o macros.o -unit macros
+sex-macros.o: sex-macros.module.scm sex-macros.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
 
-reader.o:
-	$(CHICKEN_C) $(CSC_FLAGS) reader.scm -e -c -J -o reader.o -unit reader
+reader.o: reader.module.scm reader.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -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
+sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -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
+semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,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
+sex-fmt-c.o: sex-fmt-c.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
 
-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
+fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
 
-%.link: %.o
-%.import.scm: %.o
-%.o: %.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%)
+sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils
 
-
-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
+sex-tests:
+	$(MAKE) -C tests sex-tests
+	cp ./tests/sex-tests ./
 
 clean:
-	rm -f $(OBJ) main.o ./tests/sex-tests.o
-	rm -f $(IMPORTS)
-	rm -f $(LINK) main.link
+	rm -f $(OBJ) main.o
+	rm -f *.import.scm
+	rm -f *.link
 	rm -f sexc sex-tests

example/mini-test.sex

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

example/our-reader.sex

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

@@ -1,6 +0,0 @@
-(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.module.scm

@@ -0,0 +1,3 @@
+(module fmt-c-writer (emit-c
+                      sex-fmt-current-file)
+  "fmt-c-writer.scm")

fmt-c-writer.scm

@@ -1,285 +1,283 @@
 ;;; Sex fmt-c output writer
 
-(module fmt-c-writer (emit-c
-                      sex-fmt-current-file)
-  (import
-    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
+  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)
 
-  (define (unkebabify sym)
-    (case sym
-      ((-) sym)
-      ((--) sym)
-      ((->) sym)
-      ((-=) sym)
-      (else
-       (string->symbol
-        (string-substitute "-(?!>)" "_"
-                           (symbol->string sym) #t)))))
-
-  (define (atom-to-fmt-c atom)
-    (case atom
-      ((fn) '%fun)
-      ((prototype) '%prototype)
-      ((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)
-    (if (and (list? type)
-             (= 1 (length type)))
-        (car type)
-        type))
-
-  (define (make-field-access form)
-    (assert
-     (= 2 (length form)) "Wrong field access format")
-    (unkebabify
+(define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
      (string->symbol
-      (fmt #f (cadr form) (car form)))))
+      (string-substitute "-(?!>)" "_"
+                         (symbol->string sym) #t)))))
 
-  (define (walk-generic-toplevel form)
-    (cond ((atom? form) (atom-to-fmt-c form))
-          ((list? form) (map walk-generic-toplevel form))
-          (else (error "Malformed form " form))))
+(define (atom-to-fmt-c atom)
+  (case atom
+    ((fn) '%fun)
+    ((prototype) '%prototype)
+    ((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 (field-access-form? form)
-    (and (symbol? (car form))
-         (char=? #\. (string-ref (symbol->string (car form)) 0))))
+(define (maybe-unwrap-type type)
+  (if (and (list? type)
+           (= 1 (length type)))
+      (car type)
+      type))
 
-  (define (walk-expr form)
-    (match form
-      ((? vector?)
-       (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 (make-field-access form)
+  (assert
+   (= 2 (length form)) "Wrong field access format")
+  (unkebabify
+   (string->symbol
+    (fmt #f (cadr form) (car form)))))
 
-  (define (walk-var form)
-    ;; (var a int) -> (%var int a)
-    ;; (var a (const int) 32) -> (%var (const int) a 32)
-    ;; (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-generic-toplevel form)
+  (cond ((atom? form) (atom-to-fmt-c form))
+        ((list? form) (map walk-generic-toplevel form))
+        (else (error "Malformed form " form))))
 
-  (define (walk-type form)
-    ;; int -> int
-    ;; (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 (field-access-form? form)
+  (and (symbol? (car form))
+       (char=? #\. (string-ref (symbol->string (car form)) 0))))
 
-      ;; Special case: nested structs/unions
-      ((or ('struct . _)
-           ('union . _)) (walk-struct form))
+(define (walk-expr form)
+  (match form
+    ((? vector?)
+     (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))))
 
-      (('enum . _) (walk-enum form))
-      (else
-       (type-convert-to-c form))))
+(define (walk-var form)
+  ;; (var a int) -> (%var int a)
+  ;; (var a (const int) 32) -> (%var (const int) a 32)
+  ;; (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 (type-convert-to-c type)
-    ;; 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-type form)
+  ;; int -> int
+  ;; (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-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)))))
+    ;; Special case: nested structs/unions
+    ((or ('struct . _)
+         ('union . _)) (walk-struct form))
+
+    (('enum . _) (walk-enum form))
+    (else
+     (type-convert-to-c form))))
+
+(define (type-convert-to-c type)
+  ;; 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)
-    (case (car form)
-      ((¤ * const volatile struct union) #t)
-      (else #f)))
+(define (is-probably-type form)
+  (case (car form)
+    ((¤ * const volatile struct union) #t)
+    (else #f)))
 
-  (define (walk-arglist form)
-    ;; E.g.:
-    ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
-    ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
-    (map (fn
-          (match x
-            (('¤ . _) (walk-type x))
+(define (walk-arglist form)
+  ;; E.g.:
+  ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
+  ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
+  (map (fn
+        (match x
+          (('¤ . _) (walk-type x))
 
-            ;; 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
-            ;; :(
-            ((? is-probably-type) (walk-type x))
+          ;; 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
+          ;; :(
+          ((? is-probably-type) (walk-type x))
 
-            ;; 1 element args are always type
-            ((_) (walk-type x))
+          ;; 1 element args are always type
+          ((_) (walk-type x))
 
-            ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
-                                  (list (walk-type var))))))
-         form))
+          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
+                                (list (walk-type var))))))
+       form))
 
-  (define (walk-function form)
-    ;; (fn ret-type name arglist body) -> normal function
-    ;; (fn ret-type name arglist) -> prototype
-    (if (>= (length form) 5)
-        (walk-fn-def form)
-        (cons '%prototype (cdr (walk-fn-def form)))))
+(define (walk-function form)
+  ;; (fn ret-type name arglist body) -> normal function
+  ;; (fn ret-type name arglist) -> prototype
+  (if (>= (length form) 5)
+      (walk-fn-def form)
+      (cons '%prototype (cdr (walk-fn-def form)))))
 
-  (define (process-struct-fields fields)
-    (map (fn
-          (let ((type (walk-type (last x))))
-            (cons type (map atom-to-fmt-c (drop-right x 1)))))
-         fields))
+(define (process-struct-fields fields)
+  (map (fn
+        (let ((type (walk-type (last x))))
+          (cons type (map atom-to-fmt-c (drop-right x 1)))))
+       fields))
 
-  (define (walk-struct form)
-    (match form
-      ((type (fields ...) . attrs)        ; anonymous struct
-       `(,type ,(process-struct-fields fields)
-               . ,(tree-map atom-to-fmt-c attrs)))
-      ((type name)                        ; simple 'struct whatever', like in variable def
-       `(,type ,(atom-to-fmt-c name)))
-      ((type name (fields ...) . attrs)
-       `(,type ,(atom-to-fmt-c name)
-               ,(process-struct-fields fields)
-               . ,(tree-map atom-to-fmt-c attrs)))
-      (else (error "Malformed aggregate definition " form))))
+(define (walk-struct form)
+  (match form
+    ((type (fields ...) . attrs)        ; anonymous struct
+     `(,type ,(process-struct-fields fields)
+             . ,(tree-map atom-to-fmt-c attrs)))
+    ((type name)                        ; simple 'struct whatever', like in variable def
+     `(,type ,(atom-to-fmt-c name)))
+    ((type name (fields ...) . attrs)
+     `(,type ,(atom-to-fmt-c name)
+             ,(process-struct-fields fields)
+             . ,(tree-map atom-to-fmt-c attrs)))
+    (else (error "Malformed aggregate definition " form))))
 
-  (define (walk-enum form)
-    (match form
-      (('enum (values ...))
-       `(enum ,(map atom-to-fmt-c values)))
-      (('enum name (values ...))
-       `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
+(define (walk-enum form)
+  (match form
+    (('enum (values ...))
+     `(enum ,(map atom-to-fmt-c values)))
+    (('enum name (values ...))
+     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
 
-  (define (walk-extern form)
-    (match form
-      (('fn . _)
-       ;; extern function?.. What
-       (list 'extern (walk-function form)))
-      (('var . _)
-       (list 'extern (walk-var form)))
-      (else (error "Extern what?"))))
+(define (walk-extern form)
+  (match form
+    (('fn . _)
+     ;; extern function?.. What
+     (list 'extern (walk-function form)))
+    (('var . _)
+     (list 'extern (walk-var form)))
+    (else (error "Extern what?"))))
 
-  (define (walk-public form)
-    (match form
-      (('fn . _)
-       (walk-function form))
-      (('var . _)
-       (walk-var form))
-      ((or ('define . _)
-           ('defmacro . _)
+(define (walk-public form)
+  (match form
+    (('fn . _)
+     (walk-function form))
+    (('var . _)
+     (walk-var form))
+    ((or ('define . _)
+         ('defmacro . _)
 
-           ('import . _)
-           ('include . _)
+         ('import . _)
+         ('include . _)
 
-           ('struct . _)
-           ('union . _)
+         ('struct . _)
+         ('union . _)
 
-           ('typedef . _))
-       ;; ignore here, used in generating public interface
-       (process-toplevel-form form))
-      (else
-       (error "Pub what?" (cadr form)))))
+         ('typedef . _))
+     ;; ignore here, used in generating public interface
+     (process-toplevel-form form))
+    (else
+     (error "Pub what?" (cadr form)))))
 
-  (define (process-toplevel-form form)
-    (match form
-      (('fn . _) (list 'static (walk-function form)))
-      (('var . _) (list 'static (walk-var form)))
-      (('extern . rest) (walk-extern rest))
-      (('pub . rest) (walk-public rest))
-      ((or ('struct . _)
-           ('union . _)) (walk-struct form))
-      (('enum . _) (walk-enum form))
-      (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
-      (else (walk-expr form))))
+(define (process-toplevel-form form)
+  (match form
+    (('fn . _) (list 'static (walk-function form)))
+    (('var . _) (list 'static (walk-var form)))
+    (('extern . rest) (walk-extern rest))
+    (('pub . rest) (walk-public rest))
+    ((or ('struct . _)
+         ('union . _)) (walk-struct form))
+    (('enum . _) (walk-enum form))
+    (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
+    (else (walk-expr form))))
 
-  (define (get-line-num form)
-    (let ((num (get-line-number form)))
-      (if (string? num)
-          (last (string-split num ":"))
-          #f)))
+(define (get-line-num form)
+  (let ((num (get-line-number form)))
+    (if (string? num)
+        (last (string-split num ":"))
+        #f)))
 
-  (define sex-fmt-current-file (make-parameter "/dev/null"))
-  (define sex-fmt-line-num (make-parameter 0))
+(define sex-fmt-current-file (make-parameter "/dev/null"))
+(define sex-fmt-line-num (make-parameter 0))
 
-  (define (line-directive-string)
-    (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
+(define (line-directive-string)
+  (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
 
-  (define (emit-c sex-forms)
-    (for-each (lambda (form)
-                (let ((start-line (get-line-num form)))
-                  (when start-line
-                    (sex-fmt-line-num start-line)
-                    (fmt #t (line-directive-string) nl)))
-                (fmt #t (c-expr (process-toplevel-form form)) nl))
-              sex-forms)))
+(define (emit-c sex-forms)
+  (for-each (lambda (form)
+              (let ((start-line (get-line-num form)))
+                (when start-line
+                  (sex-fmt-line-num start-line)
+                  (fmt #t (line-directive-string) nl)))
+              (fmt #t (c-expr (process-toplevel-form form)) nl))
+            sex-forms))

macros.scm

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

module-system.scm

@@ -1,92 +0,0 @@
-(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.module.scm

@@ -0,0 +1,3 @@
+(module reader (read-from-file
+                read-raw-forms)
+  "reader.scm")

reader.scm

@@ -1,64 +1,49 @@
-(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
+  scheme
+  (chicken base)
+  (chicken io)
+  (chicken pathname)
+  (chicken port)
+  (chicken read-syntax)
+  (chicken string)
+  (chicken syntax)
+  brev-separate
+  fmt)
 
-  (import-syntax utils)
+(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-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-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 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))
 
-  (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))))
+    (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.module.scm

@@ -0,0 +1,2 @@
+(module semen ()
+  "semen.scm")

semen.scm

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

sex-fmt-c.scm

@@ -105,7 +105,6 @@
 
   (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) ")"))
 

sex-macros.module.scm

@@ -0,0 +1,8 @@
+(module sex-macros
+    (register-macro
+     cat
+     get-macro
+     macro?
+     apply-macro
+     defmacro)
+  "sex-macros.scm")

sex-macros.scm

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

sex-modules.module.scm

@@ -0,0 +1,5 @@
+(module sex-modules
+    (get-modules-public-forms
+     load-persistent-module-paths
+     read-public-interface)
+  "sex-modules.scm")

sex-modules.scm

@@ -0,0 +1,87 @@
+(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 ":"))))))

sexc.module.scm

@@ -0,0 +1 @@
+(module sexc (main) "sexc.scm")

sexc.scm

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

tests/Makefile

@@ -1 +1,45 @@
+CHICKEN_C = csc
 
+CSC_FLAGS += -K prefix -static
+MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
+
+MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+SEX_OBJ = $(MODULES:%=%.o)
+
+TESTS = basic semen reader fmt-c-writer utils
+TEST_SRCS = $(TESTS:%=%.scm)
+
+sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
+	$(CHICKEN_C) $(CSC_FLAGS) run.scm -o sex-tests -link sexc
+
+#------------------------------------------------------------------
+
+utils.o: utils.module.scm ../utils.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
+
+sex-macros.o: sex-macros.module.scm ../sex-macros.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
+
+reader.o: reader.module.scm ../reader.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader
+
+sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
+
+semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils
+
+sex-fmt-c.o: ../sex-fmt-c.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
+
+fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
+
+sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils
+
+clean:
+	rm -f $(OBJ)
+	rm -f *.import.scm
+	rm -f *.link
+	rm -f sex-tests

tests/basic.scm

@@ -1,3 +1,5 @@
+(import fmt-c-writer)
+
 (test-group "basic"
 
   ;; unkebabify

tests/fmt-c-writer.module.scm

@@ -0,0 +1,3 @@
+(module fmt-c-writer
+    *
+  "../fmt-c-writer.scm")

tests/reader.module.scm

@@ -0,0 +1,3 @@
+(module reader
+    *
+  "../reader.scm")

tests/reader.scm

@@ -1,4 +1,5 @@
-(import (chicken port))
+(import (chicken port)
+        reader)
 
 (define-syntax reader-test
   (syntax-rules ()

tests/run.scm

@@ -1,10 +1,4 @@
-(declare (uses fmt-c-writer
-               semen))
-
 (import
-  (chicken process)
-  (chicken process-context)
-  srfi-1
   test)
 
 (include "basic.scm")

tests/semen.module.scm

@@ -0,0 +1,2 @@
+(module semen *
+  "../semen.scm")

tests/semen.scm

@@ -1,4 +1,5 @@
-(import srfi-69)
+(import srfi-69
+        semen)
 
 (define print-str-fn
   '(fn void print-str ((string s))
@@ -38,11 +39,11 @@
   (define (form-identity form env)
     form)
 
-  (test 'a (semen-walk-form 'a form-identity (make-hash-table)))
-  (test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table)))
+  (test 'a (walk-form 'a form-identity (make-hash-table)))
+  (test '(a b c) (walk-form '(a b c) form-identity (make-hash-table)))
 
-  (test 'a (semen-macro-expand 'a))
-  (test '(a b c) (semen-macro-expand '(a b c)))
+  (test 'a (macro-expand 'a))
+  (test '(a b c) (macro-expand '(a b c)))
 
   (let ((sex-code-macro
          '((defmacro (x10 a)

tests/sex-macros.module.scm

@@ -0,0 +1,3 @@
+(module sex-macros
+    *
+  "../sex-macros.scm")

tests/sex-modules.module.scm

@@ -0,0 +1,3 @@
+(module sex-modules
+    *
+  "../sex-modules.scm")

tests/sexc.module.scm

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

tests/utils.module.scm

@@ -0,0 +1,3 @@
+(module utils
+    *
+  "../utils.scm")

tests/utils.scm

@@ -1,3 +1,5 @@
+(import utils)
+
 (test-group "utils"
 
   (test

tools/sextest/Makefile

@@ -0,0 +1,5 @@
+CHICKEN_C = csc
+CSC_FLAGS += -K prefix -static
+
+sextest: sextest.scm
+	$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest

tools/sextest/README.org

@@ -1,34 +1,26 @@
 * 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.
+A tool for testing Sex compiler by using test programs.
+The tools compiles test programs, then runs with provided
+input, checking the output and return code.
 
 * 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.
+The test program is just a regular Sex program, which may contain
+additional toplevel forms, to define compilation parameters, input to
+the program, and expected output and return code. Default value for
+compilation, input and output is an empty strings. For the return code
+it is 0.
 
 * Example
 some-test.sex:
 #+begin_src
-; :compilation
-; :stdin
-; :stdout Hello world!
-; :return
+(compilation "-- -O2")
+(input "")
+(output "Hello world!")
+(return 123)
 
 (include stdio.h)
 
 (pub fn main () int
   (puts "Hello World!")
-  (printf "Hello, %s!\n" name)
-  (return 0))
+  (return 123))
 #+end_src

tools/sextest/hello-sextest.sex

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

tools/sextest/sextest.scm

@@ -0,0 +1,154 @@
+(import scheme
+        brev-separate
+        (chicken base)
+        (chicken file)
+        (chicken io)
+        (chicken pathname)
+        (chicken port)
+        (chicken process)
+        (chicken process-context)
+        (chicken read-syntax)
+        (chicken syntax)
+        fmt
+        srfi-1)
+
+(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))))))
+
+(define (set-working-directory file)
+  (change-directory
+   (normalize-pathname
+    (if (absolute-pathname? file)
+        (pathname-directory file)
+        (make-absolute-pathname
+         (current-directory)
+         (pathname-directory file))))))
+
+;;; TODO: use sexc reader code i.e. link with sex reader
+(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)))))))
+  (read-from-file input-source))
+
+(define (read-from-file file)
+  (with-directory file
+    (with-input-from-file (pathname-strip-directory file)
+      (fn (read-forms (list))))))
+
+(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 (print-help)
+  (fmt #t "Usage: sextest ./path/to/test-file.sex\n"))
+
+(define (process-file target-path)
+  (let ((contents (read-raw-forms target-path)))
+    (foldl (lambda (acc elt)
+             (case (car elt)
+               ((compilation input output return)
+                (cons
+                 (append (car acc) (list elt))
+                 (cdr acc)))
+               (else
+                (cons
+                 (car acc)
+                 (append (cdr acc) (list elt))))))
+           (cons (list) (list))
+           contents)))
+
+(define (compile src flags)
+  (let ((compiler (or (get-environment-variable "SEXC")
+                      ;; TODO: pass compiler in args
+                      ;; (get-arg args 'sex-compiler #f)
+                      "sexc"))
+        (compiled-file (create-temporary-file)))
+    (call-with-values
+        (fn
+          (process compiler
+                   (append (list "-o" compiled-file)
+                           flags)))
+      (lambda (out-port in-port pid)
+        (with-output-to-port in-port
+          (fn (map print src)))
+        (close-output-port in-port)
+        (call-with-values
+            (fn (process-wait pid))
+          (lambda (pid exited retcode)
+            (if (= 0 retcode)
+                compiled-file
+                #f)))))))
+
+(define (run-and-check file in out ret)
+  (call-with-values
+      (fn (process file))
+    (lambda (out-port in-port pid)
+      (when in
+        (with-output-to-port in-port
+          (fn (map print (cdr in))))
+        (close-output-port in-port))
+      (with-input-from-port out-port
+        (fn
+         (let loop ((line (read-line))
+                    (lines (list)))
+           (if (eof-object? line)
+               (reverse lines)
+               (loop (read-line)
+                     (cons line lines))))))
+      (call-with-values
+          (fn (process-wait pid))
+        (lambda (pid exited retcode)
+          (fmt #t "Ret code: " retcode nl))))))
+
+(define (main)
+  (let ((args (command-line-arguments)))
+    (if (not (= 1 (length args)))
+        (print-help)
+        (let ((settings-and-src
+               (process-file (first args))))
+          (let ((settings (car settings-and-src))
+                (src (cdr settings-and-src)))
+            (let ((compiled-file (compile src (assoc 'compile settings))))
+              (unless compiled-file
+                (fmt #t "Compilation failed." nl)
+                (exit 1))
+              (run-and-check
+               compiled-file
+               (assoc 'input settings)
+               (assoc 'output settings)
+               (assoc 'return settings))))))))
+
+(main)

tools/sextest/sextest.sex

@@ -1,73 +0,0 @@
-(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.module.scm

@@ -0,0 +1,10 @@
+(module utils
+    (get-env-var
+     set-working-directory
+     to-absolute-pathname
+     list-split
+     list-join
+     recons
+     with-directory
+     )
+  "utils.scm")

utils.scm

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