add support for nested lambdas

No closures for now, but solid groundwork is laid.

.gitignore

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

Makefile

@@ -1,20 +1,21 @@
 CHICKEN_C = csc
+CSC_FLAGS = -K prefix
 
-MODULES = sexc sex-macros sex-modules utils fmt-c
+MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
 OBJ = $(MODULES:%=%.o)
 
 sexc: main.o $(OBJ)
-	$(CHICKEN_C) $^ -o $@
+	$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
 
 main.o: main.scm
-	$(CHICKEN_C) $< -c -o $@
+	$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@
 
 %.o: %.scm
-	$(CHICKEN_C) $< -e -c -o $@
+	$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@
 
 sex-tests: $(OBJ) tests/*.scm
-	cd ./tests && $(CHICKEN_C) run.scm -c -o sex-tests.o
+	cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o
-	$(CHICKEN_C) $(OBJ) ./tests/sex-tests.o -o sex-tests
+	$(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

Readme.org

@@ -1,6 +1,7 @@
 * The Sex language
 Sex is a S-expressions language. Sex is written in Chicken, which is a
 [[https://call-cc.org][R5RS Scheme]].
+Sex is statically typed, compiled general purpose language.
 
 * Compilation
 First, get yourself a Chicken, then, some Chicken deps. You also will
@@ -12,7 +13,7 @@ to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
 environment variables. Refer to the documentation for more info:
 https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
 
-~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13~
+~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable~
 
 ** Compilation
 ~make~
@@ -25,10 +26,11 @@ Options:
  --c-compiler=ARG         Select C compiler. Defaults to value of SEX_CC
                           environment variable, or if it is empty, to cc
  -c, --compile-object     Compile object file instead of executable program
- -E, --preprocess         Emit C code
+ -C, --preprocess         Emit C code
  --public-interface       Get module's public interface
  -h, --help               Show this help
- -m, --macro-expand       Emit macro-expanded Sex code
+ -m, --macro-expand       Emit macro-expanded semantically processed Sex code
+                          (sort of IR). May be useful for debugging
  -o, --output=ARG         Write output to file. Default file name is a.out.
                           If -E or -m options are provided, defaults to stdout
 #+end_src
@@ -71,9 +73,9 @@ Hello, Alex!
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
 have is C.
 
-** Auto unkebabification
+*** Auto kebabification
 For hardcore fans of traditional Lisp naming convention,
-Sex offers automatic unkebabification of all symbols, i.e. no more
+Sex offers automatic kebabification of all symbols, i.e. no more
 ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
@@ -114,7 +116,7 @@ return Sex code.
 **** Wrapper for checking return codes
 #+begin_src scheme
 (pub defmacro (check-sdl-return call message ret-code)
-  `((if (< 0 ,call)
+  `(if (< 0 ,call)
        (begin
          (puts ,message)
          (return ,ret-code)))))

example/fns.sex

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

example/lambdas.sex

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

example/list.sex

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

example/test-list.sex

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

fmt-c-writer.scm

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

semen.scm

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

sex-macros.scm

@@ -19,11 +19,17 @@
 (define (get-macro name)
   (eval (get name 'sex-macro)))
 
-(define (macro? form)
+(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)))

sex-modules.scm

@@ -1,7 +1,8 @@
 ; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
 ; things start to break.
 (declare (unit sex-modules)
-         (uses utils))
+         (uses sex-reader
+               utils))
 
 (import brev-separate
         (chicken file)
@@ -14,7 +15,7 @@
 
 (define +persistent-module-paths+ (list))
 
-(define (import-modules module-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
@@ -63,6 +64,7 @@
      (list)
      raw-forms)))
 
+;;; TODO: use semen facilities to analyze modules
 (define (process-public-interface-form form acc)
   (case (car form)
     ((pub)

sex-reader.scm

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

sexc.scm

@@ -1,207 +1,23 @@
 (declare (unit sexc)
-         (uses fmt-c
+         (uses fmt-c-writer
-               sex-macros
+               sex-reader
-               sex-modules))
+               semen))
 
 (include "utils.macros.scm")
 
 (import brev-separate
         (chicken file)
-        (chicken pathname)
         (chicken plist)
         (chicken pretty-print)
         (chicken process)
         (chicken process-context)
         (chicken port)
-        (chicken string)
         fmt
         getopt-long
-        regex
         srfi-1                          ; list routines
-        srfi-13                         ; string routines
+        srfi-13
         tree)
 
-(define (unkebabify sym)
-  (case sym
-    ((-) sym)
-    ((--) sym)
-    ((->) sym)
-    ((-=) sym)
-    (else
-     (string->symbol
-      (string-substitute "-(?!>)" "_"
-                         (symbol->string sym) #t)))))
-
-(define (atom-to-fmt-c atom)
-  (case atom
-    ((fn) '%fun)
-    ((prototype) '%prototype)
-    ((var) '%var)
-    ((begin) '%block-begin)
-    ((define) '%define)
-    ((pointer) '%pointer)
-    ((array) '%array)
-    ((attribute) '%attribute)
-    ((@) 'vector-ref)
-    ((include) '%include)
-    ((cast) '%cast)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
-    (else
-     (if (symbol? atom)
-         (unkebabify atom)
-         atom))))
-
-(define (make-field-access form)
-  (assert (= 2 (length form)) "Wrong field access format")
-  (unkebabify
-   (string->symbol
-    (fmt #f (cadr form) (car form)))))
-
-(require-library chicken-syntax)
-
-(define (walk-generic form acc)
-  (cond
-   ((null? form) (cons '() acc))
-
-   ;; vector, e.g. {}-initializer
-   ((vector? form)
-    (cons
-     (list->vector
-      (car (walk-sex-tree (vector->list form) (list))))
-     acc))
-
-   ;; atom (hopefully)
-   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
-
-   ;; special case - replace unquote with its expansion
-   ((eq? (car form) 'unquote)
-    (fold
-     cons
-     acc
-     (car                               ; bc walk-sex-tree always
-                                        ; wraps its result
-      (walk-sex-tree (eval (cadr form)) (list)))))
-
-   ;; another special case - field access
-   ((and (symbol? (car form))
-         (char=? #\. (string-ref (symbol->string (car form)) 0)))
-    (cons (make-field-access form) acc))
-
-   ;; another special case - macro
-   ((macro? form)
-    (append (fold-right
-             walk-generic
-             (list)
-             (apply (get-macro (car form)) (cdr form)))
-            acc))
-
-   ;; toplevel, or a start of a regular list form
-   (else
-    (let ((new-acc (list)))
-      (cons (fold-right
-             walk-generic
-             new-acc
-             form)
-            acc)))))
-
-(define (normalize-fn-form form)
-  ;; (fn ret-type name arglist body) -> normal function
-  ;; (fn ret-type name arglist) -> prototype
-  (if (>= (length form) 5)
-      form
-      (cons 'prototype (cdr form))))
-
-(define (walk-function form static acc)
-  (if static
-      (append (walk-generic (list 'static (normalize-fn-form form))
-                            (list))
-              acc)
-      (append (walk-generic (normalize-fn-form (cdr form))
-                            (list))
-              acc)))
-
-(define (walk-struct form acc)
-  (let ((name (unkebabify (cadr form))))
-    (append (walk-generic form (list))
-          (cons `(typedef struct ,name ,name) acc))))
-
-(define (walk-extern form acc)
-  (case (cadr form)
-    ((fn)
-     (append
-      (list (cons 'extern (walk-function form #f (list))))
-      acc))
-    ((var)
-     (append
-      (list (cons 'extern (walk-generic (cdr form) (list))))
-      acc))
-    (else (error "Extern what?"))))
-
-(define (walk-public form acc)
-  (case (cadr form)
-    ((fn)
-     (walk-function form #f acc))
-    ((var)
-     (append (walk-generic (list 'static (cdr form)) (list)) acc))
-    ((define defmacro import include struct typedef union var)
-     ;; ignore here, used in generating public interface
-     (process-form (cdr form) acc))
-    (else
-     (error "Pub what?" (cadr form)))))
-
-(define (walk-sex-tree form acc)
-  (if (list? form)
-      (if (macro? form)
-          (fold-right (fn (walk-sex-tree x y))
-                      acc
-                      (list (apply (get-macro (car form)) (cdr form))))
-          (case (car form)
-            ((fn) (walk-function form #t acc))
-            ((extern) (walk-extern form acc))
-            ((pub) (walk-public form acc))
-            ((struct union) (walk-struct form acc))
-            ((unquote) (fold (fn (walk-sex-tree x y))
-                             acc
-                             (eval (cadr form))))
-            (else (append (walk-generic form (list)) acc))))
-      ;; only for unquote support
-      (list (list (atom-to-fmt-c form)))))
-
-(define (process-form form acc)
-  (case (car form)
-    ((chicken-define) (eval (cons 'define (cdr form))) acc)
-    ((defmacro) (defmacro (cdr form)) acc)
-    ((chicken-load)
-     (load (cadr form)) acc)
-    ((chicken-import)
-     (eval (cons 'import (cdr form))) acc)
-    ((import)
-     (append (process-raw-forms
-
-              (import-modules (cdr form)) (list))
-             acc))
-    (else
-     (walk-sex-tree form acc))))
-
-(define (process-raw-forms raw-forms acc)
-  (if (null? raw-forms)
-      (reverse acc)
-      (process-raw-forms (cdr raw-forms)
-                         (process-form (car raw-forms) acc))))
-
-(define (read-forms acc)
-  (let ((r (read)))
-    (if (eof-object? r) (reverse acc)
-        (read-forms (cons r acc)))))
-
-(define (emit-c forms)
-  (for-each (lambda (form)
-              (fmt #t (c-expr form) nl))
-            forms))
-
 ;;; Main function facilities
 
 (define opts-grammar
@@ -214,10 +30,10 @@
                       (required #f)
                       (value #f)
                       (single-char #\c))
-      (preprocess "Emit C code"
+      (emit-c "Emit C code"
                   (required #f)
                   (value #f)
-                  (single-char #\E))
+                  (single-char #\C))
       (public-interface "Get module's public interface"
                         (required #f)
                         (value #f))
@@ -225,7 +41,7 @@
             (required #f)
             (value #f)
             (single-char #\h))
-      (macro-expand "Emit macro-expanded Sex code"
+      (macro-expand "Emit macro-expanded semantically processed Sex code"
                     (required #f)
                     (value #f)
                     (single-char #\m))
@@ -261,20 +77,14 @@
         'stdin
         (car rest-args))))
 
-(define (read-from-file file)
-  (with-directory file
-   (with-input-from-file (pathname-strip-directory file)
-     (fn (read-forms (list))))))
-
 (define (write-to-file-or-stdout output what)
   (if (eq? output 'default)
       (what)
       (with-output-to-file output
         (fn (what)))))
 
-(define (preprocess-or-macroexpand sex-forms output args)
+(define (emit-c-or-sex sex-forms output args)
-  (write-to-file-or-stdout
+  (write-to-file-or-stdout output
-   output
    (lambda ()
     (if (get-arg args 'macro-expand #f)
         (map pp sex-forms)
@@ -289,7 +99,7 @@
                       output)))
     (call-with-values
         (lambda ()
-          (process compiler (append (list "-o" out-file "-std=c89" "-pedantic" "-x" "c")
+          (process compiler (append (list "-o" out-file "-x" "c")
                                     (if (get-arg args 'compile-object #f)
                                         (list "-c")
                                         (list))
@@ -301,13 +111,11 @@
         (close-output-port in-port)
         (process-wait pid)))))
 
-(define (process-input input raw-forms)
+(define (semantic-process-forms raw-forms input-source)
-  (let ((current-dir (current-directory)))
+  (if (eq? input-source 'stdin)
-    (unless (eq? input 'stdin)
+      (semen-process raw-forms)
-      (set-working-directory input))
+      (with-directory input-source
-    (prog1
+        (semen-process raw-forms))))
-     (process-raw-forms raw-forms (list))
-     (change-directory current-dir))))
 
 (define (main)
   (let* ((raw-args (command-line-arguments))
@@ -334,14 +142,11 @@
          (return #f))
        (load-persistent-module-paths)
 
-       (let* ((raw-forms
+       (let* ((raw-forms (read-raw-forms input))
-               (if (eq? input 'stdin)
+              (sex-forms (semantic-process-forms raw-forms input)))
-                   (read-forms (list))
-                   (read-from-file input)))
-              (sex-forms (process-input input raw-forms)))
          (if (or (get-arg args 'macro-expand #f)
-                 (get-arg args 'preprocess #f))
+                 (get-arg args 'emit-c #f))
-             ;; Preprocess or macroexpand
+             ;; Emit processed and macro-expanded sex code, or emit C code
-             (preprocess-or-macroexpand sex-forms output args)
+             (emit-c-or-sex sex-forms output args)
              ;; Compile file!
              (compile-to-file sex-forms output args)))))))

tests/basic.scm

@@ -1,3 +1,5 @@
+(test-begin "basic")
+
 ;;; unkebabify
 (test '- (unkebabify '-))
 (test '-- (unkebabify '--))
@@ -29,3 +31,5 @@
 ;;; make-field-access
 (test 'a.b (make-field-access '(.b a)))
 (test 'a.b.c (make-field-access '(.c a.b)))
+
+(test-end)

tests/run.scm

@@ -1,4 +1,5 @@
-(declare (uses sexc))
+(declare (uses fmt-c-writer
+               semen))
 
 (import
   (chicken process)
@@ -7,7 +8,7 @@
   test)
 
 (include "basic.scm")
-(include "types.scm")
+(include "semen.scm")
 
 ;;; Should be the last in the test suite
 (test-exit)

tests/semen.scm

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

tests/types.scm

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

utils.macros.scm

@@ -1,3 +1,5 @@
+(import (chicken process-context))
+
 (define-syntax prog1
   (syntax-rules ()
     ((prog1 form . forms)