From a09b2eca94fe10d2dd293570ba8d1eeeb76c2f64 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 1 May 2008 12:28:14 +0000
Subject: [PATCH] r6rs tests and bug fixes

svn: r9558
---
 collects/rnrs/hashtables-6.ss      |  15 +--
 collects/rnrs/syntax-case-6.ss     | 150 +++++++++++++++++++++++++--
 collects/tests/r6rs/hashtables.ss  | 136 ++++++++++++++++++++++++
 collects/tests/r6rs/syntax-case.ss | 161 +++++++++++++++++++++++++++++
 4 files changed, 450 insertions(+), 12 deletions(-)

diff --git a/collects/rnrs/hashtables-6.ss b/collects/rnrs/hashtables-6.ss
index ac422b63d9..15aa6c88d8 100644
--- a/collects/rnrs/hashtables-6.ss
+++ b/collects/rnrs/hashtables-6.ss
@@ -112,27 +112,30 @@
             tag)))
 
 (define (hashtable-update! ht key proc default)
-  (hashtable-set! ht key (proc (hashtable-ref ht key default))))
+  (if (hashtable-mutable? ht)
+      (hashtable-set! ht key (proc (hashtable-ref ht key default)))
+      (raise-type-error 'hashtable-update! "mutable hashtable" ht)))
 
 (define (hashtable-copy ht [mutable? #f])
   (make-hashtable (hash-copy (hashtable-ht ht))
                   (hashtable-wrap ht)
                   (hashtable-unwrap ht)
                   mutable?
-                  (hashtable-equivalence-function ht)))
+                  (hashtable-equivalence-function ht)
+                  (hashtable-hash-function ht)))
 
 (define (hashtable-clear! ht [k 0])
   (unless (exact-nonnegative-integer? k)
     (raise-type-error 'hashtable-clear! "exact, nonnegative integer" k))
   (if (hashtable-mutable? ht)
-      (set-hashtable-ht! (if (eq? values (hashtable-wrap ht))
-                             (make-hasheq)
-                             (make-hash)))
+      (set-hashtable-ht! ht (if (eq? values (hashtable-wrap ht))
+                                (make-hasheq)
+                                (make-hash)))
       (raise-type-error 'hashtable-clear! "mutable hashtable" ht)))
 
 (define (hashtable-keys ht)
   (let ([unwrap (hashtable-unwrap ht)])
-    (hash-map (hashtable-ht ht) (lambda (a b) (unwrap a)))))
+    (list->vector (hash-map (hashtable-ht ht) (lambda (a b) (unwrap a))))))
 
 (define (hashtable-entries ht)
   (let ([ps (hash-map (hashtable-ht ht) cons)]
diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss
index 8b40e09ac5..b3a14e1bfc 100644
--- a/collects/rnrs/syntax-case-6.ss
+++ b/collects/rnrs/syntax-case-6.ss
@@ -33,9 +33,19 @@
 
 (define (r6rs:generate-temporaries l)
   (list->mlist
-   (generate-temporaries (if (mlist? l)
-                             (mlist->list l)
-                             l))))
+   (generate-temporaries (let loop ([l l])
+                           (cond
+                            [(null? l) null]
+                            [(mpair? l) (cons (mcar l)
+                                              (loop (mcdr l)))]
+                            [(syntax? l) (loop (syntax-e l))]
+                            [(pair? l) (cons (car l)
+                                             (loop (cdr l)))]
+                            [else
+                             (raise-type-error
+                              'generate-temporaries
+                              "list or list-structured syntax object"
+                              l)])))))
 
 (define (make-variable-transformer proc)
   (make-set!-transformer proc))
@@ -274,12 +284,140 @@
 ;;  > (with-syntax ([a 10][... 11]) #'(a ...))
 ;;  (10 11)
 
-
 (define-syntax r6rs:with-syntax
   (syntax-rules ()
     [(_ [(p e0) ...] e1 e2 ...)
      (r6rs:syntax-case (mlist e0 ...) ()
        [(p ...) (let () e1 e2 ...)])]))
 
-(define-generalized-qq r6rs:quasisyntax
-  quasisyntax unsyntax unsyntax-splicing convert-mpairs)
+(define-syntax (r6rs:quasisyntax stx)
+  (syntax-case stx ()
+    [(_ tmpl)
+     (let loop ([stx #'tmpl]
+                [src stx]
+                [depth 0]
+                [to-splice? #f]
+                [k (lambda (template pats exprs)
+                     (with-syntax ([(pat ...) pats]
+                                   [(expr ...) exprs]
+                                   [template template])
+                       (syntax/loc stx
+                         (r6rs:with-syntax ([pat expr] ...)
+                                           (r6rs:syntax template)))))])
+       (cond
+        [(and (identifier? stx)
+              (or (free-identifier=? #'unsyntax stx)
+                  (free-identifier=? #'unsyntax-splicing stx)))
+         (raise-syntax-error #f
+                             "misplaced within quasitemplate"
+                             stx)]
+        [(syntax? stx)
+         (loop (syntax-e stx)
+               stx
+               depth
+               to-splice?
+               (lambda (t pats exprs)
+                 (k (if to-splice?
+                        (map (lambda (t)
+                               (datum->syntax stx t stx stx))
+                             t)
+                        (datum->syntax stx t stx stx))
+                    pats
+                    exprs)))]
+        [(pair? stx)
+         (cond
+          [(and (identifier? (car stx))
+                (or (free-identifier=? #'unsyntax (car stx))
+                    (free-identifier=? #'unsyntax-splicing (car stx))))
+           (let ([l (syntax->list (datum->syntax #f (cdr stx)))]
+                 [splice? (free-identifier=? #'unsyntax-splicing (car stx))])
+             (unless l
+               (raise-syntax-error #f
+                                   "bad syntax"
+                                   (datum->syntax src stx src src)))
+             (if (zero? depth)
+                 ;; Escape:
+                 (let ([id (car (generate-temporaries '(un)))])
+                   (when (or splice? (not (= 1 (length l))))
+                     (unless to-splice?
+                       (raise-syntax-error #f
+                                           "not in a splicing context"
+                                           (datum->syntax src stx src src))))
+                   (if (= (length l) 1)
+                       ;; Normal substitution:
+                       (k (if to-splice? 
+                              (if splice?
+                                  (list id (quote-syntax ...))
+                                  (list id))
+                              id)
+                          (list (if splice?
+                                    (list id (quote-syntax ...))
+                                    id))
+                          (list (car l)))
+                       ;; Splicing (or double-splicing) substitution:
+                       (k (if splice?
+                              (list id (quote-syntax ...) (quote-syntax ...))
+                              (list id (quote-syntax ...)))
+                          (list
+                           (if splice?
+                               (list (list id (quote-syntax ...)) (quote-syntax ...))
+                               (list id (quote-syntax ...))))
+                          (list (if splice?
+                                    #`(map convert-mpairs (list . #,(cdr stx)))
+                                    #`(list . #,(cdr stx)))))))
+                 ;; Not an escape -- just decrement depth:
+                 (loop (cdr stx)
+                       src
+                       (sub1 depth)
+                       #f
+                       (lambda (t pats exprs)
+                         (k (let ([v (cons (car stx) t)])
+                              (if to-splice?
+                                  (list v)
+                                  v))
+                            pats
+                            exprs)))))]
+          [(and (identifier? (car stx))
+                (free-identifier=? #'r6rs:quasisyntax (car stx)))
+           (loop (cdr stx)
+                 src
+                 (add1 depth)
+                 #f
+                 (lambda (t pats exprs)
+                   (k (let ([v (cons (car stx) t)])
+                        (if to-splice?
+                            (list v)
+                            v))
+                      pats
+                      exprs)))]
+          [else
+           ;; a pair
+           (loop (car stx)
+                 src
+                 depth
+                 #t
+                 (lambda (a a-pats a-exprs)
+                   (loop (cdr stx)
+                         src
+                         depth
+                         #f
+                         (lambda (b b-pats b-exprs)
+                           (k (let ([v (append a b)])
+                                (if to-splice?
+                                    (list v)
+                                    v))
+                              (append a-pats b-pats)
+                              (append a-exprs b-exprs))))))])]
+        [(vector? stx)
+         (loop (vector->list stx)
+               src
+               depth
+               #f
+               (lambda (t pats exprs)
+                 (k (let ([v (list->vector t)])
+                      (if to-splice?
+                          (list v)
+                          v))
+                    pats
+                    exprs)))]
+        [else (k (if to-splice? (list stx) stx) null null)]))]))
diff --git a/collects/tests/r6rs/hashtables.ss b/collects/tests/r6rs/hashtables.ss
index a26fc4e7b3..1016083240 100644
--- a/collects/tests/r6rs/hashtables.ss
+++ b/collects/tests/r6rs/hashtables.ss
@@ -5,6 +5,92 @@
   (import (rnrs)
           (tests r6rs test))
 
+  (define-syntax test-ht
+    (syntax-rules ()
+      [(_ mk ([key val] ...)
+          key/r orig-val new-val
+          key/a a-val
+          key/rm)
+       (let ([h mk])
+         (test (hashtable? h) #t)
+         (test (hashtable-size h) 0)
+         (test (hashtable-ref h key/r 'nope) 'nope)
+         (test/unspec (hashtable-delete! h key)) ...
+         (test (hashtable-size h) 0)
+
+         (test (hashtable-ref h key/r 'nope) 'nope)
+         (test (hashtable-contains? h key/r) #f)
+         (test/unspec (hashtable-set! h key/r orig-val))
+         (test (hashtable-ref h key/r 'nope) orig-val)
+         (test (hashtable-contains? h key/r) #t)
+         (test (hashtable-size h) 1)
+
+         (test/unspec (hashtable-set! h key val)) ...
+         (test (hashtable-size h) (length '(key ...)))
+         (test (hashtable-ref h key/r 'nope) orig-val)
+         (test (hashtable-ref h key 'nope) val) ...
+
+         (let ([h1 (hashtable-copy h #t)]
+               [h1i (hashtable-copy h)])
+           (test (hashtable-mutable? h) #t)
+           (test (hashtable-mutable? h1) #t)
+           (test (hashtable-mutable? h1i) #f)
+           
+           (test (vector-length (hashtable-keys h))
+                 (hashtable-size h))
+           (test (vector-length (let-values ([(k e) (hashtable-entries h)])
+                                  e))
+                 (hashtable-size h))
+           (test (exists (lambda (v) (eq? v key/r))
+                         (vector->list (hashtable-keys h)))
+                 #t)
+
+           (test/unspec (hashtable-set! h key/r new-val))
+           (test (hashtable-contains? h key/r) #t)
+           (test (hashtable-ref h key/r 'nope) new-val)
+
+           (test/unspec (hashtable-update! h key/r (lambda (v)
+                                                     (test v new-val)
+                                                     orig-val)
+                                           'nope))
+           (test (hashtable-ref h key/r 'nope) orig-val)
+           (test/unspec (hashtable-update! h key/r (lambda (v)
+                                                     (test v orig-val)
+                                                     new-val)
+                                           'nope))
+           (test (hashtable-ref h key/r 'nope) new-val)
+
+           (test/unspec (hashtable-update! h key/a (lambda (v)
+                                                     (test v 'nope)
+                                                     a-val)
+                                           'nope))
+           (test (hashtable-ref h key/a 'nope) a-val)
+           (test/unspec (hashtable-delete! h key/a))
+
+           (test (hashtable-contains? h key/rm) #t)
+           (hashtable-delete! h key/rm)
+           (test (hashtable-contains? h key/rm) #f)
+           (test (hashtable-ref h key/rm 'nope) 'nope)
+
+           (test (hashtable-ref h1 key 'nope) val) ...
+           (test (hashtable-ref h1i key 'nope) val) ...
+           (test (hashtable-contains? h1 key/rm) #t)
+           (test (hashtable-contains? h1i key/rm) #t)
+
+           (hashtable-clear! h)
+           (test (hashtable-contains? h key) #f) ...
+           (test (hashtable-contains? h1 key) #t) ...
+           (test (hashtable-contains? h1i key) #t) ...
+
+           (test/unspec (hashtable-clear! h1))
+           
+           (test/exn (hashtable-set! h1i key/r #f) &violation)
+           (test/exn (hashtable-delete! h1i key/r) &violation)
+           (test/exn (hashtable-update! h1i key/r (lambda (q) q) 'none) &violation)
+           (test/exn (hashtable-clear! h1i) &violation)))]))
+  
+  ;; ----------------------------------------
+
   (define (run-hashtables-tests)
 
     (let-values ([(kv vv)
@@ -26,6 +112,56 @@
                 (equal? (cons kv vv)
                         '(#(3 2 1)  . #(three two one))))
             #t))
+    
+    (test-ht (make-eq-hashtable)
+             (['a 7] ['b "bee"]
+              [#t 8] [#f 9]
+              ['c 123456789101112])
+             'b "bee" "bumble"
+             'd 12
+             'c)
+    
+    (test-ht (make-eqv-hashtable)
+             (['a 7] [#\b "bee"]
+              [#t 8] [0.0 85]
+              [123456789101112 'c])
+             #\b "bee" "bumble"
+             'd 12
+             123456789101112)
+
+    (let ([val-of (lambda (a)
+                    (if (number? a) 
+                        a 
+                        (string->number a)))])
+      (test-ht (make-hashtable val-of
+                               (lambda (a b)
+                                 (= (val-of a) (val-of b))))
+               ([1 'one]["2" 'two]
+                [3 'three]["4" 'four])
+               2 'two 'er
+               5 'five
+               4))
+
+    (test (hashtable? (make-eq-hashtable 10)) #t)
+    (test (hashtable? (make-eqv-hashtable 10)) #t)
+    (test (hashtable? (make-hashtable (lambda (x) 0) equal? 10)) #t)
+    
+    (let ([zero (lambda (a) 0)]
+          [same? (lambda (a b) #t)])
+      (let ([ht (make-hashtable zero same?)])
+        (test (hashtable-equivalence-function ht) same?)
+        (test (hashtable-hash-function ht) zero)))
+
+    (test (equal-hash "a") (equal-hash (make-string 1 #\a)))
+    (test (equal-hash 1024) (equal-hash (expt 2 10)))
+    (test (equal-hash '(1 2 3)) (equal-hash (list 1 2 3)))
+
+    (test (string-hash "a") (string-hash (make-string 1 #\a)))
+    (test (string-hash "aaaaa") (string-hash (make-string 5 #\a)))
+    (test (string-ci-hash "aAaAA") (string-hash (make-string 5 #\a)))
+
+    (test (symbol-hash 'a) (symbol-hash 'a))
+
     ;;
     ))
 
diff --git a/collects/tests/r6rs/syntax-case.ss b/collects/tests/r6rs/syntax-case.ss
index c38d21dfad..93619b62ef 100644
--- a/collects/tests/r6rs/syntax-case.ss
+++ b/collects/tests/r6rs/syntax-case.ss
@@ -3,6 +3,7 @@
 (library (tests r6rs syntax-case)
   (export run-syntax-case-tests)
   (import (for (rnrs) run expand)
+          (rename (only (rnrs base) cons) (cons kons)) ; for free-identifier=?
           (tests r6rs test))
 
   ;; ----------------------------------------
@@ -110,7 +111,167 @@
              (set! ls (cons 'a ls))
              (set! n (- n 1)))) 
           '(a a a))
+
+    ;; ----------------------------------------
+
+    (test (syntax-case #'1 () [1 'one])  'one)
+    (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) (syntax->datum #'x)]) 'a)
+    (test (syntax-case '(a 1 #f "s" #vu8(9) #(5 7)) () 
+            [(x ...) #'(x ...)]) 
+          '(a 1 #f "s" #vu8(9) #(5 7)))
+    (test (syntax-case #'(a 1 #f "s" #vu8(9) #(5 7)) () 
+            [(x ...) (map syntax->datum #'(x ...))]) 
+          '(a 1 #f "s" #vu8(9) #(5 7)))
+    (test (syntax-case '(a b c d) () [(x y . z) #'z]) '(c d))
+    (test (syntax-case #'(a b c d) () [(x y . z) (syntax->datum #'z)]) 
+          '(c d))
+    (test (syntax-case '(nonesuch 12) (nonesuch) [(nonesuch x) #'x])
+          12)
+    (test (syntax-case '(different 12) (nonesuch) 
+            [(nonesuch x) #'x]
+            [_ 'other])
+          'other)
+    (test (syntax-case '(1 2 3 4) ()
+            [(1 x ...) #'(x ...)])
+          '(2 3 4))
+    (test (syntax-case '(1 2 3 4) ()
+            [(1 x ... 3 4) #'(x ...)])
+          '(2))
+    (test (syntax-case '(1 2 3 4) ()
+            [(1 x ... 2 3 4) #'(x ...)])
+          '())
+    (test (syntax-case '(1 2 3 4) ()
+            [(1 x ... . y) #'y])
+          '())
+    (test (syntax-case '(1 2 3 4 . 5) ()
+            [(1 x ... . y) #'y])
+          '5)
+    (test (syntax-case '(1 2 3 4 . 5) ()
+            [(1 x ... 4 . y) #'y])
+          '5)
+    (test (syntax-case '(1 2 3 4 . 5) ()
+            [(1 x ... 5 . y) #'y]
+            [_ 'no])
+          'no)
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x y 4) (car #'(x y))])
+          '2)
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x y 4) (cadr #'(x y))])
+          '3)
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x y 4) (syntax->datum (cddr #'(x y)))])
+          '())
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 2 3 4) 'match])
+          'match)
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x y 4) #'y])
+          '3)
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x ...) #'(x ...)])
+          '(2 3 4))
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x ... 4) #'(x ...)])
+          '(2 3))
+    (test (syntax-case '#(1 2 3 4) ()
+            [#(1 x ... 2 3 4) #'(x ...)])
+          '())
+    (test (syntax-case #'(1) ()
+            [(_) (syntax->datum #'_)])
+          '_)
+
+    (test (identifier? 'x) #f)
+    (test (identifier? #'x) #t)
+    (test (bound-identifier=? #'x #'x) #t)
+    (test (bound-identifier=? #'x #'y) #f)
+    (test (bound-identifier=? #'cons #'kons) #f)
+    (test (free-identifier=? #'x #'x) #t)
+    (test (free-identifier=? #'x #'y) #f)
+    (test (free-identifier=? #'cons #'kons) #t)
+
+    (test (syntax->datum #'1) 1)
+    (test (syntax->datum #'a) 'a)
+    (test (syntax->datum #'(a b)) '(a b))
+    (test (syntax->datum #'(a . b)) '(a . b))
+
+    (test (syntax->datum (datum->syntax #'x 1)) 1)
+    (test (syntax->datum (datum->syntax #'x 'a)) 'a)
+    (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 (map identifier? (generate-temporaries '(1 2 3))) '(#t #t #t))
+    (test (map identifier? (generate-temporaries #'(1 2 3))) '(#t #t #t))
+    (test (map identifier? (generate-temporaries (cons 1 #'(2 3)))) '(#t #t #t))
+
+    (test (cadr (with-syntax ([x 1]
+                              [y 2])
+                  #'(x y)))
+          2)
+
+    (test (syntax->datum #`(1 2 3)) '(1 2 3))
+    (test (syntax->datum #`1) 1)
     
+    ;; Check wrapping:
+    (test (let ([v #`(1 #,(+ 1 1) 3)])
+            (list (pair? v)
+                  (syntax->datum (car v))
+                  (cadr v)
+                  (syntax->datum (cddr v))))
+          '(#t 1 2 (3)))
+    (test (let ([v #`(1 #,@(list (+ 1 1)) 3)])
+            (list (pair? v)
+                  (syntax->datum (car v))
+                  (cadr v)
+                  (syntax->datum (cddr v))))
+          '(#t 1 2 (3)))
+    (test (let ([v #`(1 #,@(list (+ 1 1) (- 8 1)) 3)])
+            (list (pair? v)
+                  (syntax->datum (car v))
+                  (cadr v)
+                  (caddr v)
+                  (syntax->datum (cdddr v))))
+          '(#t 1 2 7 (3)))
+    (test (syntax-case '(1 2 3) ()
+            [(x ...) #`(x ...)])
+          '(1 2 3))
+
+    (test (syntax->datum
+           (datum->syntax #'x
+            #`(1 2 (unsyntax 3 4 5) 6)))
+          '(1 2 3 4 5 6))
+    (test (syntax->datum
+           (datum->syntax #'x
+            #`(1 2 (unsyntax-splicing '(3 4) '(5)) 6)))
+          '(1 2 3 4 5 6))
+
+    (test (syntax->datum
+           (datum->syntax #'x
+            #`#(1 2 (unsyntax-splicing '(3 4) '(5)) 6)))
+          '#(1 2 3 4 5 6))
+
+    (test (syntax->datum
+           (datum->syntax #'x
+            #`(1 #`(#,(+ 3 4) #,#,(+ 1 1)))))
+          '(1 #`(#,(+ 3 4) #,2)))
+
+    (test/exn (syntax-violation #f "bad" 7) &syntax)
+    (test/exn (syntax-violation 'form "bad" 7) &syntax)
+    (test/exn (syntax-violation #f "bad" #'7) &syntax)
+    (test/exn (syntax-violation #f "bad" #'7 8) &syntax)
+    (test/exn (syntax-violation #f "bad" #'7 #'8) &syntax)
+    (test/exn (syntax-violation #f "bad" 7 #'8) &syntax)
+    (test/exn (syntax-violation 'form "bad" #'7 #'8) &syntax)
+    (test/exn (syntax-violation 'form "bad" 7 #'8) &syntax)
+    (test/exn (syntax-violation 'form "bad" #'7 8) &syntax)
+    (test/exn (syntax-violation 'form "bad" 7 8) &syntax)
+
     ;;
     ))