Committed scheme27 and various improvements

4 files changed, 38 insertions, 9 deletions

diff --git a/scheme/aps/easy-test.sls b/scheme/aps/easy-test.sls
index 70fd253..b7f4064 100644
--- a/scheme/aps/easy-test.sls
+++ b/scheme/aps/easy-test.sls
@@ -9,7 +9,8 @@
         ((error-message #f)
          (result
           (guard (err ;; as a side effect, set! the error message if any
-                  ((or (assertion-violation? err) (error? err))
+                  ((or (assertion-violation? err) (error? err)
+                       (undefined-violation? err))
                    (set! error-message (condition-message err))))
                  body body* ...)))
       (if error-message error-message
diff --git a/scheme/aps/lang.sls b/scheme/aps/lang.sls
index 85308c1..6b41198 100644
--- a/scheme/aps/lang.sls
+++ b/scheme/aps/lang.sls
@@ -1,12 +1,32 @@
 #!r6rs
 (library (aps lang)
-(export literal-replace : raw-identifier=? identifier-append identifier-prepend
-        get-name-from-define)
+(export literal-replace : unbound? raw-identifier=? raw-id=?
+        identifier-append identifier-prepend
+        get-name-from-define let1)
 (import (rnrs) (sweet-macros))
 
+;;LET1
+(def-syntax let1
+  (syntax-match ()
+    (sub (let1 () lst e e* ...)
+         #'(if (null? lst) (begin e e* ...)
+               (apply error 'let1 "Too many elements" lst)))
+    (sub (let1 (arg1 arg2 ... . rest) lst e e* ...)
+         #'(let ((ls lst))
+             (if (null? ls)
+                 (apply error 'let1 "Missing arguments" '(arg1 arg2 ...))
+                 (let1 arg1 (car ls)
+                   (let1 (arg2 ... . rest) (cdr ls) e e* ...)))))
+    (sub (let1 name value e e* ...)
+         #'(letrec ((name value)) e e* ...)
+         (identifier? #'name)
+         (syntax-violation 'let1 "Argument is not an identifier" #'name))
+    ))
+;;END
+
 ;;RAW-IDENTIFIER=?
-(define (raw-identifier=? id1 id2)
-  (symbol=? (syntax->datum id1) (syntax->datum id2)))
+(define (raw-identifier=? raw id)
+  (symbol=? raw (syntax->datum id)))
 ;;END
 
 ;;RAW-ID=?
@@ -14,6 +34,12 @@
     (and (identifier? x) (raw-identifier=? raw-id x)))
 ;;END
 
+;;UNBOUND?
+(define (unbound? id)
+  (define unbound-id (datum->syntax #'dummy-ctxt (syntax->datum id)))
+  (free-identifier=? id  unbound-id))
+;;END
+
 ;;LITERAL-REPLACE
 (def-syntax literal-replace
   (syntax-match ()
diff --git a/scheme/aps/list-match.sls b/scheme/aps/list-match.sls
index 20e8d95..94ba577 100644
--- a/scheme/aps/list-match.sls
+++ b/scheme/aps/list-match.sls
@@ -1,6 +1,6 @@
 (library (aps list-match)
 (export list-match _match)
-(import (rnrs) (sweet-macros))
+(import (rnrs) (sweet-macros) (aps lang) (aps cut))
 
 ;; see http://groups.google.com/group/comp.lang.scheme/msg/7701b9231835635f?hl=en
 
@@ -9,7 +9,7 @@
       (cond
        ((_match obj pattern (list template) guard ...) => car) ...
        (else (error 'list-match "pattern failure" obj))))
-  (for-all (cut raw-id=? #'sub <>) #'(sub ...)))
+  (for-all (cut raw-id=? 'sub <>) #'(sub ...)))
 
 (def-syntax _match
   (syntax-match (quote quasiquote)
diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls
index 835c9e8..95b351f 100644
--- a/scheme/aps/list-utils.sls
+++ b/scheme/aps/list-utils.sls
@@ -141,12 +141,14 @@
      (sub (fold left (acc seed) (x in lst) (x* in lst*) ... new-acc)
            (: with-syntax (a a* ...) (generate-temporaries #'(x x* ...))
               #'(fold-left
-                 (lambda (acc a a* ...) (let+ (x a) (x* a*) ... new-acc))
+                 (lambda (acc a a* ...)
+                   (let+ ((x x* ...) (list a a* ...)) new-acc))
                  seed lst lst* ...)))
      (sub (fold right (acc seed) (x in lst) (x* in lst*) ... new-acc)
            (: with-syntax (a a* ...) (generate-temporaries #'(x x* ...))
               #'(fold-right
-                 (lambda (a a* ... acc) (let+ (x a) (x* a*) ... new-acc))
+                 (lambda (a a* ... acc)
+                   (let+ ((x x* ...) (list a a* ...)) new-acc))
                  seed lst lst* ...)))
      ))
 ;;END