sex-mode inherits scheme mode

uh oh

.github/workflows/build.yaml

@@ -1,55 +0,0 @@
-name: Sex CI
-
-on:
-  push:
-    branches: [ main ]
-  pull_request:
-    branches: [ main ]
-
-jobs:
-  build-linux:
-
-    runs-on: ubuntu-latest
-
-    steps:
-    - uses: actions/checkout@v3
-    - name: Install chicken
-      run: |
-        wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
-        tar zxf chicken-6.0.0.tar.gz
-        sudo apt install -y make
-        make -C chicken-6.0.0 PLATFORM=linux
-        sudo make -C chicken-6.0.0 PLATFORM=linux install
-    - name: Install dependencies
-      # FIXME: [project-local deps]: use venv or something
-      # run: make deps
-      run: sudo chicken-install $(cat dependencies.txt)
-    - name: Make sure that sexc builds
-      # FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
-      # Without it there will be `Error: cannot load extension: fmt`.
-      run: make sexc && ./sexc --help
-    - name: Run tests
-      # FIXME: [project-local deps]: use local deps or build with -static
-      # run: make run-tests
-      run: make sex-tests && ./sex-tests
-
-  build-macos:
-
-    runs-on: macos-15
-
-    steps:
-    - uses: actions/checkout@v3
-    - name: Install chicken
-      run: brew install chicken make
-    - name: Install dependencies
-      # FIXME: [project-local deps]: use venv or something
-      # run: make deps
-      run: chicken-install $(cat dependencies.txt)
-    - name: Make sure that sexc builds
-      # FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
-      # Without it there will be `Error: cannot load extension: fmt`.
-      run: make sexc && ./sexc --help
-    - name: Run tests
-      # FIXME: [project-local deps]: use local deps or build with -static
-      # run: make run-tests
-      run: make sex-tests && ./sex-tests

.gitignore

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

Makefile

@@ -1,72 +1,19 @@
 CHICKEN_C = csc
-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 sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = sexc templates main
 OBJ = $(MODULES:%=%.o)
 
-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
+# chicken flags
+CFLAGS = -compile-syntax
 
-#------------------------------------------------------------------
+sexc: $(OBJ)
+	$(CHICKEN_C) $^ -o $@
 
-utils.o: utils.module.scm utils.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
+main.o: main.scm
+	$(CHICKEN_C) $< -c -o $@
 
-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 utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link 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.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
-
-# Unit testing
-sex-tests:
-	$(MAKE) -C ./tests sex-tests
-	cp ./tests/sex-tests ./
-
-sextest:
-	$(MAKE) -C ./tools/sextest sextest
-	cp ./tools/sextest/sextest .
-
-SEX_TEST_PROGRAMS = hello-world lists comments unicode
-
-run-tests: sexc sex-tests sextest
-	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)
+%.o: %.scm
+	$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
 
 clean:
-	rm -f $(OBJ) main.o
-	rm -f *.import.scm
-	rm -f *.link
-	rm -f sexc sex-tests sextest
-
-.PHONY: clean run-tests sex-tests sextest
+	rm -f $(OBJ) sexc

Readme.org

@@ -1,82 +1,66 @@
 * The Sex language
+Sex is a S-expressions language, which transpiles to C.
 
-#+NAME: the Sex logo
-#+ATTR_HTML: :width 300px
-[[sex.png][file:./sex.png]]
+Sex is also Chicken, since all source processing and compile-time
+computations are written in Chicken.
 
