r6rs tests and bug fixes
svn: r9558
This commit is contained in:
parent
77277f0405
commit
a09b2eca94
|
@ -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)]
|
||||
|
|
|
@ -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)]))]))
|
||||
|
|
|
@ -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))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user