Committed a lot of work on my Adventures

3 files changed, 72 insertions, 44 deletions

diff --git a/scheme/aps/lang.sls b/scheme/aps/lang.sls
index 1693259..8b23089 100644
--- a/scheme/aps/lang.sls
+++ b/scheme/aps/lang.sls
@@ -1,6 +1,6 @@
 #!r6rs
 (library (aps lang)
-(export :)
+(export : identifier-append identifier-prepend get-name-from-define)
 (import (rnrs) (sweet-macros))
 
 ;;COLON
@@ -17,4 +17,35 @@
          (syntax-violation ': "Not an identifier" #'let-form))
     ))
 ;;END
+
+
+;;GET-NAME-FROM-DEFINE
+(define get-name-from-define
+  (syntax-match (define)
+    (sub (define (name . args) body body* ...) #'name
+         (identifier? #'name)
+         (syntax-violation 'get-name-from-define "not a name" #'name))
+    (sub (define name value) #'name
+         (identifier? #'name)
+         (syntax-violation 'get-name-from-define "not a name" #'name))
+    ))
+  
+;;END
+
+;;IDENTIFIER-APPEND
+;; take an identifier and return a new one with an appended suffix
+(define (identifier-append id . strings)
+  (datum->syntax id (string->symbol
+                     (apply string-append
+                            (symbol->string (syntax->datum id)) strings))))
+;;END
+
+;;IDENTIFIER-PREPEND
+;; take an identifier and return a new one with an prepended suffix
+(define (identifier-prepend id . strings)
+  (define prefix (apply string-append strings))
+  (datum->syntax id (string->symbol
+                     (string-append
+                      prefix (symbol->string (syntax->datum id))))))
+;;END
 )
diff --git a/scheme/aps/list-match.sls b/scheme/aps/list-match.sls
index 8e87e5b..7e115f5 100644
--- a/scheme/aps/list-match.sls
+++ b/scheme/aps/list-match.sls
@@ -1,42 +1,38 @@
 (library (aps list-match)
-;;; Version: 0.2
-;;; Author: Michele Simionato
-;;; Email: michele.simionato@gmail.com
-;;; Date: 31-Jan-2009
-;;; Licence: BSD
-(export list-match)
+(export list-match _match)
 (import (rnrs) (sweet-macros))
 
-(def-syntax list-match-aux
-  (syntax-match (quote quasiquote)
-      (sub (_ obj pattern action)
-           #'(list-match-aux obj pattern action #t))
-      (sub (_ obj () action guard)
-           #'(and (null? obj) guard action))
-      (sub (_ obj underscore action guard)
-           #'(and guard action)
-           (and (identifier? #'underscore)(free-identifier=? #'underscore #'_)))
-      (sub (_ obj var action guard)
-           #'(let ((var obj)) (and guard action))
-        (identifier? #'var))
-      (sub (_ obj (quote datum) action guard)
-           #'(and (equal? obj (quote datum)) guard action))
-      (sub (_ obj (quasiquote datum) action guard)
-           #'(and (equal? obj (quasiquote datum)) guard action))
-      (sub (_ obj (kar . kdr) action guard)
-           #'(and (pair? obj)
-                  (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
-                    (list-match-aux kar-obj kar
-                      (list-match-aux kdr-obj kdr action guard)))))
-      (sub (_ obj const action guard)
-           #'(and (equal? obj const) guard action))
-      ))
+;; see http://groups.google.com/group/comp.lang.scheme/msg/7701b9231835635f?hl=en
+
+(def-syntax (list-match lst (sub pattern template guard ...) ...)
+  #'(let ((obj lst))
+      (cond
+       ((_match obj pattern (list template) guard ...) => car) ...
+       (else (error 'list-match "pattern failure" obj))))
+  (for-all (lambda (s) (eq? (syntax->datum s) 'sub)) #'(sub ...)))
 
-(def-syntax list-match
-  (syntax-match (when)
-    (sub (list-match lst (when pattern action guard ...) ...)
-      #'(let ((ls lst))
-          (cond
-           ((list-match-aux ls pattern (list action) guard ...) => car) ...
-           (else (error 'list-match "pattern mismatch" ls)))))))
+(def-syntax _match
+  (syntax-match (quote quasiquote)
+      (sub (_ obj pattern template)
+       #'(_match obj pattern template #t))
+      (sub (_ obj () template guard)
+       #'(and (null? obj) guard template))
+      (sub (_ obj underscore template guard)
+        #'(and guard template)
+        (and (identifier? #'underscore) (free-identifier=? #'underscore #'_)))
+      (sub (_ obj var template guard)
+        #'(let ((var obj)) (and guard template))
+        (identifier? (syntax var)))
+      (sub (_ obj (quote datum) template guard)
+        #'(and (equal? obj (quote datum)) template))
+      (sub (_ obj (quasiquote datum) template guard )
+        #'(and (equal? obj (quasiquote datum)) guard template))
+      (sub (_ obj (kar . kdr) template guard)
+        #'(let ((ob obj))
+            (and (pair? ob)
+               (let ((kar-obj (car ob)) (kdr-obj (cdr ob)))
+                 (_match kar-obj kar
+                    (_match kdr-obj kdr template guard))))))
+      (sub (_ obj const template guard)
+        #'(and (equal? obj const) guard template))))
 )
diff --git a/scheme/sweet-macros/main.sls b/scheme/sweet-macros/main.sls
index 6cee564..946daf0 100644
--- a/scheme/sweet-macros/main.sls
+++ b/scheme/sweet-macros/main.sls
@@ -59,12 +59,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