Make Sex templates more pleasant syntactically

No more unquotes to instantiate templates.
Also no need to pass quoted substitution lists, just use them as
regular lisp macros.

Readme.org

@@ -74,10 +74,151 @@ ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
 ** Auto typedef for structs
-Probably harmless idk.
+Probably harmless idk. Example:
+#+begin_src
+(struct foo
+  ((float a)
+   (int b)))
+#+end_src
+expands to
+#+begin_src
+typedef struct foo foo;
+
+struct foo {
+    float a;
+    int b;
+};
+#+end_src
+
+** Syntactic templates
+Sex has support for template substitutions. Any piece of code can be
+templated. Template declarations look like functions: they have a
+name, an argument list and a body. When declared template is
+encountered during reading of Sex code, its body will udergo syntactic
+rewriting using the provided values by the following rules:
+1. If the value is a symbol, all arguments in a body are replaced with
+   the value, and also all /parts/ of any other symbol equal to the
+   value also get replaced.
+2. If the value is a non-symbolic form, all arguments in a body are
+   replaced with it, but no symbolic substitution is performed.
+
+Formally, template declaration has the following syntax:
+#+begin_src
+(template (name . substitute-args) . body)
+#+end_src
+
+*** Examples:
+**** Structure with templated value type
+#+begin_src
+(template (foo ?T)
+  (struct foo-?T
+    ((?T value))))
+
+(foo float)
+#+end_src
+->
+#+begin_src
+typedef struct foo_float foo_float;
+
+struct foo_float {
+    float value;
+};
+#+end_src
+
+Note that ~?~ at the start of template argument is not syntax, just
+convention.
+
+**** Wrapper for checking return codes
+#+begin_src
+(template (check-sdl-return call message ret-code)
+  (if (< 0 call)
+      (begin
+       (puts message)
+       (return ret-code))))
+
+(fn int init ()
+  (check-sdl-return
+    (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
+...)
+#+end_src
+->
+#+begin_src
+static int init () {
+    if (0 < SDL_Init(SDL_INIT_VIDEO)) {
+        puts("Failed to initialize SDL");
+        return 1;
+    }
+    return 0;
+}
+#+end_src
+
+**** A bit of everything
+#+begin_src
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
+     (printf "\n"))
+#+end_src
+Then will be expanded in the following code:
+#+begin_src
+(typedef struct list_int list_int)
+(struct list_int ((int value) ((* list_int) next)))
+(%fun void
+      print_list
+      (((const list_int) *l))
+      (%var int v (-> l value))
+      (while (!= (-> l next) NULL)
+             (printf "%d " v)
+             (= l (-> l next))
+             (= v (-> l value)))
+      (printf "\n"))
+#+end_src
+
+And then translated to:
+#+begin_src
+typedef struct list_int list_int;
+
+struct list_int {
+    int value;
+    list_int *next;
+};
+
+void print_list (const list_int *l) {
+    int v = l->value;
+    while (l->next != NULL) {
+        printf("%d ", v);
+        l = l->next;
+        v = l->value;
+    }
+    printf("\n");
+}
+#+end_src
 
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
 best option.
 
-** COMING SOON: Polymorhpism
+*** sex-mode.el
+To harness the power of sex-mode, add the following lines to your
+~$HOME/.config/emacs/init.el~:
+#+begin_src
+(use-package sex-mode
+  :load-path "/path/to/sex"
+  :mode ("\\.sex\\'" "\\.seh\\'"))
+#+end_src
+
+** COMING SOON?: Polymorphism

example/list.seh

@@ -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 list-var elt-var what-do)
+  (var int elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    what-do
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))

example/test-list.sex

