Additional work on the module system and phase separation

5 files changed, 40 insertions, 40 deletions

diff --git a/scheme/aps/define-ct.sls b/scheme/aps/define-ct.sls
new file mode 100644
index 0000000..761bf93
--- /dev/null
+++ b/scheme/aps/define-ct.sls
@@ -0,0 +1,15 @@
+(library (aps define-ct)
+(export alist define-ct)
+(import (rnrs) (sweet-macros) (aps lang) (aps list-utils))
+
+;;DEFINE-CT
+(def-syntax (define-ct kw (define name value) ...)
+  #'(def-syntax kw
+      (let ((a (alist (name value) ...)))
+        (syntax-match (name ...)
+          (sub (kw name) (datum->syntax #'kw (car (assq 'name a))))
+          ...)))
+  (eq? (syntax->datum #'define) 'define))
+;;END
+
+)
diff --git a/scheme/aps/lang.sls b/scheme/aps/lang.sls
index 8b23089..89f8527 100644
--- a/scheme/aps/lang.sls
+++ b/scheme/aps/lang.sls
@@ -48,4 +48,5 @@
                      (string-append
                       prefix (symbol->string (syntax->datum id))))))
 ;;END
+
 )
diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls
index b662e73..1f564a5 100644
--- a/scheme/aps/list-utils.sls
+++ b/scheme/aps/list-utils.sls
@@ -1,7 +1,7 @@
 #!r6rs
 (library (aps list-utils)
 (export range enumerate zip transpose distinct? let+ perm list-of-aux list-for
-        remove-dupl append-unique fold flatten list-of normalize)
+        remove-dupl append-unique fold flatten list-of normalize alist)
 (import (rnrs) (sweet-macros) (aps cut) (for (aps lang) expand))
 
 ;;; macros
@@ -58,6 +58,18 @@
 (def-syntax (list-for decl ... expr)
   #'(list-of-aux expr '() decl ...))
 
+;;ALIST
+(def-syntax (alist arg ...)
+  (: with-syntax
+     ((name value) ...)
+     (map (syntax-match ()
+            (sub n #'(n n) (identifier? #'n))
+            (sub (n v) #'(n v) (identifier? #'n)))
+          #'(arg ...))
+     #'(let* ((name value) ...)
+         (list (list 'name name) ...))))
+;;END
+
 ;;; utilities
 
 ;;RANGE
@@ -157,18 +169,11 @@
              (ls in (perm eq? (remp (cut eq? el <>) lst)))))))
 ;;END
 
-
-
-
-
-
-
-
 ;;NORMALIZE
 (define (normalize ls)
-  (list-of (syntax-match a ()
-              (sub n #'(n n) (identifier? #'n))
-              (sub (n v) #'(n v) (identifier? #'n)))
-           (a in ls)))
+  (map (syntax-match ()
+         (sub n #'(n n) (identifier? #'n))
+         (sub (n v) #'(n v) (identifier? #'n)))
+       ls))
 ;;END
 )
diff --git a/scheme/define-ct.ss b/scheme/define-ct.ss
deleted file mode 100644
index ead89c2..0000000
--- a/scheme/define-ct.ss
+++ /dev/null
@@ -1,22 +0,0 @@
-;;; how to define a static table from a dynamic one
-
-(import (rnrs) (sweet-macros) (table) (ikarus))
-
-(def-syntax define-ct
-  (syntax-match (define)
-    (sub (define-ct kw (define name value) ...)
-         #'(def-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/sweet-macros/helper3.mzscheme.sls b/scheme/sweet-macros/helper3.mzscheme.sls
index 9d6108e..b1cb947 100644
--- a/scheme/sweet-macros/helper3.mzscheme.sls
+++ b/scheme/sweet-macros/helper3.mzscheme.sls
@@ -11,12 +11,13 @@
     
     (sub (def-syntax name transformer)
      #'(define-syntax name
-         (syntax-match (<source> <transformer>)
-           (sub (name <transformer>) #'(... (... transformer)))
-           (sub (name <source>) #''(... (... transformer)))
-           (sub x (transformer #'x))))
-     (identifier? #'name)
-     (syntax-violation 'def-syntax "Invalid name" #'name))
+         (lambda (x)
+           (syntax-case x (<source> <transformer>)
+             ((name <transformer>) #'(... (... transformer)))
+             ((name <source>) #''(... (... transformer)))
+             (x (transformer #'x)))))
+     (identifier? #'name))
+     ;(syntax-violation 'def-syntax "Invalid name" #'name))
 
     (sub (def-syntax name (extends parent) (literal ...) clause ...)
      #'(def-syntax name