-Sex is a S-expressions language. Sex is written in Chicken, which is an
-[[https://call-cc.org][R7RS Scheme]].
-Sex is statically typed, compiled general purpose language.
+And Chicken is [[https://call-cc.org][R5RS Scheme]].
 
-* Compilation
-First, get yourself a Chicken, then, some Chicken deps. You also will
-need a C compiler.
+* Compilation and usage
+First, get yourself a Chicken. Second, some Chicken deps.
 
 ** Install Chicken Eggs
-Tip: there's a way to make Chicken install eggs non-globally. You need
-to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
-environment variables. Refer to the documentation for more info:
+By the way, there's a way to make Chicken install eggs non-globally. Refer to
+the documentation for more info:
 https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
 
-~chicken-install `cat dependencies.txt`~
+~chicken-install fmt getopt-long brev-separate~
 
 ** Compilation
 ~make~
 
-* Usage
-** Summary
+** Usage
+You'll also need a C compiler, so pick any.
 #+begin_src
-Usage: sexc [options] filename [-- options-for-c-compiler]
-Options:
- --c-compiler=ARG         Select C compiler. Defaults to value of SEX_CC
-                          environment variable, or if it is empty, to cc
- -c, --compile-object     Compile object file instead of executable program
- -C, --preprocess         Emit C code
- --public-interface       Get module's public interface
- -h, --help               Show this help
- -m, --macro-expand       Emit macro-expanded semantically processed Sex code
-                          (sort of IR). May be useful for debugging
- -o, --output=ARG         Write output to file. Default file name is a.out.
-                          If -E or -m options are provided, defaults to stdout
-#+end_src
-** Compiling Hello World
-#+begin_src shell
-sexc ./examples/hello-world.sex -o hello
+cat hello-world.sex | sexc > hello_world.c
+cc hello_world.c -o hello_world
 #+end_src
 
-That's it. Now you should have executable named ~hello~ in your
-directory. Sex uses C under the hood, the default C compiler is ~cc~,
-but you can pass any using ~--c-compiler~ option, or by setting
-~SEX_CC~ environment variable.
+* Example
+Here is an example, demonstrating what Sex source looks like, and what
+it compiles too. An avid reader also shall notice how we call Chicken
+procedures in Sex source.
 
-Everything after ~--~ is handed to the C compiler exactly as written:
-
-#+begin_src shell
-sexc example/sdl3-triangle.sex -o triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
-#+end_src
-
-** Example
-An example of Sex source:
-#+begin_src scheme
+The Sex source:
+#+begin_src
 (include stdio.h)
 
-(pub fn main ((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 0))
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(pub fn int main ((int argc) (char **argv))
+    (puts "Hello from Sex!")
+    (var (array char 512) name)
+    (puts "What is your name?")
+    (scanf "%s" &name)
+    (printf "Hello, %s!\n" name)
+    (printf ,(foo))
+    0)
 #+end_src
 
-Compile and run:
-#+begin_src shell
-~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
-~/dev/sex $ ./hello-world
-Hello from Sex!
-What is your name?
-Alex
-Hello, Alex!
+The resulting C source:
+#+begin_src
+#include <stdio.h>
+
+int main (int argc, char **argv) {
+    puts("Hello from Sex!");
+    char name[512];
+    puts("What is your name?");
+    scanf("%s", &name);
+    printf("Hello, %s!\n", name);
+    printf("Hello from Chicken code!\n");
+    return 0;
+}
 #+end_src
 
 * Features
@@ -84,76 +68,16 @@ Hello, Alex!
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
 have is C.
 
-*** Auto kebabification
 For hardcore fans of traditional Lisp naming convention,
-Sex offers automatic kebabification of all symbols, i.e. no more
+Sex offers automatic unkebabification of all symbols, i.e. no more
 ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
-** Modules
-Each source file is a module. Module can provide public interface and
-be imported by using ~(import path/to/module)~ expression. Module
-search path consists of two parts: first is relative to the source
-being compiled location, and the second is ~SEX_MODULE_PATH~
-environment variable.
-
-Module's public interface consists of everything declared
-~pub~. Structures, function, macros, types, variables can be
-public.
-
-** Syntactic macros
-Sex has support for syntactic macros. Macro definitions look like
-functions: they have a name, an argument list and a body. Macro should
-return Sex code.
-
-*** Examples:
-**** Structure with templated value type
-#+begin_src scheme
-(pub defmacro (list-T type)
-  (let ((list-type (cat 'list- type)))
-    `(struct ,list-type
-       ((value ,type)
-        (next (* ,list-type))))))
-
-(list-T int)
-#+end_src
-->
-#+begin_src scheme
-(struct list_int
- ((value int)
-  (next (* list_int))))
-#+end_src
-
-**** Wrapper for checking return codes
-#+begin_src scheme
-(pub defmacro (check-sdl-return call message ret-code)
-  `(if (< 0 ,call)
-       (do
-         (puts ,message)
-         (return ,ret-code))))
-
-(pub fn init () int
-  (check-sdl-return
-    (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
-...)
-#+end_src
-->
-#+begin_src scheme
-(pub fn init () int
-  (if (< 0 (SDL_Init SDL_INIT_VIDEO))
-    (do (puts "Failed to initialize SDL") (return 1)))
-  ...)
-#+end_src
+** Auto typedef for structs
+Probably harmless idk.
 
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
 best option.
 
-*** sex-mode.el
-To harness the power of sex-mode, add the following lines to your
-~$HOME/.config/emacs/init.el~:
-#+begin_src emacs-lisp
-(use-package sex-mode
-  :load-path "/path/to/sex"
-  :mode ("\\.sex\\'"))
-#+end_src
+** COMING SOON: Polymorhpism

dependencies.txt

@@ -1 +0,0 @@
-fmt getopt-long brev-separate test srfi-1 srfi-13 srfi-69 matchable

example/fns.sex

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

example/hello-world.sex

@@ -1,9 +0,0 @@
-(include stdio.h)
-
-(pub fn main ((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 0))

example/lambdas.sex

@@ -1,51 +0,0 @@
-(include stdio.h)
-
-(fn sum ((a int) (b int)) int
-  (return (+ a b)))
-
-(pub fn main () int
-  (var a int 10)
-  (var b int 20)
-  (var (fn ((int) (int)) int) sum-fn sum)
-
-  (var (fn ((int) (int)) int) sum-lambda
-
-       (lambda ((a int) (b int)) int ()
-         (return (+ a b))))
-
-  (var (fn ((int)) int) sum-lambda-2
-
-       (lambda ((a int)) int ()
-         (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 ((a int) (b int)) int ()
-                                            (return (+ a b 100)))
-                                          a b))
-
-  (var (fn ((int)) int) l-1
-       (lambda ((a int)) int ()
-         (var (fn ((int)) int) l-2
-              (lambda ((a int)) int ()
-                (return (+ 60 a))))
-         (return (+ 600 (l-2 a)))))
-  (printf "Calling nested lambdas: %d\n" (l-1 6))
-
-  ;; Not supported yet
-  ;; Closure
-  ;;  (var (fn (fn ((int)) int) ((int))) make-adder
-  ;;       (lambda (fn int ((int a))) ()
-  ;;         (return (lambda int ((int b)) (a)
-  ;;                   (return (+ a b))))))
-  ;;
-  ;;  (var (fn int ((int))) add-10
-  ;;       (make-adder 10))
-  ;;  (var (fn int ((int))) add-20
-  ;;       (make-adder 20))
-  ;;  (printf "Calling closures: %d\n" (add-10 24))
-  (return 0))

example/list.sex

@@ -1,48 +0,0 @@
-(pub defmacro (list-T type)
-  (let ((list-type (cat 'list- type)))
-    `(struct ,list-type
-       ((value ,type)
-        (next (* struct ,list-type))))))
-
-(pub defmacro (make-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'make-list- type)))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
-      (var list (* ,list-type) (cast  (malloc (sizeof ,list-type)) (* ,list-type)))
-      (= (-> list next) NULL)
-      (return list))))
-
-(pub defmacro (add-value-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'add-value-list- type)))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
-      (while (!= (-> list next) NULL)
-        (= list (-> list next)))
-      (= (-> list next) (,(cat 'make-list- type)))
-      (= (-> list value) value))))
-
-(pub defmacro (length-list-T type is-public?)
-  (let ((fn-name (cat 'length-list- type))
-        (list-type (list 'struct (cat 'list- type))))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
-      (var n size-t 0)
-      (while (!= (-> list next) NULL)
-        (= list (-> list next))
-        (++ n))
-      (return n))))
-
-(pub defmacro (is-empty-list-T type is-public?)
-  `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
-    ((list ,(list '* 'struct (cat 'list- type))))
-    bool
-    (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)))
-    `(do
-      (var ,list-var-2 (* ,list-type) ,list-var)
-      (var ,elt-var ,elt-type (-> ,list-var-2 value))
-      (while (!= (-> ,list-var-2 next) NULL)
-        ,what-do
-        (= ,list-var-2 (-> ,list-var-2 next))
-        (= ,elt-var (-> ,list-var-2 value))))))

example/test-list.sex

@@ -1,44 +0,0 @@
-(include stdlib.h)
-(include stddef.h)
-(include stdio.h)
-
-(import list)
-
-(struct foo
-  ((a-field float)
-   (b int)
-   (c (* const char))
-   (not (fn ((val bool)) bool))))
-
-(var f (struct foo))
-
-(list-T int)
-(make-list-T int #f)
-(add-value-list-T int #f)
-(length-list-T int #f)
-(is-empty-list-T int #f)
-
-(extern fn puk ((a int) (b float)) void)
-(pub fn baz () bool
-  (return true))
-
-(extern var i int)
-(var j int)
-(pub var k int)
-
-(pub fn main () int
-     (var l (* struct list-int) (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 (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 l->next (* void)))
-     (return 0))
-
-(pub fn print-list ((l (* const struct list-int))) void
-     (list-for-each (const struct list-int) l int v (printf "%d " v))
-     (printf "\n"))

fmt-c-writer.module.scm

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

fmt-c-writer.scm

@@ -1,424 +0,0 @@
-;;; Sex fmt-c output writer
-
-(import
-  scheme
-  (scheme base)                         ; make-parameter
-  (chicken base)
-  (chicken string)
-  (chicken syntax)
-  brev-separate                         ; fn, flatten
-  fmt
-  sex-fmt-c
-  matchable
-  (chicken irregex)                     ; unkebabify
-  srfi-1                                ; lists
-  srfi-13                               ; strings
-  utils)
-
-;;; egg `tree' not ported to CHICKEN 6 yet
-(define (tree-map f tree)
-  (cond ((null? tree) (list))
-        ((pair? tree) (cons (tree-map f (car tree))
-                            (tree-map f (cdr tree))))
-        (else (f tree))))
-
-;;; How much #line information to emit:
-;;;
-;;;   statement -- before every statement.
-;;;   toplevel  -- one directive per toplevel form.
-;;;   none      -- none at all, for reading -C output by eye.
-(define sex-line-directives (make-parameter 'statement))
-
-(define (anchor-statements?)
-  (eq? (sex-line-directives) 'statement))
-
-(define (line-directive src)
-  ;; `%line' is fmt-c's #line directive. cpp-line concatenates its
-  ;; second argument verbatim, so the file name arrives already quoted.
-  `(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))
-
-(define (walk-body stmts)
-  "Walk a statement list, re-anchoring each statement that has a known
-source location. Only statement positions may be walked this way: a
-#line inside an expression is a C syntax error."
-  (if (anchor-statements?)
-      (append-map (lambda (s)
-                    (let ((src (form-source s)))
-                      (if src
-                          (list (line-directive src) (walk-expr s))
-                          (list (walk-expr s)))))
-                  (pack-comments stmts))
-      (map walk-expr (pack-comments stmts))))
-
-(define (walk-stmt s)
-  "A statement in a slot that holds exactly one form -- an `if' arm.
-Splicing is not possible there, since c-if reads anything past the arm
-as an `else if' chain, so the anchor and the statement are wrapped in
-`%begin': a statement sequence that emits no braces of its own (the
-surrounding c-block supplies them)."
-  (let ((src (and (pair? s) (anchor-statements?) (form-source s))))
-    (if src
-        `(%begin ,(line-directive src) ,(walk-expr s))
-        (walk-expr s))))
-
-;;; A `;' comment reads as a form, so one written inside a construct
-;;; with positional slots lands in a slot and shifts everything after
-;;; it. So take the positional slots by skipping comments, and hand
-;;; the comments back to be emitted just before the statement
-(define (take-slots forms n)
-  "Three values: the comment forms skipped over, the next N non-comment
-forms, and what remains."
-  (let loop ((fs forms) (n n) (comments (list)) (slots (list)))
-    (cond ((or (= n 0) (null? fs))
-           (values (reverse comments) (reverse slots) fs))
-          ((comment-form? (car fs))
-           (loop (cdr fs) n (cons (car fs) comments) slots))
-          (else
-           (loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))
-
-;;; `%begin' is a statement sequence that emits no braces of its own, so
-;;; the comments simply precede the statement.
-(define (with-comments comments form)
-  (if (null? comments)
-      form
-      `(%begin ,@(map walk-expr comments) ,form)))
-
-(define (walk-if-clauses clauses)
-  "(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
-  (let loop ((cs clauses) (acc (list)))
-    (cond ((null? cs) (reverse acc))
-          ((null? (cdr cs))                    ; trailing else statement
-           (reverse (cons (walk-stmt (car cs)) acc)))
-          (else (loop (cddr cs)
-                      (cons (walk-stmt (cadr cs))
-                            (cons (walk-expr (car cs)) acc)))))))
-
-(define (unkebabify sym)
-  (case sym
-    ((-) sym)
-    ((--) sym)
-    ((->) sym)
-    ((-=) sym)
-    (else
-     (string->symbol
-      (irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))
-
-(define (atom-to-fmt-c atom)
-  (case atom
-    ((fn) '%fun)
-    ((prototype) '%prototype)
-    ((do) '%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 (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
-
-;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
-(define (strip-comment-marker text)
-  (string-trim-both (string-trim text #\;)))
-
-(define (walk-comment texts)
-  (list '%comment
-        (string-append " "
-                       (string-intersperse (map strip-comment-marker texts)
-                                           "\n ")
-                       " ")))
-
-;;; Merge multiple lines of /* */ into single block
-(define (pack-comments forms)
-  (let loop ((fs forms) (acc (list)))
-    (cond
-     ((null? fs) (reverse acc))
-     ((comment-form? (car fs))
-      (let ((first (car fs)))
-        (let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
-          (if (and (pair? rest)
-                   (comment-form? (car rest))
-                   line
-                   (equal? (form-file first) (form-file (car rest)))
-                   (eqv? (form-line (car rest)) (+ line 1)))
-              (gather (cdr rest)
-                      (append texts (cdr (car rest)))
-                      (form-line (car rest)))
-              (loop rest
-                    (cons (if (eq? texts (cdr first))
-                              first          ; a run of one, left alone
-                              (copy-form-source! first (cons 'comment texts)))
-                          acc))))))
-     (else (loop (cdr fs) (cons (car fs) acc))))))
-
-(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-expr form)
-  (match form
-    ((? vector?)
-     (list->vector
-      (walk-expr (vector->list form))))
-    ((? atom?)
-     (atom-to-fmt-c form))
-    ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
-    (('comment . text) (walk-comment text))
-    ;; (dot-access obj field ...) -> obj.field... member access. `%.'
-    ;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
-    (('dot-access . rest) (cons '%. (map walk-expr rest)))
-    (('var . _) (walk-var form))
-    ;; An expression has no room for a statement, so a comment in a
-    ;; cast is dropped rather than relocated.
-    (('cast . rest)
-     (let-values (((comments slots _) (take-slots rest 2)))
-       (list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
-    (('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)))
-
-    ;; Statement positions. These are the only places a #line may go,
-    ;; and each is spliced or wrapped according to what the
-    ;; corresponding fmt-c procedure accepts.
-    (('do . stmts) (cons '%block-begin (walk-body stmts)))
-    (('if . clauses)
-     (with-comments (filter comment-form? clauses)
-       (cons 'if (walk-if-clauses (remove comment-form? clauses)))))
-    (('while . rest)
-     (let-values (((comments slots body) (take-slots rest 1)))
-       (with-comments comments
-         (cons* 'while (walk-expr (car slots)) (walk-body body)))))
-    (('for . rest)
-     (let-values (((comments slots body) (take-slots rest 3)))
-       (with-comments comments
-         (cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
-                (walk-expr (caddr slots))
-                (walk-body body)))))
-    ;; No anchor *between* switch clauses: c-switch requires every clause
-    ;; to be a case/default form and errors on anything else. The clause
-    ;; bodies are anchored from inside, which is what a debugger steps
-    ;; onto -- a `case' label is not a statement.
-    ;; A comment between clauses has to go too: c-switch requires every
-    ;; clause to be a case/default form and errors on anything else.
-    (('switch . rest)
-     (let-values (((comments slots clauses) (take-slots rest 1)))
-       (with-comments (append comments (filter comment-form? clauses))
-         (cons* 'switch (walk-expr (car slots))
-                (map walk-expr (remove comment-form? clauses))))))
-    (('case . rest)
-     (let-values (((comments slots body) (take-slots rest 1)))
-       (with-comments comments
-         (cons* 'case (walk-expr (car slots)) (walk-body body)))))
-    (('case/fallthrough . rest)
-     (let-values (((comments slots body) (take-slots rest 1)))
-       (with-comments comments
-         (cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
-    (('default . body) (cons 'default (walk-body body)))
-
-    ;; Drop comments so they will not generate additional comma
-    (else (map walk-expr (remove comment-form? 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)
-  ;; Likewise a declaration: drop any comment rather than shift the
-  ;; name and type apart.
-  (let ((form (cons (car form) (remove comment-form? (cdr form)))))
-    `(%var
-      ,(walk-type (third form))
-      ,(atom-to-fmt-c (second form))
-      .
-      ,(if (null? (drop form 3))
-           (list)
-           (walk-expr (drop form 3)))))) ; optional init expression
-
-(define (walk-type form)
-  ;; 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"))
-
-    ;; 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-body 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 (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))
-
-          ;; 1 element args are always type
-          ((_) (walk-type x))
-
-          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
-                                (list (walk-type var))))))
-       (remove comment-form? 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)))))
-       (remove comment-form? 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-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-public form)
-  (match form
-    (('fn . _)
-     (walk-function form))
-    (('var . _)
-     (walk-var form))
-    ((or ('define . _)
-         ('defmacro . _)
-
-         ('import . _)
-         ('include . _)
-
-         ('struct . _)
-         ('union . _)
-
-         ('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
-    (('comment . text) (walk-comment text))
-    (('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 (emit-c sex-forms)
-  (for-each (lambda (form)
-              ;; Forms the reader did not produce -- the prelude, and
-              ;; anything a macro built that we could not attribute --
-              ;; have no location and get no directive.
-              (let ((src (and (not (eq? (sex-line-directives) 'none))
-                              (form-source form))))
-                (when src
-                  (fmt #t (c-expr (line-directive src)))))
-              (fmt #t (c-expr (process-toplevel-form form)) nl))
-            (pack-comments sex-forms)))

hello-world.sex

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

lib/list.hsex

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

lib/test-list.sex

@@ -0,0 +1,28 @@
+(include stdlib.h)
+(include stddef.h)
+(include stdbool.h)
+(include stdio.h)
+
+(load "list.hsex")
+
+(struct foo
+  ((float a)
+   (int b)))
+
+,(list-T '(int))
+,(make-list-T '(int) #f)
+,(add-value-list-T '(int) #f)
+,(length-list-T '(int) #f)
+,(is-empty-list-T '(int) #f)
+
+(fn bool bar () false)
+
+(pub fn int main ()
+     (var (* list-int) l (make-list-int))
+     (printf "Size of the list: %zu\n" (length-list-int l))
+     (add-value-list-int l 3)
+     (add-value-list-int l 4)
+     (printf "Size of the list: %zu\n" (length-list-int l))
+     ,(list-for-each '((printf "%d " v) l v))
+     (printf "\n")
+     0)

main.scm

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

reader.module.scm

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

reader.scm

@@ -1,284 +0,0 @@
-;;; Sex reader
-;;;
-;;; A hand-written tokenizer + recursive-descent parser that replaces
-;;; CHICKEN's built-in `read'. We need our own reader because the
-;;; features Sex requires cannot be expressed on top of `read':
-;;;   - [ ... ] array/pointer sugar, read as (¤ ...)
-;;;   - a leading `.' rewritten to the symbol `dot-access'
-;;;   - `;' comments preserved as (comment "...") forms, so they can be
-;;;     re-emitted into the generated C (keeping the source mapping)
-;;; It also records the source location of every form it reads (see
-;;; utils' form-source), so the C writer can emit #line directives.
-
-(import
-  scheme
-  (scheme base)                         ; make-parameter
-  (chicken base)
-  (chicken pathname)
-  utils)
-
-;;; Sentinels for structural tokens
-(define close-paren   (list '%close-paren))
-(define close-bracket (list '%close-bracket))
-(define dot-token     (list '%dot))
-
-;;; Current source line. Tracked as characters are consumed
-(define current-line (make-parameter 1))
-
-(define (get-ch port)
-  (let ((c (read-char port)))
-    (when (and (char? c) (char=? c #\newline))
-      (current-line (+ 1 (current-line))))
-    c))
-
-(define (peek port)
-  (peek-char port))
-
-;;; Record where a form started. Called with the line of the opening
-;;; delimiter, sampled before it is consumed
-(define (stamp form line)
-  (when (pair? form)
-    (set-form-source! form (current-source-file) line))
-  form)
-
-(define (delimiter? c)
-  (or (eof-object? c)
-      (char-whitespace? c)
-      (memv c '(#\( #\) #\[ #\] #\" #\; #\' #\` #\,))))
-
-;;; Skip whitespace. `;' comments are NOT skipped here: they are read
-;;; as (comment "...") forms by the tokenizer. Block comments (#| |#)
-;;; and datum comments (#;) are discarded in the tokenizer's `#'
-;;; dispatch, since `#' also introduces real data (#t, #f, #\c, #(...))
-(define (skip-whitespace port)
-  (let ((c (peek port)))
-    (cond
-     ((eof-object? c) #t)
-     ((char-whitespace? c) (get-ch port) (skip-whitespace port))
-     (else #t))))
-
-;;; A `;' comment, read as (comment "<rest of line>"). The leading `;'
-;;; is consumed; the newline is left in the stream so line tracking and
-;;; the surrounding parser see it normally
-(define (read-comment port)
-  (get-ch port)                         ; consume the leading ;
-  (let loop ((chars (list)))
-    (let ((c (peek port)))
-      (if (or (eof-object? c) (char=? c #\newline))
-          (list 'comment (list->string (reverse chars)))
-          (begin (get-ch port)
-                 (loop (cons c chars)))))))
-
-;;; Read the next token: a datum, one of the structural sentinels
-;;; (close-paren / close-bracket / dot-token), or the eof-object
-(define (next-token port)
-  (skip-whitespace port)
-  (let ((c (peek port)))
-    (cond
-     ((eof-object? c) c)
-     ((char=? c #\()
-      (let ((line (current-line)))
-        (get-ch port)
-        (stamp (read-list port close-paren) line)))
-     ((char=? c #\[)
-      (let ((line (current-line)))
-        (get-ch port)
-        (stamp (cons '¤ (read-list port close-bracket)) line)))
-     ((char=? c #\)) (get-ch port) close-paren)
-     ((char=? c #\]) (get-ch port) close-bracket)
-     ((char=? c #\;)
-      (let ((line (current-line)))
-        (stamp (read-comment port) line)))
-     ((char=? c #\") (read-string-lit port))
-     ((char=? c #\') (get-ch port) (list 'quote (read-datum port)))
-     ((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port)))
-     ((char=? c #\,)
-      (get-ch port)
-      (if (eqv? (peek port) #\@)
-          (begin (get-ch port) (list 'unquote-splicing (read-datum port)))
-          (list 'unquote (read-datum port))))
-     ((char=? c #\#) (get-ch port) (read-hash port))
-     (else (read-atom port)))))
-
-;;; Like next-token, but a full datum is required: the structural
-;;; sentinels and eof are errors here (e.g. after a quote or `.')
-(define (read-datum port)
-  (let ((tok (next-token port)))
-    (cond
-     ((eof-object? tok) (error "Unexpected end of input"))
-     ((eq? tok close-paren) (error "Unexpected )"))
-     ((eq? tok close-bracket) (error "Unexpected ]"))
-     ((eq? tok dot-token) (error "Unexpected ."))
-     (else tok))))
-
-;;; Read list elements up to close-paren or close-bracket,
-;;; honoring dotted-pair notation (a b . c)
-(define (read-list port closer)
-  (let loop ((acc (list)))
-    (let ((tok (next-token port)))
-      (cond
-       ((eof-object? tok) (error "Unexpected end of input inside list"))
-       ((eq? tok close-paren)
-        (if (eq? closer close-paren)
-            (reverse acc)
-            (error "Unmatched closing bracket")))
-       ((eq? tok close-bracket)
-        (if (eq? closer close-bracket)
-            (reverse acc)
-            (error "Unmatched closing bracket")))
-       ((eq? tok dot-token)
-        (if (null? acc)
-            ;; Leading `.': the member/method access operator. It reads
-            ;; as an ordinary `dot-access' symbol in first position.
-            (loop (cons 'dot-access acc))
-            ;; Otherwise: ordinary dotted-pair notation (a b . c).
-            (let ((tail (read-datum port))
-                  (end (next-token port)))
-              (unless (eq? end closer)
-                (error "Malformed dotted list"))
-              (append-reverse acc tail))))
-       (else (loop (cons tok acc)))))))
-
-;;; Append the reversed list `rev' in front of `tail', producing a
-;;; possibly-improper list (used for dotted pairs)
-(define (append-reverse rev tail)
-  (if (null? rev)
-      tail
-      (append-reverse (cdr rev) (cons (car rev) tail))))
-
-;;; A bare atom: symbol or number, or the dot token when it is exactly "."
-(define (read-atom port)
-  (let loop ((chars (list)))
-    (let ((c (peek port)))
-      (if (delimiter? c)
-          (finish-atom (list->string (reverse chars)))
-          (begin (get-ch port) (loop (cons c chars)))))))
-
-(define (finish-atom s)
-  (cond
-   ((string=? s ".") dot-token)
-   ((string->number s) => identity)
-   (else (string->symbol s))))
-
-;;; #-dispatch: booleans, characters, vectors, block/datum comments
-(define (read-hash port)
-  (let ((c (get-ch port)))
-    (cond
-     ((eof-object? c) (error "Unexpected end of input after #"))
-     ((or (char=? c #\t) (char=? c #\T)) (read-bool port #t))
-     ((or (char=? c #\f) (char=? c #\F)) (read-bool port #f))
-     ((char=? c #\\) (read-char-lit port))
-     ((char=? c #\() (list->vector (read-list port close-paren)))
-     ((char=? c #\|) (skip-block-comment port 1) (next-token port))
-     ((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
-     (else (error "Unsupported # syntax" c)))))
-
-;;; #t / #true / #f / #false. `val' is the boolean; consume any
-;;; trailing name characters and validate
-(define (read-bool port val)
-  (let ((rest (read-atom-string port)))
-    (cond
-     ((string=? rest "") val)
-     ((and val (string=? rest "rue")) val)
-     ((and (not val) (string=? rest "alse")) val)
-     (else (error "Malformed boolean literal" rest)))))
-
-(define (read-atom-string port)
-  (let loop ((chars (list)))
-    (let ((c (peek port)))
-      (if (delimiter? c)
-          (list->string (reverse chars))
-          (begin (get-ch port) (loop (cons c chars)))))))
-
-(define named-chars
-  '(("space" . #\space) ("newline" . #\newline) ("tab" . #\tab)
-    ("return" . #\return) ("nul" . #\nul) ("null" . #\nul)
-    ("delete" . #\delete) ("escape" . #\escape) ("alarm" . #\alarm)
-    ("backspace" . #\backspace)))
-
-(define (read-char-lit port)
-  (let ((first (get-ch port)))
-    (when (eof-object? first)
-      (error "Unexpected end of input in character literal"))
-    (if (char-alphabetic? first)
-        (let ((rest (read-atom-string port)))
-          (if (string=? rest "")
-              first
-              (let ((name (string-append (string first) rest)))
-                (cond
-                 ((assoc name named-chars) => cdr)
-                 (else (error "Unknown character name" name))))))
-        first)))
-
-;;; String literal with escape processing, matching the common escapes
-;;; the previous reader (CHICKEN `read') interpreted
-(define (read-string-lit port)
-  (get-ch port)                         ; consume opening quote
-  (let loop ((chars (list)))
-    (let ((c (get-ch port)))
-      (cond
-       ((eof-object? c) (error "Unterminated string literal"))
-       ((char=? c #\") (list->string (reverse chars)))
-       ((char=? c #\\) (loop (cons (read-escape port) chars)))
-       (else (loop (cons c chars)))))))
-
-(define (read-escape port)
-  (let ((c (get-ch port)))
-    (cond
-     ((eof-object? c) (error "Unterminated string literal"))
-     ((char=? c #\n) #\newline)
-     ((char=? c #\t) #\tab)
-     ((char=? c #\r) #\return)
-     ((char=? c #\a) #\alarm)
-     ((char=? c #\b) #\backspace)
-     ((char=? c #\f) (integer->char 12))
-     ((char=? c #\v) (integer->char 11))
-     ((char=? c #\0) #\nul)
-     (else c))))                        ; \" \\ and anything else: literal
-
-(define (skip-block-comment port depth)
-  (if (= depth 0)
-      #t
-      (let ((c (get-ch port)))
-        (cond
-         ((eof-object? c) (error "Unterminated block comment"))
-         ((and (char=? c #\|) (eqv? (peek port) #\#))
-          (get-ch port) (skip-block-comment port (- depth 1)))
-         ((and (char=? c #\#) (eqv? (peek port) #\|))
-          (get-ch port) (skip-block-comment port (+ depth 1)))
-         (else (skip-block-comment port depth))))))
-
-;;; Read every top-level form from `port'. Locations are recorded by
-;;; next-token, for every form rather than only these
-(define (parse-all port)
-  (parameterize ((current-line 1))
-    (let loop ((acc (list)))
-      (skip-whitespace port)
-      (let ((tok (next-token port)))
-        (cond
-         ((eof-object? tok) (reverse acc))
-         ((or (eq? tok close-paren)
-              (eq? tok close-bracket))
-          (error "Unmatched closing bracket at top level"))
-         ((eq? tok dot-token)
-          (error "Unexpected . at top level"))
-         (else
-          (loop (cons tok acc))))))))
-
-;;; Entry point: read all forms from a file, or from the current input
-;;; port when the source is 'stdin
-(define (read-from-file file)
-  ;; Resolve the name before with-directory moves us, so an imported
-  ;; module's forms carry that module's path rather than the importer's
-  (let ((source-file (to-absolute-pathname file)))
-    (with-directory file
-      (with-input-from-file (pathname-strip-directory file)
-        (lambda ()
-          (parameterize ((current-source-file source-file))
-            (parse-all (current-input-port))))))))
-
-(define (read-raw-forms input-source)
-  (if (eq? input-source 'stdin)
-      (parameterize ((current-source-file "stdin"))
-        (parse-all (current-input-port)))
-      (read-from-file input-source)))

semen.module.scm

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

semen.scm

@@ -1,267 +0,0 @@
-;;; Sex semantic engine
-
-(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))
-
-;;; 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 (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 (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))
-        (src (form-source macro-form)))
-    ;; An expansion is fresh structure with no location of its own. Give
-    ;; it the call site's, the way cpp attributes a macro body to where
-    ;; the macro was used
-    (if (list? (car res))
-        (append (map (lambda (f) (stamp-form-source! f src)) res)
-                rest-forms)
-        (cons (stamp-form-source! res src) 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))
-    (('comment . _) (cons sex-form acc))
-
-    (('import . modules)
-     (process-imports (get-modules-public-forms modules) acc))
-
-    ((or ('defmacro . rest)
-         ('pub 'defmacro . rest)) (defmacro rest) acc)
-
-    ((or ('typedef new-type target)
-         ('pub 'typedef new-type target))
-     (process-typedef sex-form new-type target acc))
-
-    (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 (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
-;;; perform additional operations depending of what the walk function
-;;; has requested.
-
-;;; 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-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 form new-type target acc)
-  (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
-
-;;; Fn processing
-
-(define (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
-
-(define (strip-fn-header-comments fn-form)
-  ;; Remove comment forms from the function header
-  ;; ([pub|extern] fn name arglist rettype) so the positional accessors
-  ;; below are not shifted. Comments in the body are left in place as
-  ;; ordinary statements and preserved into the generated C.
-  (let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
-    ;; This always rebuilds the list, so the location has to be carried
-    ;; over explicitly -- otherwise every function loses it
-    (copy-form-source!
-     fn-form
-     (let loop ((form fn-form) (kept 0) (acc (list)))
-       (cond
-        ((null? form) (reverse acc))
-        ((= kept header-count) (append (reverse acc) form))
-        ((comment-form? (car form)) (loop (cdr form) kept acc))
-        (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
-
-(define (process-fn sex-fn-raw acc)
-  (let* ((sex-fn (strip-fn-header-comments sex-fn-raw))
-         (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))))
-
-(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-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 (copy-form-source! form `(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-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.module.scm

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

sex-macros.scm

@@ -1,38 +0,0 @@
-(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-mode.el

@@ -28,20 +28,12 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
     (list
      ;; Declarations
      (list (concat "("
-                   (regexp-opt '("chicken-define"
-                                 "chicken-define-syntax"
-                                 "chicken-import"
-                                 "chicken-load"
-                                 "define"
-                                 "defmacro"
-                                 "extern"
-                                 "import"
-                                 "include"
+                   (regexp-opt '("include"
                                  "fn"
                                  "pub"
                                  "struct"
-                                 "var"
-                                 "union")
+                                 "template"
+                                 "var")
                                'word)
                    "\\>"
                    "[[:space:]]*"
@@ -51,9 +43,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
      ;; Keywords
      (list (concat "("
                    (regexp-opt '(
-                                 "do"
                                  "case"
-                                 "default"
                                  "do"
                                  "if"
                                  "for"
@@ -79,14 +69,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
   (setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
 
 (put 'fn 'lisp-indent-function 'defun)
-(put 'pub 'lisp-indent-function 'defun)
-(put 'defmacro 'lisp-indent-function 'defun)
+(put 'template 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
-(put 'union 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
-(put 'import 'lisp-indent-function 1)
-(put 'switch 'lisp-indent-function 1)
-(put 'case 'lisp-indent-function 1)
 
 ;;;###autoload
 (define-derived-mode sex-mode lisp-data-mode "Sex"

sex-modules.module.scm

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

sex-modules.scm

@@ -1,87 +0,0 @@
-(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 (copy-form-source! form (take (cdr form) 4)) acc))
-       ((define defmacro import include struct typedef union var)
-        (cons (copy-form-source! form (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

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

sexc.scm

@@ -1,68 +1,136 @@
-(import scheme
-        (scheme base)                   ; call/cc
-        brev-separate
-        (chicken base)
-        (chicken file)
-        (chicken plist)
+(declare (unit sexc)
+         (uses templates))
+
+(import brev-separate
+        (chicken pathname)
         (chicken pretty-print)
-        (chicken process)
         (chicken process-context)
-        (chicken port)
+        (chicken string)
         fmt
-        fmt-c-writer
+        fmt-c
         getopt-long
-        sex-macros
-        sex-modules
-        reader
-        semen
         srfi-1                          ; list routines
-        utils)
+        tree)
+
+(define +debug+ #f)
+
+(define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
+     (string->symbol
+      (string-translate (symbol->string sym) #\- #\_)))))
+
+(define (atom-to-fmt-c atom)
+  (case atom
+    ((fn) '%fun)
+    ((var) '%var)
+    ((begin) '%begin)
+    ((pointer) '%pointer)
+    ((array) '%array)
+    ((@) 'vector-ref)
+    ((include) '%include)
+    ((cast) '%cast)
+    (else
+     (if (symbol? atom)
+         (unkebabify atom)
+         atom))))
+
+(define (tree-finder symbol)
+  (lambda (node)
+    (or (and (tree? node)
+             (eq? (car node) symbol))
+        #f)))
+
+(define (walk-generic form acc)
+  (if (eq? (car form) 'unquote)
+      ;; special case - replace top-level unquote with it's expansion
+      (append
+       (fold append (list)
+             (map (fn (walk-sex-tree x (list)))
+                  (eval (cadr form))))
+       acc)
+      (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f)))
+        (if unquote-form
+            (begin
+              (let* ((inv (invert-tree form))
+                     (pos (tree-local-position inv unquote-form)))
+                (for-each (fn
+                           (set! form (tree-insert inv (tree-parent inv unquote-form) pos x))
+                           (set! inv (invert-tree form)))
+                          (reverse (eval (cadr unquote-form))))
+                (set! form (tree-prune inv unquote-form)))
+              (loop (tree-find (tree-finder 'unquote)
+                               form
+                               #f)))
+            (cons (tree-map atom-to-fmt-c form) acc)))))
+
+(define (walk-function form static acc)
+  (if static
+      (walk-generic (list 'static form) acc)
+      (walk-generic (cdr form) acc)))
+
+(define (walk-struct form acc)
+  (let ((name (unkebabify (cadr form))))
+    (walk-generic form (cons `(typedef struct ,name ,name) acc))))
+
+(define (walk-sex-tree form acc)
+  (case (car form)
+    ((fn) (walk-function form #t acc))
+    ((pub) (walk-function form #f acc))
+    ((struct) (walk-struct form acc))
+    (else (walk-generic form acc))))
+
+(define (process-form form acc)
+  (case (car form)
+    ((define) (eval form) acc)
+    ((template) (eval form) acc)
+    ((load) (eval form) acc)
+    ((instance) (walk-sex-tree (eval form) acc))
+    (else
+     (walk-sex-tree form acc))))
+
+(define (process-raw-forms raw-forms acc)
+  (if (null? raw-forms) (filter (fn (not (null? x)))
+                                (reverse acc))
+      (process-raw-forms (cdr raw-forms)
+                         (process-form (car raw-forms) acc))))
+
+(define (read-forms acc)
+  (let ((r (read)))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
+
+(define (emit-c forms)
+  (for-each (lambda (form)
+              (fmt #t (c-expr form))
+              (fmt #t "\n"))
+            forms))
 
 ;;; Main function facilities
 
 (define opts-grammar
-  (let ((padding 26))
-    `((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"
+  `((output "Write output to file"
             (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))
-      (line-directives
-       ,(fmt #f "How much #line information to emit: statement (default)," nl
-             (pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
-             (pad padding) "land on the right source line; `none' is for reading -C" nl
-             (pad padding) "output by eye")
-       (required #f)
-       (value #t)))))
+            (value #t)
+            (single-char #\o))
+    (help "Show this help"
+          (required #f)
+          (value #f)
+          (single-char #\h))
+    (macro-expand "Emit macro-expanded Sex code instead of C"
+                  (required #f)
+                  (value #f)
+                  (single-char #\m))))
 
 (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 ""))
+  (fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
+  (fmt #t "Options: -o, --output <file>        Write output to file. If omitted, write to stdout\n")
+  (fmt #t "         -h, --help                 Show this help\n")
+  (fmt #t "         -m, --macro-expand         Emit macro-expanded Sex code instead of C\n"))
 
 (define (help-arg? args)
   (assoc 'help args))
@@ -72,130 +140,44 @@
     (if arg (cdr arg)
         default)))
 
-;;; Everything before the first `--' is ours to parse, everything after
-;;; is handed to the C compiler verbatim
-
-(define (separator? a)
-  (string=? a "--"))
-
-(define (args-before-separator argv)
-  (take-while (complement separator?) argv))
-
-(define (args-after-separator argv)
-  (let ((tail (drop-while (complement separator?) argv)))
-    (if (null? tail)
-        (list)
-        (cdr tail))))
-
-(define (get-rest-args args)
-  (cdr (assoc '@ args)))
-
-(define (line-directives-arg args)
-  (let ((v (get-arg args 'line-directives "statement")))
-    (cond ((equal? v "statement") 'statement)
-          ((equal? v "toplevel") 'toplevel)
-          ((equal? v "none") 'none)
-          (else (error "--line-directives must be statement, toplevel or none, got" v)))))
-
 (define (get-input-file args)
-  (let ((rest-args (get-rest-args args)))
-    (if (null? rest-args)
+  (let ((rest-args (assoc '@ args)))
+    (if (= 1 (length rest-args))
         'stdin
-        (car rest-args))))
+        (cadr rest-args))))
 
-(define (write-to-file-or-stdout output what)
-  (if (eq? output 'default)
-      (what)
-      (with-output-to-file output
-        (fn (what)))))
+(define (read-from-file file)
+  (with-input-from-file (pathname-strip-directory file)
+    (fn (read-forms (list)))))
 
-(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 cc-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)))
-    ;; `process' hands back one record. Its port accessors are named
-    ;; from the *child's* point of view, so `process-input-port' is the
-    ;; port we write to: the C compiler's stdin.
-    (let* ((proc (process compiler (append (list "-o" out-file "-x" "c")
-                                           (if (get-arg args 'compile-object #f)
-                                               (list "-c")
-                                               (list))
-                                           (list "-")  ; read stdin
-                                           cc-args)))
-           (cc-stdin (process-input-port proc)))
-      (with-output-to-port cc-stdin
-        (lambda () (emit-c sex-forms)))
-      (close-output-port cc-stdin)
-      (process-wait proc))))
-
-(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)
-
-    (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 (set-working-directory file)
+  (change-directory
+   (normalize-pathname
+    (make-absolute-pathname
+     (current-directory)
+     (pathname-directory file)))))
 
 (define (main)
-  (let* ((argv (command-line-arguments))
-         (raw-args (args-before-separator argv))
-         (cc-args (args-after-separator argv))
+  (let* ((raw-args (command-line-arguments))
+         (current-dir (current-directory))
          (args (getopt-long raw-args
                             opts-grammar))
-         (output (get-arg args 'output 'default))
+         (output (get-arg args 'output 'stdout))
          (help (help-arg? args))
-
-         (input (get-input-file args))
-         (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)
-
-       ;; The file name in a #line directive now comes from the form's
-       ;; own recorded location, so imported modules report themselves
-       ;; rather than the unit that imported them
-       (sex-line-directives (line-directives-arg args))
-       (when (and (get-arg args 'emit-c #f)
-                  (not (get-arg args 'line-directives #f)))
-         (sex-line-directives 'none))
-
-       (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 cc-args)))))))
+         (input (get-input-file args)))
+    (if help (print-help)
+        (let* ((raw-forms
+                (if (eq? input 'stdin)
+                    (read-forms (list))
+                    (begin
+                      (set-working-directory input)
+                      (read-from-file input))))
+               (sex-forms (process-raw-forms raw-forms (list))))
+          (change-directory current-dir)
+          (if (get-arg args 'macro-expand #f)
+              (map pp sex-forms)
+              (if (not (eq? output 'stdout))
+                  (with-output-to-file output
+                    (lambda ()
+                      (emit-c sex-forms)))
+                  (emit-c sex-forms)))))))

templates.scm

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

tests/Makefile

@@ -1,45 +0,0 @@
-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 line-directives codegen args
-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 utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link 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.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 $(SEX_OBJ)
-	rm -f *.import.scm
-	rm -f *.link
-	rm -f sex-tests

tests/args.scm

@@ -1,55 +0,0 @@
-;;; Splitting the command line at `--'.
-;;;
-;;; getopt-long cannot do this: it consumes the separator and merges
-;;; everything after it into `@' alongside the input file. So sexc
-;;; splits the raw argv first, and only the head is parsed as options.
-;;; Everything else reaches the C compiler exactly as written --
-;;; including the words that do not start with a dash, which a previous
-;;; leading-dash heuristic used to drop.
-
-(import sexc)
-
-(define full '("foo.sex" "-o" "bar" "--" "-framework" "OpenGL" "-Wall"))
-
-(test-group "argument separator"
-
-  (test "options and input file stay with sexc"
-        '("foo.sex" "-o" "bar")
-        (args-before-separator full))
-
-  (test "the tail reaches the compiler verbatim"
-        '("-framework" "OpenGL" "-Wall")
-        (args-after-separator full))
-
-  ;; The case that motivated this: `OpenGL' has no leading dash and was
-  ;; silently dropped, leaving `-framework' to swallow whatever flag
-  ;; came next.
-  (test "a word without a dash survives"
-        '("-framework" "OpenGL")
-        (args-after-separator '("x.sex" "--" "-framework" "OpenGL")))
-
-  (test "no separator means nothing for the compiler"
-        '()
-        (args-after-separator '("foo.sex" "-o" "bar")))
-
-  (test "no separator leaves every argument with sexc"
-        '("foo.sex" "-o" "bar")
-        (args-before-separator '("foo.sex" "-o" "bar")))
-
-  (test "a trailing separator is allowed"
-        '()
-        (args-after-separator '("foo.sex" "--")))
-
-  (test "a leading separator leaves no input file"
-        '()
-        (args-before-separator '("--" "-lm")))
-
-  ;; Only the first `--' separates; a later one is an ordinary compiler
-  ;; argument (ld takes several).
-  (test "only the first separator counts"
-        '("-Wl,--as-needed" "--" "-lm")
-        (args-after-separator '("x.sex" "--" "-Wl,--as-needed" "--" "-lm")))
-
-  (test "an empty command line is handled"
-        '()
-        (args-before-separator '())))

tests/basic.scm

@@ -1,51 +0,0 @@
-(import fmt-c-writer)
-
-(test-group "basic"
-
-  ;; unkebabify
-  (test '- (unkebabify '-))
-  (test '-- (unkebabify '--))
-  (test '-> (unkebabify '->))
-  (test '-= (unkebabify '-=))
-  (test 'kebab_case (unkebabify 'kebab-case))
-  (test '_what_ (unkebabify '-what-))
-  (test 'this->member (unkebabify 'this->member))
-  (test '_this_->_member_ (unkebabify '-this-->-member-))
-  (test '__->>> (unkebabify '--->>>))
-
-  ;; Non-ASCII identifiers must survive intact. The `regex' egg's
-  ;; string-substitute drops one trailing character per multi-byte
-  ;; character, which renames things silently -- the C still compiles,
-  ;; just under a different name than was written.
-  (test 'naïve_count (unkebabify 'naïve-count))
-  (test 'aï_b (unkebabify 'aï-b))
-  (test 'ïï (unkebabify 'ïï))
-
-  ;; atom-to-fmt-c
-  (test '%fun (atom-to-fmt-c 'fn))
-  (test '%prototype (atom-to-fmt-c 'prototype))
-  (test '%block-begin (atom-to-fmt-c 'do))
-  (test '%define (atom-to-fmt-c 'define))
-  (test '%pointer (atom-to-fmt-c 'pointer))
-  (test '%array (atom-to-fmt-c 'array))
-  (test 'vector-ref (atom-to-fmt-c '¤))
-  (test '%include (atom-to-fmt-c 'include))
-
-  ;; c89 stuff
-  (test 'int (atom-to-fmt-c 'bool))
-  (test 1 (atom-to-fmt-c 'true))
-  (test 0 (atom-to-fmt-c 'false))
-
-  ;; dot-access -> %. member-access directive (kebab-converted operands)
-  (test '(%. a b) (walk-expr '(dot-access a b)))
-  (test '(%. a b c) (walk-expr '(dot-access a b c)))
-  (test '(%. a_b c) (walk-expr '(dot-access a-b c)))
-
-  ;; comment -> %comment directive (rendered as /* ... */)
-  ;; The reader eats only the `;' that introduced the line, so ";;; Foo"
-  ;; arrives as ";; Foo"; and c-comment puts nothing between /* */ and
-  ;; the text. Both are handled on the way out.
-  (test '(%comment " hi ") (walk-expr '(comment " hi")))
-  (test '(%comment " hi ") (process-toplevel-form '(comment " hi")))
-  (test '(%comment " Foo ") (walk-expr '(comment ";; Foo")))
-  (test '(%comment " Foo ") (walk-expr '(comment ";;;   Foo   "))))

tests/codegen.scm

@@ -1,126 +0,0 @@
-;;; Codegen details that are easy to get subtly wrong, and that the
-;;; walk-* unit tests cannot see: they check the intermediate form we
-;;; hand to fmt-c, not the C that fmt-c renders from it.
-;;;
-;;; Both cases below were found by writing an OpenGL example, not by
-;;; the existing suite, because both need an operand shape that no
-;;; earlier test program happened to use.
-
-(import (chicken port)
-        (chicken string)
-        srfi-13
-        fmt-c-writer
-        reader
-        semen
-        utils)
-
-(define (sex->c source)
-  "Compile SOURCE, a string of Sex, and return the generated C."
-  (let ((forms (with-input-from-string source
-                 (lambda ()
-                   (parameterize ((current-source-file "codegen.sex"))
-                     (parse-all (current-input-port)))))))
-    (with-output-to-string
-      (lambda ()
-        (parameterize ((sex-line-directives 'none))
-          (emit-c (semen-process forms)))))))
-
-(define (emits? source fragment)
-  (and (string-contains (sex->c source) fragment) #t))
-
-(define (in-fn body)
-  (string-append "(fn f ((a int) (b int)) void " body ")"))
-
-(test-group "codegen"
-
-  ;; c-switch handed its scrutinee straight to `cat', which only works
-  ;; when it is an atom. Anything else was displayed as a raw
-  ;; s-expression: `switch ((%. e type))'.
-  (test-group "switch scrutinee"
-    (test-assert "member access"
-      (emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))"
-              "switch (e.type)"))
-    (test-assert "call"
-      (emits? (in-fn "(switch (g a) (case 1 (h)))")
-              "switch (g(a))"))
-    (test-assert "arithmetic"
-      (emits? (in-fn "(switch (+ a b) (case 1 (h)))")
-              "switch (a + b)")))
-
-  ;; A cast binds tighter than every binary operator, so an operand
-  ;; that is itself a binary expression has to be parenthesised --
-  ;; otherwise the cast silently applies to the first operand only.
-  (test-group "cast precedence"
-    (test-assert "binary operand is parenthesised"
-      (emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))")
-              "(void *)(2 * sizeof(int))"))
-    (test-assert "subtraction operand is parenthesised"
-      (emits? (in-fn "(var f float (cast (- a b) float))")
-              "(float)(a - b)"))
-    ;; ...but exactly once. The operand used to parenthesise itself
-    ;; again inside the parens the cast had just added.
-    (test-assert "and not parenthesised twice"
-      (not (emits? (in-fn "(var f float (cast (- a b) float))")
-                   "(float)((a - b))")))
-    ;; Unary operands are already unary-expressions and must be left
-    ;; alone, or every existing cast in the tree gains noise.
-    (test-assert "identifier is left bare"
-      (emits? (in-fn "(var f float (cast a float))")
-              "(float)a"))
-    (test-assert "address-of is left bare"
-      (emits? (in-fn "(var p (* int) (cast (& a) (* int)))")
-              "(int *)&a"))
-    (test-assert "sizeof is left bare"
-      (emits? (in-fn "(var n int (cast (sizeof int) int))")
-              "(int)sizeof(int)")))
-
-  ;; A comment among a call's arguments used to become an argument,
-  ;; and c-apply put a comma on each side of it -- which does not
-  ;; compile. It is dropped, as in any other expression context.
-  (test-group "comments among arguments"
-    (test-assert "no stray comma"
-      (not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
-    (test-assert "the arguments survive"
-      (emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
-
-  ;; The reader leaves the `;'s that introduced each line, and a run of
-  ;; comment lines arrives as one form per line.
-  (test-group "comment rendering"
-    (test-assert "the markers are stripped"
-      (emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
-    (test-assert "so none survive into the C"
-      (not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
-    (test-assert "consecutive lines are packed into one comment"
-      (emits? "(fn f () void\n ;; first\n ;; second\n (g))"
-              "/* first\n second */"))
-    ;; Packing compares locations rather than just looking for adjacent
-    ;; comment forms, so a blank line still separates them.
-    (test-assert "a blank line keeps them apart"
-      (emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
-
-  ;; A `;' comment is a form, so one written inside a construct with
-  ;; positional slots used to land in a slot and shift everything after
-  ;; it -- silently. In an `if' the comment became the then-arm and the
-  ;; then-arm became an `else if' condition, and it still compiled.
-  ;; Comments are now taken out of the slots and emitted just before the
-  ;; statement; comments in a body stay where they were written.
-  (test-group "comments in positional slots"
-    (test-assert "an if arm is not shifted"
-      (not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
-    (test-assert "and both arms survive"
-      (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
-    (test-assert "the comment survives too"
-      (emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
-    (test-assert "a for header is not shifted"
-      (emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
-              "for (int i = 0; i < 2; ++i)"))
-    (test-assert "a while condition is not shifted"
-      (emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
-    (test-assert "a var is not shifted"
-      (emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
-    (test-assert "a cast is not shifted"
-      (emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
-    ;; Bodies are a statement sequence, so comments there stay put.
-    (test-assert "a comment in a body stays in the body"
-      (emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
-              "while (a < b) {"))))

tests/fmt-c-writer.module.scm

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

tests/fmt-c-writer.scm

@@ -1,159 +0,0 @@
-;;; Types
-(test-group "fmt-writer"
-
-  (test
-   '(const int)
-   (walk-type '(const int)))
-
-  (test
-   '(%array (const char) 512)
-   (walk-type '(¤ const char 512)))
-
-  (test
-   '(%array (float) 512)
-   (walk-type '(¤ (float) 512)))
-
-  (test
-   '(%array (const char) 512)
-   (walk-type '(¤ (const char) 512)))
-
-  (test
-   '(%array (const char))
-   (walk-type '(¤ const char)))
-
-  (test
-   '(%array (const char))
-   (walk-type '(¤ (const char))))
-
-  (test
-   '(%array float 8)
-   (walk-type '(¤ float 8)))
-
-  (test
-   "Pointer to const char"
-   '(const char *)
-   (walk-type '(* const char)))
-
-  (test
-   "Const pointer to const char"
-   '(const char * const)
-   (walk-type '(const * const char)))
-
-  (test
-   '(%fun void ((int) (float) (%array (struct what * const))))
-   (walk-type '(fn ((int) (float) (¤ (const * struct what))) void)))
-
-  (test
-   '(%fun void ((int) (%array float) (%array (struct what * const))))
-   (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void)))
-
-  (test
-   '(%array (%fun void ((int) (%array float) (%array (struct what * const)))))
-   (walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void))))
-
-  ;; Type convert to C
-  (test
-   '(int)
-   (type-convert-to-c '(int)))
-
-  (test
-   '(* int)
-   (type-convert-to-c '(int *)))
-
-  (test
-   '(* const int)
-   (type-convert-to-c '(const int *)))
-
-  (test
-   '(const * const char)
-   (type-convert-to-c '(const char * const)))
-
-;;; Variable defs
-  (test
-   '(%var (%array float 8) a)
-   (walk-var '(var a (¤ float 8))))
-
-  (test
-   '(%var (int *) a (& n))
-   (walk-var '(var a (* int) (& n))))
-
-  (test
-   '(%var (const int *) a (& n))
-   (walk-var '(var a (* const int) (& n))))
-
-  (test
-   '(%var (struct suc) s)
-   (walk-var '(var s (struct suc))))
-
-  (test
-   '(%var (const struct suc *) s s1)
-   (walk-var '(var s (* const struct suc) s1)))
-
-  (test
-   '(%var (const struct suc *) s s1)
-   (walk-var '(var s (* (const struct suc)) s1)))
-
-  (test
-   '(%var (struct suc) s (hoge piyo))
-   (walk-var '(var s (struct suc) (hoge piyo))))
-
-  (test
-   '(%var (struct suc *) s (hoge piyo))
-   (walk-var '(var s (* struct suc) (hoge piyo))))
-
-;;; Fn defs
-  (test
-   '(%fun void puk ((int) (%array float 8)))
-   (walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
-
-  (test
-   '(%fun int main ((int argc) ((%array (const char)) argv))
-          (return 0))
-   (walk-fn-def
-    '(fn main ((argc int) (argv (¤ const char))) int
-         (return 0))))
-  (test
-   '(%fun int quxu (((struct piq *) bar))
-          (return 0))
-   (walk-fn-def
-    '(fn quxu ((bar (* struct piq))) int
-         (return 0))))
-
-  (test
-   '(%fun int quxu (((struct piq *) bar) ((%array (struct tt *)) ploop))
-          (return 0))
-   (walk-fn-def
-    '(fn quxu ((bar (* struct piq)) (ploop (¤ * struct tt))) int
-         (return 0))))
-
-  ;; Structs
-  (test
-   '(struct no_kebab ((int a) (float f)))
-   (walk-struct '(struct no-kebab ((a int) (f float)))))
-
-  (test
-   '(struct settings ((u32 x y w h)
-                      ((%array (struct ((float r g b a))) 4) colors)))
-   (walk-struct
-    '(struct settings
-             ((x y w h u32)
-              (colors [¤ struct ((r g b a float)) 4])))))
-
-  (test
-   '(struct settings ((u32 x y w h)
-                      ((%array (struct color ((float r g b a))) 4) colors)))
-   (walk-struct
-    '(struct settings
-             ((x y w h u32)
-              (colors [¤ struct color ((r g b a float)) 4])))))
-
-  (test
-   '(struct mega_kebab ((int a)
-                        ((struct ((int year) (int month) (int day))) dob)
-                        ((%fun int ((int) (%array int))) min)))
-   (walk-struct '(struct mega-kebab
-                         ((a int)
-                          (dob (struct ((year int)
-                                        (month int)
-                                        (day int))))
-                          (min (fn ((int) (¤ int)) bool)))))))

tests/line-directives.scm

@@ -1,242 +0,0 @@
-;;; Source-line mapping.
-;;;
-;;; Every construct in the generated C must be attributed, through
-;;; #line directives, to the source line of the Sex form it came from.
-;;; That mapping is the whole basis of source-level debugging.
-;;;
-;;; It cannot be left to the C compiler's implicit line counting,
-;;; because a Sex form and its C rendering may or may not occupy the
-;;; same number of lines. A call written across four lines renders as
-;;; one C line; a one-line `for' renders as a braced block of
-;;; four. Either way every following line drifts, and the drift
-;;; accumulates over a function body.
-;;;
-;;; The tests below pin one construct per statement kind. Each carries
-;;; a unique numeric marker chosen so that it lands on the first C line
-;;; that construct emits; the marker is then located in the fixture (to
-;;; get the true source line) and in the C output (to get the line the
-;;; directives claim). The two must agree.
-
-(import (chicken port)
-        (chicken string)
-        srfi-1
-        srfi-13
-        fmt-c-writer
-        reader
-        semen
-        utils)
-
-;;; ------------------------------------------------------------------
-;;; Fixture. Line numbers are in the trailing comments; keep them
-;;; correct when editing. Markers are distinct 3-digit integers, and no
-;;; other literal in the fixture contains one as a substring.
-
-(define fixture-lines
-  '("(include stdio.h)"                   ;  1
-    ""                                    ;  2
-    "(struct pt"                          ;  3  multi-line toplevel
-    "  ((x int)"                          ;  4
-    "   (y int)))"                        ;  5
-    ""                                    ;  6
-    "(enum color (red green blue))"       ;  7
-    ""                                    ;  8
-    "(typedef byte u8)"                   ;  9
-    ""                                    ; 10
-    "(define MAXN 101)"                   ; 11
-    ""                                    ; 12
-    "(var gvar int 102)"                  ; 13
-    ""                                    ; 14
-    "(extern var evar int)"               ; 15
-    ""                                    ; 16
-    "(fn helper ((a int)) int)"           ; 17  prototype
-    ""                                    ; 18
-    "(pub fn main () int"                 ; 19
-    "  (var mvar int 103)"                ; 20
-    "  (var p (struct pt))"               ; 21
-    "  (var arr [int 4])"                 ; 22
-    "  (= (. p x) 104)"                   ; 23
-    "  (+= mvar 105)"                     ; 24
-    "  (++ mvar)"                         ; 25
-    "  (= [arr 0] 106)"                   ; 26
-    "  (putchar (+ 107"                   ; 27  form spanning 3 lines,
-    "             mvar"                   ; 28  emitted as one C line:
-    "             0))"                    ; 29  everything after drifts
-    "  (var aftercall int 108)"           ; 30
-    "  (if (< mvar 109)"                  ; 31
-    "      (putchar 110))"                ; 32
-    "  (if (< mvar 111)"                  ; 33
-    "      (putchar 112)"                 ; 34
-    "      (putchar 113))"                ; 35
-    "  (while (< mvar 114)"               ; 36
-    "    (++ mvar))"                      ; 37
-    "  (for (var i int 115)"              ; 38
-    "       (< i 116)"                    ; 39
-    "       (++ i)"                       ; 40
-    "    (continue))"                     ; 41
-    "  (switch 117"                       ; 42
-    "    (case 118"                       ; 43
-    "      (putchar 119)"                 ; 44
-    "      (break))"                      ; 45
-    "    (default"                        ; 46
-    "      (putchar 120)))"               ; 47
-    "  (do"                            ; 48
-    "    (var bvar int 121)"              ; 49
-    "    (putchar bvar))"                 ; 50
-    "  (goto done)"                       ; 51
-    "  (: done)"                          ; 52
-    "  (var svar u64 (sizeof (struct pt)))" ; 53
-    "  (var cvar int (cast mvar int))"    ; 54
-    "  (return 122))"                     ; 55
-    ))
-
-(define fixture (string-intersperse fixture-lines "\n"))
-
-;;; ------------------------------------------------------------------
-;;; Pipeline and #line accounting
-
-(define (compile-to-c source)
-  "Run reader -> semen -> writer on SOURCE, returning the generated C.
-parse-all is called directly rather than through read-raw-forms so the
-fixture can be given a file name: a location is (file . line), and the
-file is what makes an imported module report itself rather than the unit
-that imported it."
-  (let ((forms (with-input-from-string source
-                 (lambda ()
-                   (parameterize ((current-source-file "fixture.sex"))
-                     (parse-all (current-input-port)))))))
-    (with-output-to-string
-      (lambda () (emit-c (semen-process forms))))))
-
-(define (split-lines s)
-  (let loop ((i 0) (start 0) (acc (list)))
-    (cond
-     ((= i (string-length s))
-      (reverse (if (> i start) (cons (substring s start i) acc) acc)))
-     ((char=? (string-ref s i) #\newline)
-      (loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
-     (else (loop (+ i 1) start acc)))))
-
-(define (directive-line text)
-  "The N of a `#line N \"file\"' directive, or #f if TEXT is not one."
-  (let ((t (string-trim text)))
-    (and (string-prefix? "#line " t)
-         (string->number (car (string-split (substring t 6) " "))))))
-
-(define (directive-file text)
-  "The file name of a `#line N \"file\"' directive, or #f."
-  (let ((t (string-trim text)))
-    (and (string-prefix? "#line " t)
-         (let ((parts (string-split (substring t 6) " ")))
-           (and (pair? (cdr parts)) (cadr parts))))))
-
-(define (attributed-lines c-source)
-  "Pair every non-directive C line with the source line it is
-attributed to. `#line N' says the *next* physical line is N; each line
-after that is one more. Lines before the first directive get #f."
-  (let loop ((lines (split-lines c-source)) (cur #f) (acc (list)))
-    (if (null? lines)
-        (reverse acc)
-        (cond
-         ((directive-line (car lines))
-          => (lambda (n) (loop (cdr lines) n acc)))
-         (else
-          (loop (cdr lines)
-                (and cur (+ cur 1))
-                (cons (cons (car lines) cur) acc)))))))
-
-(define (sex-line token)
-  "1-based fixture line containing TOKEN."
-  (let loop ((lines fixture-lines) (n 1))
-    (cond ((null? lines) #f)
-          ((string-contains (car lines) token) n)
-          (else (loop (cdr lines) (+ n 1))))))
-
-(define (claimed-line attributed token)
-  "The source line the generated C attributes TOKEN to."
-  (let ((hit (find (lambda (p) (string-contains (car p) token)) attributed)))
-    (and hit (cdr hit))))
-
-;;; ------------------------------------------------------------------
-
-(define c-out (compile-to-c fixture))
-(define attributed (attributed-lines c-out))
-
-;;; MAPS checks a construct found under the same token on both sides.
-;;; MAPS/TOKENS is for constructs that are spelled differently in Sex
-;;; and in C (`(break)' -> `break;', `(: done)' -> `done:').
-(define-syntax maps
-  (syntax-rules ()
-    ((maps name token)
-     (test name (sex-line token) (claimed-line attributed token)))))
-
-(define-syntax maps/tokens
-  (syntax-rules ()
-    ((maps/tokens name sex-token c-token)
-     (test name (sex-line sex-token) (claimed-line attributed c-token)))))
-
-(test-group "line-directives"
-
-  ;; Toplevel forms
-  (test-group "toplevel"
-    (maps/tokens "include"        "(include stdio.h)" "#include")
-    (maps/tokens "struct"         "(struct pt"        "struct pt {")
-    (maps/tokens "enum"           "(enum color"       "enum color {")
-    (maps/tokens "typedef"        "(typedef byte u8)" "typedef u8 byte;")
-    (maps         "define"        "101")
-    (maps         "global var"    "102")
-    (maps/tokens "extern var"     "(extern var evar" "extern int evar")
-    (maps/tokens "prototype"      "(fn helper"       "int helper (int a)")
-    (maps/tokens "function"       "(pub fn main"     "int main (void)"))
-
-  ;; Declarations and expression statements
-  (test-group "statements"
-    (maps "var decl"              "103")
-    (maps "member assignment"     "104")
-    (maps "compound assignment"   "105")
-    (maps/tokens "increment"      "(++ mvar)" "++mvar;")
-    (maps "array assignment"      "106")
-
-    ;; The point of the whole exercise: a call spread over three source
-    ;; lines collapses to one C line, so the statement after it must be
-    ;; re-anchored or it is reported two lines too early. The call
-    ;; itself anchors to the line it *starts* on, which is where a
-    ;; debugger should report it.
-    (maps "multi-line call"       "107")
-    (maps "statement after it"    "108"))
-
-  ;; Control flow
-  (test-group "control flow"
-    (maps "if"                    "109")
-    (maps "if body"               "110")
-    (maps "if/else"               "111")
-    (maps "then branch"           "112")
-    (maps "else branch"           "113")
-    (maps "while"                 "114")
-    (maps "for"                   "115")
-    (maps/tokens "continue"       "(continue)" "continue;")
-    (maps "switch"                "117")
-    ;; The `case 118:' label line itself is deliberately not pinned.
-    ;; c-switch requires every clause to be a case/default form and
-    ;; rejects anything else, so no anchor can be placed between
-    ;; clauses. The clause *bodies* are anchored from inside, which is
-    ;; what matters -- a label is not a statement a debugger stops on.
-    (maps "case body"             "119")
-    (maps/tokens "break"          "(break)" "break;")
-    (maps "default body"          "120")
-    (maps "block"                 "121")
-    (maps/tokens "goto"           "(goto done)" "goto done;")
-    (maps/tokens "label"          "(: done)"    "done:")
-    (maps "return"                "122"))
-
-  ;; Expressions that are their own statement
-  (test-group "expressions"
-    (maps/tokens "sizeof" "(var svar" "sizeof")
-    (maps/tokens "cast"   "(var cvar" "(int)mvar"))
-
-  ;; A location is (file . line); every directive must name the file the
-  ;; form was read from.
-  (test-group "file name"
-    (test "every directive names the fixture"
-          (list "\"fixture.sex\"")
-          (delete-duplicates
-           (filter values (map directive-file (split-lines c-out)))))))

tests/reader.module.scm

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

tests/reader.scm

@@ -1,41 +0,0 @@
-(import (chicken port)
-        reader)
-
-(define-syntax reader-test
-  (syntax-rules ()
-    ((reader-test result string)
-     (test result
-           (with-input-from-string string
-             (lambda () (read-raw-forms 'stdin)))))))
-
-(test-group "reader"
-  ;; []-syntax. For array types and array access expressions
-  (reader-test '((¤ * char)) "[* char]")
-  (reader-test '((¤ * * char const 512)) "[* * char const 512]")
-  (reader-test '((¤)) "[]")
-  (reader-test '((¤ (¤))) "[[]]")
-  (reader-test '((¤ (¤ const char))) "[[const char]]")
-
-  ;; leading `.' becomes the dot-access operator
-  (reader-test '((dot-access obj field)) "(. obj field)")
-  (reader-test '((dot-access obj method a b)) "(. obj method a b)")
-  (reader-test '((dot-access a b)) "(.  a  b)")
-  ;; nested leading dot
-  (reader-test '((foo (dot-access a b))) "(foo (. a b))")
-
-  ;; dotted pairs are preserved (only a *leading* dot is special)
-  (reader-test '((a . b)) "(a . b)")
-  (reader-test '((a b . c)) "(a b . c)")
-  (reader-test '((quote (a . b))) "'(a . b)")
-  ;; a `.'-prefixed symbol is an ordinary symbol, not dot-access
-  (reader-test '((.field obj)) "(.field obj)")
-
-  ;; `;' comments are preserved as (comment "...") forms
-  (reader-test '((comment " hi")) "; hi")
-  (reader-test '((comment ";; Prototypes")) ";;; Prototypes")
-  (reader-test '((foo (comment " c") bar)) "(foo ; c\n bar)")
-  ;; a trailing top-level comment is its own form
-  (reader-test '((a b) (comment " t")) "(a b) ; t")
-  ;; a `;' inside a string is not a comment
-  (reader-test '("a;b") "\"a;b\"")
-)

tests/run.scm

@@ -1,14 +0,0 @@
-(import
-  test)
-
-(include "basic.scm")
-(include "semen.scm")
-(include "reader.scm")
-(include "fmt-c-writer.scm")
-(include "utils.scm")
-(include "line-directives.scm")
-(include "codegen.scm")
-(include "args.scm")
-
-;;; Should be the last in the test suite
-(test-exit)

tests/semen.module.scm

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

tests/semen.scm

@@ -1,57 +0,0 @@
-(import srfi-69
-        semen)
-
-(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-group "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
-
-  (define (form-identity form env)
-    form)
-
-  (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 (macro-expand 'a))
-  (test '(a b c) (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))))

tests/sex-macros.module.scm

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

tests/sex-modules.module.scm

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

tests/sex-programs/comments.sex

@@ -1,13 +0,0 @@
-(input)
-(output "start" "end")
-(return 0)
-
-;;; A top-level comment, preserved into the generated C.
-(include stdio.h)
-
-;; Another top-level comment, right before the function.
-(pub fn main () int
-  ;; a comment in statement position
-  (puts "start")
-  (puts "end") ; a trailing comment after a statement
-  (return 0))

tests/sex-programs/hello-world.sex

@@ -1,13 +0,0 @@
-(input "Sextest")
-(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
-(return 255)
-
-(include stdio.h)
-
-(pub fn main ((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))

tests/sex-programs/list-macros.sex

@@ -1,48 +0,0 @@
-(pub defmacro (list-T type)
-  (let ((list-type (cat 'list- type)))
-    `(struct ,list-type
-       ((value ,type)
-        (next (* struct ,list-type))))))
-
-(pub defmacro (make-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'make-list- type)))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
-      (var list (* ,list-type) (cast  (malloc (sizeof ,list-type)) (* ,list-type)))
-      (= (-> list next) NULL)
-      (return list))))
-
-(pub defmacro (add-value-list-T type is-public?)
-  (let ((list-type (list 'struct (cat 'list- type)))
-        (fn-name (cat 'add-value-list- type)))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
-      (while (!= (-> list next) NULL)
-        (= list (-> list next)))
-      (= (-> list next) (,(cat 'make-list- type)))
-      (= (-> list value) value))))
-
-(pub defmacro (length-list-T type is-public?)
-  (let ((fn-name (cat 'length-list- type))
-        (list-type (list 'struct (cat 'list- type))))
-    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
-      (var n size-t 0)
-      (while (!= (-> list next) NULL)
-        (= list (-> list next))
-        (++ n))
-      (return n))))
-
-(pub defmacro (is-empty-list-T type is-public?)
-  `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
-    ((list ,(list '* 'struct (cat 'list- type))))
-    bool
-    (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)))
-    `(do
-      (var ,list-var-2 (* ,list-type) ,list-var)
-      (var ,elt-var ,elt-type (-> ,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))))))

tests/sex-programs/lists.sex

@@ -1,50 +0,0 @@
-(input)
-(output "Size of the list: 0"
-        "Size of the list: 2"
-        "3 4 "
-        "Size of the list: 2")
-(return 0)
-
-(include stdlib.h)
-(include stddef.h)
-(include stdio.h)
-
-(import list-macros)
-
-(struct foo
-  ((a-field float)
-   (b int)
-   (c (* const char))
-   (not (fn ((val bool)) bool))))
-
-(var f (struct foo))
-
-(list-T int)
-(make-list-T int #f)
-(add-value-list-T int #f)
-(length-list-T int #f)
-(is-empty-list-T int #f)
-
-(extern fn puk ((a int) (b float)) void)
-(pub fn baz () bool
-  (return true))
-
-(extern var i int)
-(var j int)
-(pub var k int)
-
-(pub fn main () int
-     (var l (* struct list-int) (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 (struct list-int) l int v
-       (printf "%d " v))
-     (printf "\n")
-     (printf "Size of the list: %lu\n" (length-list-int l))
-     (return 0))
-
-(pub fn print-list ((l (* const struct list-int))) void
-     (list-for-each (const struct list-int) l int v (printf "%d " v))
-     (printf "\n"))

tests/sex-programs/unicode.sex

@@ -1,24 +0,0 @@
-(input)
-(output "café 日本語 🍺" "café1" "naïve: 3")
-(return 0)
-
-;;; Non-ASCII string literals and identifiers.
-;;;
-;;; Two things are pinned here. First, a character outside printable
-;;; ASCII must reach the C compiler as the UTF-8 bytes it was written
-;;; as. Octal escapes are used because C's \x escape swallows every
-;;; following hex digit: "café1" is the case that catches it, since a
-;;; hex escape would run "\xc3\xa9" into the "1" and produce a value out
-;;; of range for a char. Second, a kebab-case identifier containing
-;;; non-ASCII characters must survive unkebabify intact -- getting this
-;;; wrong truncates the name silently, and the program still compiles
-;;; and runs, just under a different name than the one written.
-
-(include stdio.h)
-
-(pub fn main () int
-  (puts "café 日本語 🍺")
-  (puts "café1")
-  (var naïve-count int 3)
-  (printf "naïve: %d\n" naïve-count)
-  (return 0))

tests/sexc.module.scm

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

tests/utils.module.scm

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

tests/utils.scm

@@ -1,24 +0,0 @@
-(import utils)
-
-(test-group "utils"
-
-  (test
-   '((1) (2) (3))
-   (list-split '(1 * 2 * 3) '*))
-
-  (test
-   '((1 2 3))
-   (list-split '(1 2 3) '*))
-
-  (test
-   '(() (1) (2) (3) ())
-   (list-split '(* 1 * 2 * 3 *) '*))
-
-  (test
-   '((const) (const struct something))
-   (list-split '(const * const struct something) '*))
-
-  (test
-   '(1 * 2 * 3)
-   (list-join '(1 2 3) '*))
-)

tools/sextest/Makefile

@@ -1,23 +0,0 @@
-CHICKEN_C = csc
-CSC_FLAGS += -K prefix -static
-MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
-
-ROOT = ../..
-
-# sextest reuses sexc's reader (and its utils dependency) instead of
-# duplicating the S-expression reader. The module wrappers here include
-# the shared sources from the project root.
-
-sextest: sextest.scm reader.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest -link reader,utils
-
-utils.o: utils.module.scm $(ROOT)/utils.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
-
-reader.o: reader.module.scm $(ROOT)/reader.scm utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
-
-clean:
-	rm -f *.o *.import.scm *.link sextest
-
-.PHONY: clean

tools/sextest/README.org

@@ -1,26 +0,0 @@
-* Sextest
-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 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 "-- -O2")
-(input "")
-(output "Hello world!")
-(return 123)
-
-(include stdio.h)
-
-(pub fn main () int
-  (puts "Hello World!")
-  (return 123))
-#+end_src

tools/sextest/hello-sextest.sex

@@ -1,13 +0,0 @@
-(input "Sextest")
-(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
-(return 255)
-
-(include stdio.h)
-
-(pub fn main ((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/reader.module.scm

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

tools/sextest/sextest.scm

@@ -1,148 +0,0 @@
-(import scheme
-        brev-separate
-        (chicken base)
-        (chicken file)
-        (chicken io)
-        (chicken pathname)
-        (chicken port)
-        (chicken process)
-        (chicken process-context)
-        fmt
-        getopt-long
-        reader                          ; read-raw-forms, shared with sexc
-        srfi-1)
-
-(define (print-help)
-  (fmt #t "Usage: sextest [options] filename" nl
-       "Options:" nl
-       (usage opts-grammar) nl))
-
-(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 sexc)
-  (let ((compiler (or
-                   (and sexc (cdr sexc))
-                   (get-environment-variable "SEXC")
-                   "sexc"))
-        (compiled-file (create-temporary-file)))
-    ;; `process' returns one record; `process-input-port' is named from
-    ;; the child's side, so it is the port we write to.
-    (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
-           (sexc-stdin (process-input-port proc)))
-      (with-output-to-port sexc-stdin
-        (fn (map (fn (fmt #t x)) src)))
-      (close-output-port sexc-stdin)
-      (call-with-values
-          (fn (process-wait proc))
-        (lambda (pid exited retcode)
-          (if (= 0 retcode)
-              compiled-file
-              #f))))))
-
-(define (run-and-check file in out ret)
-  (let* ((proc (process file))
-         (out-port (process-output-port proc))   ; the program's stdout
-         (in-port  (process-input-port proc)))   ; the program's stdin
-    (let ()
-      (when in
-        (with-output-to-port in-port
-          (fn (map (fn (fmt #t x))
-                   (cdr in))))
-        (close-output-port in-port))
-      (let ((out-lines
-             (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)))))))
-            (ret-code
-             (call-with-values
-                 ;; TODO: what if the program hangs
-                 ;; we need some kind of timeout mechanism
-                 (fn
-                  (process-wait proc))
-               (lambda (pid exited retcode)
-                 retcode))))
-        (and
-         (if (not (= ret-code (cadr ret)))
-             (begin
-               (fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
-               #f)
-             #t)
-
-         (if (not (equal? out-lines (cdr out)))
-             (begin
-               (fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
-               #f)
-             #t))))))
-
-(define opts-grammar
-  `((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
-                (pad 26) "environment variable, ot if it's empty, to sexc" nl )
-          (required #f)
-          (value #t))
-    (help "Show this help"
-          (required #f)
-          (value #f)
-          (single-char #\h))))
-
-(define (process-test-file sexc path)
-  (set-environment-variable! "SEX_MODULE_PATH"
-                             (normalize-pathname (make-absolute-pathname
-                                                  (current-directory)
-                                                  (pathname-directory path))))
-  (let* ((settings-and-src (process-file path))
-         (settings (car settings-and-src))
-         (src (cdr settings-and-src))
-         (compiled-file (compile src (assoc 'compile settings) sexc)))
-    (if (not compiled-file)
-        (begin (fmt #t "Failed to compile " path nl)
-               #f)
-        (if (run-and-check
-             compiled-file
-             (assoc 'input settings)
-             (assoc 'output settings)
-             (assoc 'return settings))
-            (begin (fmt #t ".")
-                   #t)
-            (begin (fmt #t ",")
-                   #f)))))
-
-(define (main)
-  (let ((args (getopt-long (command-line-arguments)
-                           opts-grammar)))
-    (when (assoc 'help args)
-      (print-help)
-      (exit 0))
-    (when (null? (cdr (assoc '@ args)))
-      (fmt #t "Missing target file" nl)
-      (print-help)
-      (exit 1))
-    (unless
-        (foldl (lambda (a b) (and a b))
-               #t
-               (map (fn (process-test-file (assoc 'sexc args) x))
-                    (cdr (assoc '@ args))))
-      ;; TODO: add more verbose and human readable output and reporting
-      (fmt #t nl)
-      (exit 2))
-    (fmt #t nl)
-    (exit 0)))
-
-(main)

tools/sextest/utils.module.scm

@@ -1,17 +0,0 @@
-(module utils
-    (get-env-var
-     set-working-directory
-     to-absolute-pathname
-     list-split
-     list-join
-     recons
-     current-source-file
-     set-form-source!
-     form-source
-     form-file
-     form-line
-     copy-form-source!
-     stamp-form-source!
-     with-directory
-     )
-  "../../utils.scm")

utils.module.scm

@@ -1,17 +0,0 @@
-(module utils
-    (get-env-var
-     set-working-directory
-     to-absolute-pathname
-     list-split
-     list-join
-     recons
-     current-source-file
-     set-form-source!
-     form-source
-     form-file
-     form-line
-     copy-form-source!
-     stamp-form-source!
-     with-directory
-     )
-  "utils.scm")

utils.scm

@@ -1,117 +0,0 @@
-(import
-  scheme
-  (scheme base)                         ; make-parameter
-  (chicken base)
-  (chicken pathname)
-  (chicken process-context)
-  srfi-1
-  srfi-69)
-
-(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 (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
-      (make-absolute-pathname
-       (current-directory)
-       pathname)))
-
-(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
-      ;; A rebuilt cell is still the same source form, so it keeps the
-      ;; same location
-      (copy-form-source! old-cons (cons new-car new-cdr))))
-
-;;; Source-location map.
-;;; Our hand-written reader records the source location of each form
-;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's
-;;; read-with-source-info / get-line-number, which only works when forms
-;;; are produced by the built-in `read'.
-;;;
-;;; A location is (file . line). The file matters because imported
-;;; modules paste their public forms into the current unit: those forms
-;;; originate in another file and must be reported as such
-(define +form-sources+ (make-hash-table eq?))
-
-;;; The file `parse-all' is currently reading. Bound by the reader
-(define current-source-file (make-parameter "<unknown>"))
-
-(define (set-form-source! form file line)
-  (hash-table-set! +form-sources+ form (cons file line)))
-
-(define (form-source form)
-  (hash-table-ref/default +form-sources+ form #f))
-
-(define (form-file form)
-  (let ((src (form-source form)))
-    (and src (car src))))
-
-(define (form-line form)
-  (let ((src (form-source form)))
-    (and src (cdr src))))
-
-(define (copy-form-source! from to)
-  "Give TO the location of FROM, if FROM has one. Returns TO, so it can
-wrap a form-building expression."
-  (let ((src (form-source from)))
-    (when (and src (pair? to))
-      (hash-table-set! +form-sources+ to src)))
-  to)
-
-(define (stamp-form-source! form src)
-  "Give FORM and every subform that has none the location SRC. Used for
-macro expansions, which inherit the location of the call site the way a
-cpp macro does. Forms that already have a location keep it."
-  (when (and src (pair? form))
-    (unless (form-source form)
-      (hash-table-set! +form-sources+ form src))
-    (stamp-form-source! (car form) src)
-    (stamp-form-source! (cdr form) src))
-  form)