@@ -0,0 +1,69 @@
+(include stdlib.h)
+(include stddef.h)
+(include stdbool.h)
+(include stdio.h)
+
+(chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
+
+(chicken-load "list.seh")
+
+(chicken-define (imports-test a b c)
+  (fold + 0 (list 1 2 3 a b c)))
+
+(struct foo
+  ((float a-field)
+   (int b)
+   ((const char *) c)
+   ((fn bool ((bool val))) not)))
+
+(var foo f #((= .a-field 1.2)))
+
+(list-T int)
+(make-list-T int)
+(add-value-list-T int)
+(length-list-T int)
+(is-empty-list-T int)
+
+(extern fn void puk ((int a) (float b)))
+(fn int bar () ,(imports-test 10 20 30))
+(pub fn void baz () true)
+
+(extern var int i)
+(var int j)
+(pub var int k)
+
+(pub fn int main ()
+     (var (* list-int) l (make-list-int))
+     (printf "Size of the list: %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 l v
+       (printf "%d " v))
+     (printf "\n")
+     (printf "%zu\n" l->next)
+     0)
+
+(pub fn segs-renderer* create-renderer ())
+(pub fn void clear-command-buffer ((segs-renderer *r)))
+(pub fn void add-render-command ((segs-renderer *r) ((fn void ()) command)))
+(pub fn void commit-command-buffer ((segs-renderer *r)))
+
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
+     (printf "\n"))

lib/list.hsex

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

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

sex-mode.el

@@ -28,12 +28,19 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
     (list
      ;; Declarations
      (list (concat "("
-                   (regexp-opt '("include"
+                   (regexp-opt '("chicken-define"
+                                 "chicken-define-syntax"
+                                 "chicken-import"
+                                 "chicken-load"
+                                 "define"
+                                 "extern"
+                                 "include"
                                  "fn"
                                  "pub"
                                  "struct"
                                  "template"
-                                 "var")
+                                 "var"
+                                 "union")
                                'word)
                    "\\>"
                    "[[:space:]]*"

sexc.scm

@@ -3,12 +3,14 @@
 
 (import brev-separate
         (chicken pathname)
+        (chicken plist)
         (chicken pretty-print)
         (chicken process-context)
         (chicken string)
         fmt
         fmt-c
         getopt-long
+        regex
         srfi-1                          ; list routines
         tree)
 
@@ -22,13 +24,16 @@
     ((-=) sym)
     (else
      (string->symbol
-      (string-translate (symbol->string sym) #\- #\_)))))
+      (string-substitute "-(?!>)" "_"
+                         (symbol->string sym) #t)))))
 
 (define (atom-to-fmt-c atom)
   (case atom
     ((fn) '%fun)
+    ((prototype) '%prototype)
     ((var) '%var)
     ((begin) '%begin)
+    ((define) '%define)
     ((pointer) '%pointer)
     ((array) '%array)
     ((@) 'vector-ref)
@@ -45,57 +50,137 @@
              (eq? (car node) symbol))
         #f)))
 
+(define (make-field-access form)
+  (assert (= 2 (length form)) "Wrong field access format")
+  (unkebabify
+   (string->symbol
+    (fmt #f (cadr form) (car form)))))
+
 (define (walk-generic form acc)
-  (if (eq? (car form) 'unquote)
+  (cond
-      ;; special case - replace top-level unquote with it's expansion
+   ((null? form) (cons '() acc))
-      (append
+
-       (fold append (list)
+   ;; vector, e.g. {}-initializer
-             (map (fn (walk-sex-tree x (list)))
+   ((vector? form)
-                  (eval (cadr form))))
+    (cons
-       acc)
+     (list->vector
-      (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f)))
+      (car (walk-sex-tree (vector->list form) (list))))
-        (if unquote-form
+     acc))
-            (begin
+
-              (let* ((inv (invert-tree form))
+   ;; atom (hopefully)
-                     (pos (tree-local-position inv unquote-form)))
+   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
-                (for-each (fn
+
-                           (set! form (tree-insert inv (tree-parent inv unquote-form) pos x))
+   ;; special case - replace unquote with its expansion
-                           (set! inv (invert-tree form)))
+   ((eq? (car form) 'unquote)
-                          (reverse (eval (cadr unquote-form))))
+    (fold
-                (set! form (tree-prune inv unquote-form)))
+     cons
-              (loop (tree-find (tree-finder 'unquote)
+     acc
-                               form
+     (car                               ; bc walk-sex-tree always
-                               #f)))
+                                        ; wraps its result
-            (cons (tree-map atom-to-fmt-c form) acc)))))
+      (walk-sex-tree (eval (cadr form)) (list)))))
+
+   ;; another special case - field access
+   ((and (symbol? (car form))
+         (char=? #\. (string-ref (symbol->string (car form)) 0)))
+    (cons (make-field-access form) acc))
+
+   ;; another special case - template
+   ((template? form)
+    (append (fold
+             walk-generic
+             (list)
+             (eval form))
+            acc))
+
+   ;; toplevel, or a start of a regular list form
+   (else
+    (let ((new-acc (list)))
+      (cons (reverse
+             (fold
+              walk-generic
+              new-acc
+              form))
+            acc)))))
+
+(define (normalize-fn-form form)
+  ;; (fn ret-type name arglist body) -> normal function
+  ;; (fn ret-type name arglist) -> prototype
+  (if (>= (length form) 5)
+      form
+      (cons 'prototype (cdr form))))
 
 (define (walk-function form static acc)
   (if static
-      (walk-generic (list 'static form) acc)
+      (append (walk-generic (list 'static (normalize-fn-form form))
-      (walk-generic (cdr form) acc)))
+                            (list))
+              acc)
+      (append (walk-generic (normalize-fn-form (cdr form))
+                            (list))
+              acc)))
 
 (define (walk-struct form acc)
   (let ((name (unkebabify (cadr form))))
-    (walk-generic form (cons `(typedef struct ,name ,name) acc))))
+    (append (walk-generic form (list))
+          (cons `(typedef struct ,name ,name) acc))))
+
+(define (walk-extern form acc)
+  (case (cadr form)
+    ((fn)
+     (append
+      (list (cons 'extern (walk-function form #f (list))))
+      acc))
+    ((var)
+     (append
+      (list (cons 'extern (walk-generic (cdr form) (list))))
+      acc))
+    (else (error "Extern what?"))))
+
+(define (walk-public form acc)
+  (case (cadr form)
+    ((fn)
+     (walk-function form #f acc))
+    ((var)
+     (append (walk-generic (list 'static (cdr form)) (list)) acc))
+    (else (error "Pub what?"))))
+
+(define (template? form)
+  (and (list? form)
+       (symbol? (car form))
+       (get (car form) 'sex-template)))
 
 (define (walk-sex-tree form acc)
-  (case (car form)
+  (if (list? form)
-    ((fn) (walk-function form #t acc))
+      (if (template? form)
-    ((pub) (walk-function form #f acc))
+          (fold (fn (walk-sex-tree x y))
-    ((struct) (walk-struct form acc))
+                acc
-    (else (walk-generic form acc))))
+                (eval form))
+          (case (car form)
+            ((fn) (walk-function form #t acc))
+            ((extern) (walk-extern form acc))
+            ((pub) (walk-public form acc))
+            ((struct union) (walk-struct form acc))
+            ((unquote) (fold (fn (walk-sex-tree x y))
+                             acc
+                             (eval (cadr form))))
+            (else (append (walk-generic form (list)) acc))))
+      ;; only for unquote support
+      (list (list (atom-to-fmt-c form)))))
 
 (define (process-form form acc)
   (case (car form)
-    ((define) (eval form) acc)
+    ((chicken-define) (eval (cons 'define (cdr form))) acc)
     ((template) (eval form) acc)
-    ((load) (eval form) acc)
+    ((chicken-load)
-    ((instance) (walk-sex-tree (eval form) acc))
+     (load (cadr form)) acc)
+    ((chicken-import)
+     (eval (cons 'import (cdr form))) acc)
     (else
      (walk-sex-tree form acc))))
 
+
 (define (process-raw-forms raw-forms acc)
-  (if (null? raw-forms) (filter (fn (not (null? x)))
+  (if (null? raw-forms)
-                                (reverse acc))
+      (reverse acc)
       (process-raw-forms (cdr raw-forms)
                          (process-form (car raw-forms) acc))))
 

templates.scm

@@ -1,19 +1,27 @@
 (declare (unit templates))
 
-(import brev-separate
+(import
-        fmt
+  (chicken plist)
-        regex
+  brev-separate
-        srfi-1                          ; list routines
+  fmt
-        tree)
+  regex
+  srfi-1                                ; list routines
+  tree)
 
+(define (register-template name)
+  (put! name 'sex-template #t))
 
 (define-syntax template
   (syntax-rules ()
-    ((_ (name subst-list args ...) body ...)
+    ((template (name . args) . body)
-     (define (name subst-list-arg args ...)
+     (begin
-       (let* ((subst-alist (map cons 'subst-list subst-list-arg))
+       (register-template 'name)
-              (replaced-body (apply-substitution `(body ...) subst-alist)))
+       (define-syntax name
-         replaced-body)))))
+         (syntax-rules ()
+           ((name . applied-args)
+            (let* ((subst-alist (map cons 'args 'applied-args))
+                   (replaced-body (apply-substitution `body subst-alist)))
+              replaced-body))))))))
 
 (define (apply-symbol-substitution sym subst-alist)
   ;; All non-symbol substitutions will be filtered.
@@ -23,10 +31,12 @@
         (subst-map (map (fn
                          (if (symbol? (car x))
                              (cons
-                              (fmt #f "([^\\-]?)" (symbol->string (car x)) "([\\-$]?)")
+                              (fmt #f "([^\\-]?)"
+                                   (regexp-escape (symbol->string (car x)))
+                                   "([\\-$]?)")
                               (fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
                              x))
-                        (filter (fn (not (list? (cdr x)))) subst-alist))))
+                        (filter (fn (symbol? (cdr x))) subst-alist))))
     (string->symbol
      (string-substitute* str subst-map))))