Various work on scheme

6 files changed, 26 insertions, 99 deletions

diff --git a/scheme/aps/define-ct.sls b/scheme/aps/define-ct.sls
index 761bf93..66cc4e2 100644
--- a/scheme/aps/define-ct.sls
+++ b/scheme/aps/define-ct.sls
@@ -1,15 +1,22 @@
+#!r6rs
 (library (aps define-ct)
-(export alist define-ct)
-(import (rnrs) (sweet-macros) (aps lang) (aps list-utils))
+(export compilation-time)
+(import (rnrs) (sweet-macros) (aps lang) (aps list-utils) (srfi :19))
+
+;; see http://srfi.schemers.org/srfi-19/srfi-19.html
+(define-syntax compilation-time
+  (let ((isodate (date->string (current-date) "~5")));; visit time
+    (display "Visit time: ") (display isodate) (newline)
+    (lambda (x) isodate)))
 
 ;;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))
+;(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/make_sweet_macros.py b/scheme/make_sweet_macros.py
index cfc1441..b026ffd 100644
--- a/scheme/make_sweet_macros.py
+++ b/scheme/make_sweet_macros.py
@@ -27,7 +27,7 @@ helper2 = '''#!r6rs
 '''
 
 helper3 = '''#!r6rs
-(library (sweet-macros)
+(library (sweet-macros helper3)
 (export syntax-match def-syntax)
 (import (rnrs) (for (sweet-macros helper2) run expand))
 
@@ -50,15 +50,15 @@ def write_on(fname, code):
     
 def makefiles(name, snippet):
     write_on(name + '/main.sls', ikarus_code)
-    write_on('sweet-macros.larceny.sls', main)
-    for impl in  ('larceny', 'mzscheme'):
-        write_on(name + '/helper1.%s.sls' % impl, helper1 % snippet)
-        write_on(name + '/helper2.%s.sls' % impl, helper2 % snippet)
-        write_on(name + '/helper3.%s.sls' % impl, helper3 % snippet)
-        write_on(name + '/main.%s.sls' % impl, main % snippet)
+    write_on(name + '/main.mzscheme.sls', main % snippet)
+    write_on('sweet-macros.larceny.sls', main % snippet)
+    write_on(name + '/helper1.sls', helper1 % snippet)
+    write_on(name + '/helper2.sls', helper2 % snippet)
+    write_on(name + '/helper3.sls', helper3 % snippet)
     
 if __name__ == '__main__':
     #plt_home = os.path.expanduser('~/.plt-scheme')
     #collects = os.path.join(plt_home, max(os.listdir(plt_home)), 'collects')
     makefiles('sweet-macros', snippet)
-  
+    os.system('scp sweet-macros.zip '
+              'micheles@merlin.phyast.pitt.edu:public_html/scheme')
diff --git a/scheme/sweet-macros/helper1.mzscheme.sls b/scheme/sweet-macros/helper1.mzscheme.sls
deleted file mode 100644
index a5964b5..0000000
--- a/scheme/sweet-macros/helper1.mzscheme.sls
+++ /dev/null
@@ -1,27 +0,0 @@
-#!r6rs
-(library (sweet-macros helper1)
-(export guarded-syntax-case)
-(import (rnrs))
-
-(define-syntax guarded-syntax-case
-  (let ((add-clause
-         (lambda (clause acc)
-           (syntax-case clause ()
-             ((pattern skeleton . rest)
-                (syntax-case #'rest ()
-                  ((cond? else1 else2 ...)
-                   (cons*
-                    #'(pattern cond? skeleton)
-                    #'(pattern (begin else1 else2 ...))
-                    acc))
-                  ((cond?)
-                   (cons #'(pattern cond? skeleton) acc))
-                  (()
-                   (cons #'(pattern skeleton) acc))
-                  ))))))
-    (lambda (x)
-      (syntax-case x ()
-        ((guarded-syntax-case y (literal ...) clause ...)
-         (with-syntax (((c ...) (fold-right add-clause '() #'(clause ...))))
-           #'(syntax-case y (literal ...) c ...)))))))
-)
diff --git a/scheme/sweet-macros/helper2.mzscheme.sls b/scheme/sweet-macros/helper2.mzscheme.sls
deleted file mode 100644
index 29045f5..0000000
--- a/scheme/sweet-macros/helper2.mzscheme.sls
+++ /dev/null
@@ -1,24 +0,0 @@
-#!r6rs
-(library (sweet-macros helper2)
-(export syntax-match)
-(import (rnrs) (for (rnrs) (meta -1))
-(for (sweet-macros helper1) (meta -1) (meta 0) (meta 1)))
-
-(define-syntax syntax-match
-  (lambda (y)
-    (guarded-syntax-case y (sub)
-      
-      ((self (literal ...) (sub patt skel rest ...) ...)
-       #'(lambda (x) (self x (literal ...) (sub patt skel rest ...) ...)))
-      
-      ((self x (literal ...) (sub patt skel rest ...) ...)
-       #'(guarded-syntax-case x (<literals> <patterns> literal ...)
-           ((ctx <literals>) #''(literal ...))
-           ((ctx <patterns>) #''((... (... patt)) ...))
-           (patt skel rest ...)
-           ...)
-       (for-all identifier? #'(literal ...))
-       (syntax-violation 'syntax-match "Found non identifier" #'(literal ...)
-                         (remp identifier? #'(literal ...))))
-      )))
-)
diff --git a/scheme/sweet-macros/helper3.mzscheme.sls b/scheme/sweet-macros/helper3.mzscheme.sls
deleted file mode 100644
index f737dc0..0000000
--- a/scheme/sweet-macros/helper3.mzscheme.sls
+++ /dev/null
@@ -1,29 +0,0 @@
-#!r6rs
-(library (sweet-macros)
-(export syntax-match def-syntax)
-(import (rnrs) (for (sweet-macros helper2) run expand))
-
-(define-syntax def-syntax
-  (syntax-match (extends)
-
-    (sub (def-syntax name (extends parent) (literal ...) clause ...)
-     #'(def-syntax name
-         (syntax-match (literal ...)
-           clause ...
-           (sub x ((parent <transformer>) #'x)))))
-    
-    (sub (def-syntax (name . args) skel rest ...)
-     #'(def-syntax name (syntax-match () (sub (name . args) skel rest ...))))
-    
-    (sub (def-syntax name transformer)
-     #'(define-syntax 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))
-
-    ))
-)
diff --git a/scheme/sweet-macros/main.sls b/scheme/sweet-macros/main.sls
index c7b78f2..5ba2912 100644
--- a/scheme/sweet-macros/main.sls
+++ b/scheme/sweet-macros/main.sls
@@ -1,8 +1,8 @@
 (library (sweet-macros)
-;;; Version: 0.8
+;;; Version: 0.8.1
 ;;; Author: Michele Simionato
 ;;; Email: michele.simionato@gmail.com
-;;; Date: 22-Apr-2009
+;;; Date: 23-Apr-2009
 ;;; Licence: BSD
 (export syntax-match def-syntax syntax-expand sub)
 (import (rnrs))