suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r6rs tests and bug fixes

Browse Source 
svn: r9563
This commit is contained in:
Matthew Flatt 2008-05-01 13:52:05 +00:00
parent 949a6e3916
commit 4e6639fb2f
9 changed files with 111 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/r5rs/main.ss
View File

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

10
collects/rnrs/enums-6.ss
View File

@ -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)))])
(or (zero? (bitwise-and v1 val1))
(let ([val2 (hash-ref ht2 key1 #f)])
(and val2
([(key1 val1) (in-hash (universe-ht (enum-set-uni enum1)))]
#:when sub?)
(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)

2
collects/rnrs/r5rs-6.ss
View File

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

9
collects/rnrs/syntax-case-6.ss
View File

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

4
collects/scribblings/reference/class.scrbl
View File

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

11
collects/scribblings/reference/surrogate.scrbl
View File

@ -1,12 +1,11 @@
#lang scribble/doc
@(require
scribble/basic
scribble/manual
(for-label scheme/surrogate
scheme/class))
@(require "mz.ss"
(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

42
collects/tests/r6rs/enums.ss
View File

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

16
collects/tests/r6rs/r5rs.ss
View File

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

52
collects/tests/r6rs/syntax-case.ss
View File

@ -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) (syntax->datum #'x)]) 'a)
(test (syntax-case '(a 1 #f "s" #vu8(9) #(5 7)) ()
(test (syntax-case '("a") () [(x) #'x]) "a")
(test (syntax-case #'("a") () [(x) (syntax->datum #'x)]) "a")
(test (syntax-case '(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)) ()
'(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)))
(test (syntax-case '(a b c d) () [(x y . z) #'z]) '(c d))
'(1 #f "s" #vu8(9) #(5 7)))
(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
#`(1 2 (unsyntax 3 4 5) 6)))
(test (unwrap
#`(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)))
(test (unwrap
#`(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)))
(test (unwrap
#`#(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)))))
(test (unwrap
#`(1 #`(#,(+ 3 4) #,#,(+ 1 1))))
'(1 #`(#,(+ 3 4) #,2)))
(test/exn (syntax-violation #f "bad" 7) &syntax)