implement new macro system

Makefile

@@ -1,6 +1,6 @@
 CHICKEN_C = csc
 
-MODULES = sexc modules templates utils fmt-c
+MODULES = sexc sex-macros sex-modules utils fmt-c
 OBJ = $(MODULES:%=%.o)
 
 sexc: main.o $(OBJ)
@@ -9,9 +9,6 @@ sexc: main.o $(OBJ)
 main.o: main.scm
 	$(CHICKEN_C) $< -c -o $@
 
-templates.o: templates.scm
-	$(CHICKEN_C) $< -c -o $@ -compile-syntax
-
 %.o: %.scm
 	$(CHICKEN_C) $< -e -c -o $@
 

Readme.org

@@ -87,124 +87,51 @@ being compiled location, and the second is ~SEX_MODULE_PATH~
 environment variable.
 
 Module's public interface consists of everything declared
-~pub~. Structures, function, templates, types, variables can be
+~pub~. Structures, function, macros, types, variables can be
 public.
 
-** Syntactic templates
+** Syntactic macros
-Sex has support for template substitutions. Any piece of code can be
+Sex has support for syntactic macros. Macro definitions look like
-templated. Template declarations look like functions: they have a
+functions: they have a name, an argument list and a body. Macro should
-name, an argument list and a body. When declared template is
+return Sex code.
-encountered during reading of Sex code, its body will undergo 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)
+(pub defmacro (list-T type)
-  (struct foo-?T
+  (let ((list-type (cat 'list- type)))
-    ((?T value))))
+    `(struct ,list-type
+       ((,type value)
+        ((* ,list-type) next)))))
 
-(foo float)
+(list-T int)
 #+end_src
 ->
 #+begin_src
-typedef struct foo_float foo_float;
+(struct list_int
-
+ ((int value)
-struct foo_float {
+  ((* list_int) next)))
-    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)
+(pub defmacro (check-sdl-return call message ret-code)
-  (if (< 0 call)
+  `((if (< 0 ,call)
         (begin
-       (puts message)
+         (puts ,message)
-       (return ret-code))))
+         (return ,ret-code)))))
 
