From 4e6639fb2f77920d64f42ac130da08d8d666432a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 May 2008 13:52:05 +0000 Subject: [PATCH] r6rs tests and bug fixes svn: r9563 --- collects/r5rs/main.ss | 2 +- collects/rnrs/enums-6.ss | 10 ++-- collects/rnrs/r5rs-6.ss | 2 - collects/rnrs/syntax-case-6.ss | 9 ++++ collects/scribblings/reference/class.scrbl | 4 +- .../scribblings/reference/surrogate.scrbl | 11 ++-- collects/tests/r6rs/enums.ss | 42 +++++++++++++++ collects/tests/r6rs/r5rs.ss | 16 ++++++ collects/tests/r6rs/syntax-case.ss | 52 +++++++++++-------- 9 files changed, 111 insertions(+), 37 deletions(-) diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index bf10766763..fb97997ea7 100644 --- a/collects/r5rs/main.ss +++ b/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)))) diff --git a/collects/rnrs/enums-6.ss b/collects/rnrs/enums-6.ss index f1ba2fbb18..b88f82a018 100644 --- a/collects/rnrs/enums-6.ss +++ b/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)))]) - (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) diff --git a/collects/rnrs/r5rs-6.ss b/collects/rnrs/r5rs-6.ss index 821e794be6..c5799de829 100644 --- a/collects/rnrs/r5rs-6.ss +++ b/collects/rnrs/r5rs-6.ss @@ -11,5 +11,3 @@ [r5rs:force force] [r5rs:null-environment null-environment] [r5rs:scheme-report-environment scheme-report-environment])) - - \ No newline at end of file diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index b3a14e1bfc..5f838ab17e 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/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) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 980885a685..02eae7698e 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1709,4 +1709,6 @@ a method that is not supplied by an object. } -@include-section["surrogate.scrbl"] \ No newline at end of file +@; ---------------------------------------------------------------------- + +@include-section["surrogate.scrbl"] diff --git a/collects/scribblings/reference/surrogate.scrbl b/collects/scribblings/reference/surrogate.scrbl index 29a58b9c97..bc57f9fd16 100644 --- a/collects/scribblings/reference/surrogate.scrbl +++ b/collects/scribblings/reference/surrogate.scrbl @@ -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 diff --git a/collects/tests/r6rs/enums.ss b/collects/tests/r6rs/enums.ss index 65943f05ef..364954d332 100644 --- a/collects/tests/r6rs/enums.ss +++ b/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)))) diff --git a/collects/tests/r6rs/r5rs.ss b/collects/tests/r6rs/r5rs.ss index d091bf6685..712f7ad226 100644 --- a/collects/tests/r6rs/r5rs.ss +++ b/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)) + ;; )) diff --git a/collects/tests/r6rs/syntax-case.ss b/collects/tests/r6rs/syntax-case.ss index 93619b62ef..516786ec4e 100644 --- a/collects/tests/r6rs/syntax-case.ss +++ b/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) (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)