r6rs tests and bug fixes

svn: r9563

collects/r5rs/main.ss

@@ -480,7 +480,7 @@
                                       define-syntax let-syntax letrec-syntax
                                       => else
                                       #%app #%datum #%top #%top-interaction
-                                      #%require #%provide))
+                                      #%require #%provide #%expression))
             (begin
               (namespace-require 'r5rs) ; for syntax
               (namespace-require/copy 'r5rs))))

collects/rnrs/enums-6.ss

@@ -138,11 +138,11 @@
             [v1 (enum-set-val enum1)]
             [v2 (enum-set-val enum2)])
         (for/fold ([sub? #t])
-            (#:when sub?
+            ([(key1 val1) (in-hash (universe-ht (enum-set-uni enum1)))]
-                    [(key1 val1) (in-hash (universe-ht (enum-set-uni enum1)))])
+             #:when sub?)
-          (or (zero? (bitwise-and v1 val1))
           (let ([val2 (hash-ref ht2 key1 #f)])
             (and val2
+                 (or (zero? (bitwise-and v1 val1))
                      (not (zero? (bitwise-and v2 val2))))))))))
 
 (define (enum-set=? enum1 enum2)

collects/rnrs/r5rs-6.ss

@@ -11,5 +11,3 @@
                      [r5rs:force force]
                      [r5rs:null-environment null-environment]
                      [r5rs:scheme-report-environment scheme-report-environment]))
-         
-                     

collects/rnrs/syntax-case-6.ss

@@ -26,6 +26,15 @@
 (define (r6rs:datum->syntax id datum)
   (unless (identifier? id)
     (raise-type-error 'datum->syntax "identifier?" id))
+  (let loop ([d datum])
+    (cond
+     [(syntax? d) (raise-type-error
+                   'datum->syntax
+                   "datum"
+                   datum)]
+     [(pair? d) (loop (car d)) (loop (cdr d))]
+     [(mpair? d) (loop (mcar d)) (loop (mcdr d))]
+     [(vector? d) (for-each loop (vector->list d))]))
   (datum->syntax id (convert-mpairs datum)))
 
 (define (r6rs:syntax->datum stx)

collects/scribblings/reference/class.scrbl

@@ -1709,4 +1709,6 @@ a method that is not supplied by an object.
 
 }
 
+@; ----------------------------------------------------------------------
+
 @include-section["surrogate.scrbl"]

collects/scribblings/reference/surrogate.scrbl

@@ -1,12 +1,11 @@
 #lang scribble/doc
-@(require 
+@(require "mz.ss"
-  scribble/basic
-  scribble/manual
           (for-label scheme/surrogate
                      scheme/class))
 
 @title{Surrogates}
-@(defmodule scheme/surrogate)
+ 
+@note-lib-only[scheme/surrogate]
 
 The @schememodname[scheme/surrogate] library provides an abstraction
 for building an instance of the @deftech{proxy design pattern}. The

collects/tests/r6rs/enums.ss

@@ -20,6 +20,48 @@
             (list (i 'red) (i 'green) (i 'blue) (i 'yellow)))
           '(0 1 2 #f))
 
+    (let* ((e (make-enumeration '(red green blue)))
+           (r ((enum-set-constructor e) '(red))))
+      (test (enum-set->list (enum-set-universe e))
+            '(red green blue))
+      (test (enum-set->list (enum-set-universe r))
+            '(red green blue))
+      (test ((enum-set-indexer
+              ((enum-set-constructor e) '(red)))
+             'green)
+            1)
+      (test (enum-set-member? 'red e) #t)
+      (test (enum-set-member? 'black e) #f)
+      (test (enum-set-subset? e e) #t)
+      (test (enum-set-subset? r e) #t)
+      (test (enum-set-subset? e r) #f)
+      (test (enum-set-subset? e (make-enumeration '(blue green red))) #t)
+      (test (enum-set-subset? e (make-enumeration '(blue green red black))) #t)
+      (test (enum-set-subset? (make-enumeration '(blue green red black)) e) #f)
+      (test (enum-set-subset? ((enum-set-constructor
+                                (make-enumeration '(blue green red black)))
+                               '(red))
+                              e) #f)
+      (test (enum-set-subset? ((enum-set-constructor
+                                (make-enumeration '(green red)))
+                               '(red))
+                              e) #t)
+      (test (enum-set=? e e) #t)
+      (test (enum-set=? r e) #f)
+      (test (enum-set=? e r) #f)
+      (test (enum-set=? e (make-enumeration '(blue green red))) #t))
+
+    (test (let* ((e (make-enumeration '(red green blue)))
+                 (c (enum-set-constructor e)))
+            (list
+             (enum-set-member? 'blue (c '(red blue)))
+             (enum-set-member? 'green (c '(red blue)))
+             (enum-set-subset? (c '(red blue)) e)
+             (enum-set-subset? (c '(red blue)) (c '(blue red)))
+             (enum-set-subset? (c '(red blue)) (c '(red)))
+             (enum-set=? (c '(red blue)) (c '(blue red)))))
+          (list #t #f #t #t #f #t))
+
     (test (let* ((e (make-enumeration '(red green blue)))
                  (c (enum-set-constructor e)))
             (enum-set->list (c '(blue red)))) 

collects/tests/r6rs/r5rs.ss

@@ -4,6 +4,7 @@
   (export run-r5rs-tests)
   (import (rnrs)
           (rnrs r5rs)
+          (rnrs eval)
           (tests r6rs test))
 
   ;; ----------------------------------------
@@ -160,6 +161,21 @@
     (test (modulo -536870912238479837489374 -3248732398479823749283)
           -830066489308918857679)
 
+    ;; ----------------------------------------
+
+    (test (exact->inexact 1) 1.0)
+    (test (exact->inexact 1.0) 1.0)
+    (test (inexact->exact 1) 1)
+    (test (inexact->exact 1.0) 1)
+
+    ;; ----------------------------------------
+
+    (test (eval '(cond [#t 1]) (null-environment 5)) 1)
+    (test (eval '(cond [#t => (lambda (x) x)]) (null-environment 5)) #t)
+
+
+    (test (eval '(cons 1 2) (scheme-report-environment 5)) '(1 . 2))
+
     ;;
     ))
 

collects/tests/r6rs/syntax-case.ss

@@ -6,6 +6,16 @@
           (rename (only (rnrs base) cons) (cons kons)) ; for free-identifier=?
           (tests r6rs test))
 
+  (define (unwrap s)
+    (cond
+     [(pair? s) (cons (unwrap (car s)) (unwrap (cdr s)))]
+     [(vector? s) (list->vector (map unwrap (vector->list s)))]
+     [(null? s) s]
+     [(number? s) s]
+     [(string? s) s]
+     [(boolean? s) s]
+     [else (syntax->datum s)]))
+
   ;; ----------------------------------------
   
   (define p (cons 4 5))
@@ -118,20 +128,21 @@
     (test (syntax-case #'(1) () [(1) 'one])  'one)
     (test (syntax-case '(1) () [(x) #'x]) 1)
     (test (syntax-case #'(1) () [(x) (syntax->datum #'x)]) 1)
-    (test (syntax-case '(a) () [(x) #'x]) 'a)
+    (test (syntax-case '("a") () [(x) #'x]) "a")
-    (test (syntax-case #'(a) () [(x) (syntax->datum #'x)]) 'a)
+    (test (syntax-case #'("a") () [(x) (syntax->datum #'x)]) "a")
-    (test (syntax-case '(a 1 #f "s" #vu8(9) #(5 7)) () 
+    (test (syntax-case '(1 #f "s" #vu8(9) #(5 7)) () 
             [(x ...) #'(x ...)]) 
-          '(a 1 #f "s" #vu8(9) #(5 7)))
+          '(1 #f "s" #vu8(9) #(5 7)))
-    (test (syntax-case #'(a 1 #f "s" #vu8(9) #(5 7)) () 
+    (test (syntax-case #'(1 #f "s" #vu8(9) #(5 7)) () 
             [(x ...) (map syntax->datum #'(x ...))]) 
-          '(a 1 #f "s" #vu8(9) #(5 7)))
+          '(1 #f "s" #vu8(9) #(5 7)))
-    (test (syntax-case '(a b c d) () [(x y . z) #'z]) '(c d))
+    (test (syntax-case '(1 2 3 4) () [(x y . z) #'z]) '(3 4))
     (test (syntax-case #'(a b c d) () [(x y . z) (syntax->datum #'z)]) 
           '(c d))
-    (test (syntax-case '(nonesuch 12) (nonesuch) [(nonesuch x) #'x])
+    (test (syntax-case #'(nonesuch 12) (nonesuch) 
+            [(nonesuch x) (syntax->datum #'x)])
           12)
-    (test (syntax-case '(different 12) (nonesuch) 
+    (test (syntax-case #'(different 12) (nonesuch) 
             [(nonesuch x) #'x]
             [_ 'other])
           'other)
@@ -204,7 +215,7 @@
     (test (syntax->datum (datum->syntax #'x '(a b))) '(a b))
     (test (syntax->datum (datum->syntax #'x '(a . b))) '(a . b))
 
-    (test (symbol? (car (syntax->datum (datum->syntax #'x (list #'id))))) #t)
+    (test (number? (car (syntax->datum (datum->syntax #'x (list 1))))) #t)
 
     (test (map identifier? (generate-temporaries '(1 2 3))) '(#t #t #t))
     (test (map identifier? (generate-temporaries #'(1 2 3))) '(#t #t #t))
@@ -242,23 +253,20 @@
             [(x ...) #`(x ...)])
           '(1 2 3))
 
-    (test (syntax->datum
+
-           (datum->syntax #'x
+    (test (unwrap
-            #`(1 2 (unsyntax 3 4 5) 6)))
+           #`(1 2 (unsyntax 3 4 5) 6))
           '(1 2 3 4 5 6))
-    (test (syntax->datum
+    (test (unwrap
-           (datum->syntax #'x
+           #`(1 2 (unsyntax-splicing '(3 4) '(5)) 6))
-            #`(1 2 (unsyntax-splicing '(3 4) '(5)) 6)))
           '(1 2 3 4 5 6))
 
-    (test (syntax->datum
+    (test (unwrap
-           (datum->syntax #'x
+           #`#(1 2 (unsyntax-splicing '(3 4) '(5)) 6))
-            #`#(1 2 (unsyntax-splicing '(3 4) '(5)) 6)))
           '#(1 2 3 4 5 6))
 
-    (test (syntax->datum
+    (test (unwrap
-           (datum->syntax #'x
+           #`(1 #`(#,(+ 3 4) #,#,(+ 1 1))))
-            #`(1 #`(#,(+ 3 4) #,#,(+ 1 1)))))
           '(1 #`(#,(+ 3 4) #,2)))
 
     (test/exn (syntax-violation #f "bad" 7) &syntax)