-(fn int init ()
+(pub fn int init ()
   (check-sdl-return
     (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
 ...)
 #+end_src
 ->
 #+begin_src
-static int init () {
+(%fun int init ()
-    if (0 < SDL_Init(SDL_INIT_VIDEO)) {
+  (if (< 0 (SDL_Init SDL_INIT_VIDEO))
-        puts("Failed to initialize SDL");
+    (%begin (puts "Failed to initialize SDL") (return 1)))
-        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
 
@@ -218,7 +145,7 @@ To harness the power of sex-mode, add the following lines to your
 #+begin_src
 (use-package sex-mode
   :load-path "/path/to/sex"
-  :mode ("\\.sex\\'" "\\.seh\\'"))
+  :mode ("\\.sex\\'"))
 #+end_src
 
 ** COMING SOON?: Polymorphism

example/list.sex

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

example/test-list.sex

@@ -25,7 +25,7 @@
 (is-empty-list-T int #f)
 
 (extern fn void puk ((int a) (float b)))
-(fn int bar () ,(imports-test 10 20 30))
+(fn int bar () (return ,(imports-test 10 20 30)))
 (pub fn void baz () true)
 
 (extern var int i)
@@ -43,7 +43,7 @@
      (printf "\n")
      (printf "Size of the list: %zu\n" (length-list-int l))
      (printf "%p\n" l->next)
-     0)
+     (return 0))
 
 (pub fn void print-list (((const list-int) *l))
      (list-for-each (const list-int) l int v (printf "%d " v))

sex-macros.scm

@@ -0,0 +1,30 @@
+(declare (unit sex-macros))
+
+(import
+  (chicken plist)
+  (chicken string))
+
+(define (cat-syms s-1 s-2)
+  (import fmt)
+  (fmt #f s-1 s-2))
+
+(define (cat sym-1 sym-2)
+  (string->symbol (cat-syms sym-1 sym-2)))
+
+(define (register-macro name arglist body)
+  (put! name 'sex-macro
+        `(lambda ,arglist
+           ,@body)))
+
+(define (get-macro name)
+  (eval (get name 'sex-macro)))
+
+(define (macro? form)
+  (and (list? form)
+       (symbol? (car form))
+       (get (car form) 'sex-macro)))
+
+(define (defmacro form)
+  (let ((arglist (car form))
+        (body (cdr form)))
+    (register-macro (car arglist) (cdr arglist) body)))

sex-mode.el

@@ -33,13 +33,13 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
                                  "chicken-import"
                                  "chicken-load"
                                  "define"
+                                 "defmacro"
                                  "extern"
                                  "import"
                                  "include"
                                  "fn"
                                  "pub"
                                  "struct"
-                                 "template"
                                  "var"
                                  "union")
                                'word)
@@ -78,7 +78,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
 
 (put 'fn 'lisp-indent-function 'defun)
 (put 'pub 'lisp-indent-function 'defun)
-(put 'template 'lisp-indent-function 'defun)
+(put 'defmacro 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
 (put 'import 'lisp-indent-function 1)

sex-modules.scm

@@ -71,7 +71,7 @@
         ;; fn type name (arg-list) (body)
         ;; 1    2   3       4 - we need first 4
         (cons (take (cdr form) 4) acc))
-       ((define import include struct template typedef union var)
+       ((define defmacro import include struct typedef union var)
         (cons (cdr form) acc))
        (else (error "Pub what? " (cadr form)))))
     (else acc)))

sexc.scm

@@ -1,7 +1,7 @@
 (declare (unit sexc)
-         (uses sex-modules
+         (uses fmt-c
-               fmt-c
+               sex-macros
-               templates))
+               sex-modules))
 
 (include "utils.macros.scm")
 
@@ -54,6 +54,8 @@
    (string->symbol
     (fmt #f (cadr form) (car form)))))
 
+(require-library chicken-syntax)
+
 (define (walk-generic form acc)
   (cond
    ((null? form) (cons '() acc))
@@ -82,12 +84,12 @@
          (char=? #\. (string-ref (symbol->string (car form)) 0)))
     (cons (make-field-access form) acc))
 
-   ;; another special case - template
+   ;; another special case - macro
-   ((template? form)
+   ((macro? form)
     (append (fold-right
              walk-generic
              (list)
-             (eval form))
+             (apply (get-macro (car form)) (cdr form)))
             acc))
 
    ;; toplevel, or a start of a regular list form
@@ -138,22 +140,18 @@
      (walk-function form #f acc))
     ((var)
      (append (walk-generic (list 'static (cdr form)) (list)) acc))
-    ((define import include struct template typedef union var)
+    ((define defmacro import include struct typedef union var)
      ;; ignore here, used in generating public interface
      (process-form (cdr form) acc))
-    (else (error "Pub what?" (cadr form)))))
+    (else
-
+     (error "Pub what?" (cadr form)))))
-(define (template? form)
-  (and (list? form)
-       (symbol? (car form))
-       (get (car form) 'sex-template)))
 
 (define (walk-sex-tree form acc)
   (if (list? form)
-      (if (template? form)
+      (if (macro? form)
           (fold-right (fn (walk-sex-tree x y))
                       acc
-                      (eval form))
+                      (list (apply (get-macro (car form)) (cdr form))))
           (case (car form)
             ((fn) (walk-function form #t acc))
             ((extern) (walk-extern form acc))
@@ -169,7 +167,7 @@
 (define (process-form form acc)
   (case (car form)
     ((chicken-define) (eval (cons 'define (cdr form))) acc)
-    ((template) (eval form) acc)
+    ((defmacro) (defmacro (cdr form)) acc)
     ((chicken-load)
      (load (cadr form)) acc)
     ((chicken-import)

templates.scm

@@ -1,66 +0,0 @@
-(declare (unit templates))
-
-(import
-  brev-separate
-  (chicken plist)
-  fmt
-  regex
-  srfi-1                                ; list routines
-  tree)
-
-(define (register-template name)
-  (put! name 'sex-template #t))
-
-(define-syntax template
-  (syntax-rules ()
-    ((template (name . args) . body)
-     (begin
-       (register-template 'name)
-       (define-syntax name
-         (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.
-  ;; 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 "([^\\-]?)"
-                                   (regexp-escape (symbol->string (car x)))
-                                   "([\\-$]?)")
-                              (fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
-                             x))
-                        (filter (fn (symbol? (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))