r6rs tests and bug fixes

svn: r9558
This commit is contained in:
Matthew Flatt 2008-05-01 12:28:14 +00:00
parent 77277f0405
commit a09b2eca94
4 changed files with 450 additions and 12 deletions

View File

@ -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)]

View File

@ -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)]))]))

View File

@ -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))
;;
))

View File

@ -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))
;; ----------------------------------------
@ -111,6 +112,166 @@
(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)
;;
))