Added two scripts

2 files changed, 51 insertions, 0 deletions

diff --git a/scheme/define-ct.ss b/scheme/define-ct.ss
new file mode 100644
index 0000000..3d29380
--- /dev/null
+++ b/scheme/define-ct.ss
@@ -0,0 +1,20 @@
+(import (rnrs) (sweet-macros) (table) (ikarus))
+
+(def-syntax define-ct
+  (syntax-match (define)
+    (sub (define-ct kw (define name value) ...)
+         #'(define-syntax kw
+             (let ((t (tbl (name value) ...)))
+               (syntax-match (name ...)
+                (sub (kw name) (datum->syntax #'kw (t 'name))) ...))))))
+(define-ct example
+  (define x 1)
+  (define y (* x 2)))
+
+(pretty-print (syntax-expand
+(define-ct example
+  (define x 1)
+  (define y (* x 2)))))
+
+(display (list (example x) (example y)))
+         
diff --git a/scheme/table.sls b/scheme/table.sls
new file mode 100644
index 0000000..55899e9
--- /dev/null
+++ b/scheme/table.sls
@@ -0,0 +1,31 @@
+(library (table)
+(export tbl table table-extend table-get)
+(import (rnrs) (sweet-macros) (only (ikarus) gensym))
+
+(def-syntax (tbl (name value) ...)
+  #'(letrec ((name value) ...)
+      (table (list (list 'name name) ...))))
+
+(def-syntax (table-get t key else0 else1 ...)
+  #'(let ((res (t key)))
+      (if (missing-key? res)
+          (begin else0 else1 ...)
+          res)))
+
+(define MISSING-KEY (gensym 'missing-key))
+
+(define (missing-key? x)
+  (eq? x MISSING-KEY))
+
+(define append-unique append)
+
+(define (table alist)
+  (define full-list (append-unique (list (list '->alist alist)) alist))
+  (lambda (k)
+    (define ls (assq k full-list))
+    (if ls (cadr ls) MISSING-KEY)))
+
+(define (table-extend base-table ext)
+  (table (append (base-table '->alist) ext)))
+
+)