implement templates (kinda)

uh oh

Makefile

@@ -1,7 +1,19 @@
 CHICKEN_C = csc
 
-sexc: sexc.scm
-	$(CHICKEN_C) $< -o $@
+MODULES = sexc templates main
+OBJ = $(MODULES:%=%.o)
+
+# chicken flags
+CFLAGS = -compile-syntax
+
+sexc: $(OBJ)
+	$(CHICKEN_C) $^ -o $@
+
+main.o: main.scm
+	$(CHICKEN_C) $< -c -o $@
+
+%.o: %.scm
+	$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
 
 clean:
 	rm -f $(OBJ) sexc

lib/list.hsex

@@ -1,3 +1,40 @@
-(template (T) struct list
-    (var T value)
-    ())
+(template (T)
+  struct list-T
+  ((T value)
+   ((list-T *) next)))
+
+(template (T)
+  pub fn (list-T *) make-list-T ()
+  (var (list-T *) list (malloc (sizeof list-T)))
+  (= (-> list next) NULL)
+  list)
+
+(template (T)
+  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 (T)
+  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 (T)
+  pub fn bool is-empty-list-T ((list-T *list))
+  (== (-> list next) NULL))
+
+(define-syntax list-for-each
+  (syntax-rules ()
+    ((_ list-var elt-var what-do ...)
+     '(begin
+        ;; todo: that int here is not good
+        (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,22 @@
+(include stdlib.h)
+(include stddef.h)
+(include stdbool.h)
+(include stdio.h)
+
+(load "list.hsex")
+
+(instance list-int list-T (int))
+(instance make-list-int make-list-T (int))
+(instance add-value-list-int add-value-list-T (int))
+(instance length-list-int length-list-T (int))
+(instance is-empty-list-int is-empty-list-T (int))
+
+(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")
+     0)

main.scm

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

sexc.scm

@@ -1,3 +1,6 @@
+(declare (unit sexc)
+         (uses templates))
+
 (import brev-separate
         (chicken pathname)
         (chicken pretty-print)
@@ -9,6 +12,8 @@
         srfi-1                          ; list routines
         tree)
 
+(define +debug+ #f)
+
 (define (unkebabify sym)
   (case sym
     ((-) sym)
@@ -75,7 +80,9 @@
 (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))))
 
@@ -167,5 +174,3 @@
                     (lambda ()
                       (emit-c sex-forms)))
                   (emit-c sex-forms)))))))
-
-(main)

templates.scm

@@ -0,0 +1,154 @@
+(declare (unit templates))
+
+(import brev-separate
+        fmt
+        regex
+        srfi-1                          ; list routines
+        tree)
+
+;;; template structure storage example:
+;;; (name (T U) ((T field-1) (U field-2))))
+;;;
+;;; template function storage example:
+;;; (name (T U) public? T-ret ((T arg-1) (U arg-2)) body)
+
+(define template-functions (list))
+(define template-structures (list))
+
+(define (template-name template)
+  (first template))
+
+(define (template-subst-list template)
+  (second template))
+
+(define (template-struct-fields template)
+  (third template))
+
+(define (template-fn-public? template)
+  (third template))
+
+(define (template-fn-return-type template)
+  (fourth template))
+
+(define (template-fn-arglist template)
+  (fifth template))
+
+(define (template-fn-body template)
+  (sixth template))
+
+(define (find-template name subst-list template-storage)
+  (find (fn (and (eq? name (template-name x))
+                 (= (length subst-list)
+                    (length (template-subst-list x)))))
+        template-storage))
+
+(define (check-template-doesnt-exist name subst-list)
+  (when (find-template
+         name subst-list
+         template-functions)
+    (error "Template function with this name and number of parameters already exists"))
+  (when (find-template
+         name subst-list
+         template-structures)
+    (error "Template structure with this name and number of parameters already exists")))
+
+(define (register-template-fn subst-list public? return-type name arg-list body)
+  (check-template-doesnt-exist name subst-list)
+  (when +debug+
+    (fmt #t (fmt-join dsp (list "Adding template fn" public? return-type name subst-list) " ") nl))
+  (set! template-functions
+    (cons (list name subst-list public? return-type arg-list body) template-functions)))
+
+(define (register-template-struct subst-list name fields)
+  (check-template-doesnt-exist name subst-list)
+  (when +debug+
+    (fmt #t (fmt-join dsp (list "Adding template structure" name subst-list fields) " ") nl))
+  (set! template-structures
+    (cons (list name subst-list fields) template-structures)))
+
+(define-syntax template
+  (syntax-rules (pub fn struct)
+    ((_ (T ...) pub fn ret-type name args body ...)
+     (register-template-fn (list 'T ...) #t 'ret-type 'name 'args (list 'body ...)))
+    ((_ (T ...) fn ret-type name args body ...)
+     (register-template-fn (list 'T ...) #f 'ret-type 'name 'args (list 'body ...)))
+    ((_ (T ...) struct name fields)
+     (register-template-struct (list 'T ...) 'name 'fields))))
+
+(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))
+
+(define (instantiate-template-fn instance-name fun subst-alist)
+  `(,@((fn (if (template-fn-public? fun) '(pub) '())))
+    fn
+    ,(apply-substitution (template-fn-return-type fun) subst-alist)
+    ,instance-name
+    ,(apply-substitution (template-fn-arglist fun) subst-alist)
+    ,@(apply-substitution (template-fn-body fun) subst-alist)))
+
+(define (instantiate-template-struct instance-name struct subst-alist)
+  (list 'struct instance-name
+        (apply-substitution (template-struct-fields struct)
+                            subst-alist)))
+
+(define (instantiate-template instance-name template subst-list)
+  (let ((struct (find-template template subst-list template-structures))
+        (fn (find-template template subst-list template-functions)))
+    (when (and struct fn)
+      (error (fmt #f "Both template structure and function are defined. Shouldn't have happened\n"
+                  "Struct: " struct nl
+                  "Fn: " fn nl)))
+    (unless (or struct fn)
+      (error (fmt #f "Template with name " template " was not found." nl
+                  "Known template fns: " (fmt-join dsp (map template-name template-functions)
+                                                   "\n                    ")
+                  nl
+                  "Known template structs: " (fmt-join dsp (map template-name template-structures)
+                                                       "\n                       "))))
+    (let ((subst-alist
+           (map cons (template-subst-list (or struct fn)) subst-list)))
+      (if struct
+          (instantiate-template-struct instance-name struct subst-alist)
+          (instantiate-template-fn instance-name fn subst-alist)))))
+
+(define-syntax instance
+  (syntax-rules ()
+    ((_ instance-name template subst-list)
+     (instantiate-template 'instance-name 'template 'subst-list))))