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

sync to trunk again

Browse Source 
svn: r14006
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-07 19:10:50 +00:00
commit 09ee5d37a5
4 changed files with 72 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/redex/private/reduction-semantics.ss
View File

@ -1730,18 +1730,19 @@
(define (apply-reduction-relation*/cycle? reductions exp) (define (apply-reduction-relation*/cycle? reductions exp)
(let ([answers (make-hash)] (let ([answers (make-hash)]
[cycle? #f] [cycle? #f])
[cycles (make-hash)]) (let loop ([exp exp]
(let loop ([exp exp]) [path (make-immutable-hash '())])
(cond (cond
[(hash-ref cycles exp #f) [(hash-ref path exp #f)
(set! cycle? #t)] (set! cycle? #t)]
[else [else
(hash-set! cycles exp #t)
(let ([nexts (apply-reduction-relation reductions exp)]) (let ([nexts (apply-reduction-relation reductions exp)])
(cond (cond
[(null? nexts) (hash-set! answers exp #t)] [(null? nexts) (hash-set! answers exp #t)]
[else (for-each loop nexts)]))])) [else (for-each
(λ (next) (loop next (hash-set path exp #t)))
nexts)]))]))
(values (sort (hash-map answers (λ (x y) x)) (values (sort (hash-map answers (λ (x y) x))
string<=? string<=?
#:key (λ (x) (format "~s" x))) #:key (λ (x) (format "~s" x)))
@ -1849,9 +1850,13 @@
[(= tests 0) [(= tests 0)
(printf "No tests run.\n")] (printf "No tests run.\n")]
[(= test-failures 0) [(= test-failures 0)
(if (= tests 1) (cond
(printf "One test passed.\n") [(= tests 1)
(printf "All ~a tests passed.\n" tests))] (printf "One test passed.\n")]
[(= tests 2)
(printf "Both tests passed.\n")]
[else
(printf "All ~a tests passed.\n" tests)])]
[else [else
(printf "~a test~a failed (out of ~a total).\n" (printf "~a test~a failed (out of ~a total).\n"
test-failures test-failures

53
collects/redex/private/tl-test.ss
View File

@ -1393,4 +1393,57 @@
(test (sort (covered-cases c) <) (test (sort (covered-cases c) <)
'(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1))))) '(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
;
;
;
;
; ;;;
; ;; ;; ; ;; ;;
; ;; ;; ; ;; ;;
; ;;;;; ;;; ;;; ;;;;; ;; ;;; ;;;; ;;;;
; ;; ;; ;; ;; ; ;; ;;;;;;;; ;; ;;; ;; ; ;; ;;
; ;; ;;;;; ;;; ;; ;;; ;; ; ;; ;; ;; ;;
; ;; ;; ;; ;; ;;; ;; ;;;; ;; ;; ;;
; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ; ;; ;;
; ;;;; ;;; ;;; ;;;; ; ;;;;; ;; ;;;; ;;;;
;
;
;
(define-syntax-rule
(capture-output arg1 args ...)
(let ([p (open-output-string)])
(parameterize ([current-output-port p]
[current-error-port p])
arg1 args ...)
(get-output-string p)))
(let ()
(define red (reduction-relation empty-language (--> 1 2)))
(test (capture-output (test--> red 1 2) (test-results))
"One test passed.\n")
(test (capture-output (test--> red 2 3) (test-results))
#rx"FAILED tl-test.ss:[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n"))
(let ()
(define red-share (reduction-relation
empty-language
(--> a b)
(--> a c)
(--> c d)
(--> b d)))
(test (capture-output (test--> red-share (term a) (term d)) (test-results))
"One test passed.\n"))
(let ()
(define red-cycle (reduction-relation
empty-language
(--> a a)))
(test (capture-output (test--> red-cycle #:cycles-ok (term a)) (test-results))
"One test passed.\n")
(test (capture-output (test--> red-cycle (term a)) (test-results))
#rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
(print-tests-passed 'tl-test.ss)) (print-tests-passed 'tl-test.ss))

7
collects/scheme/private/contract.ss
View File

@ -132,7 +132,8 @@ improve method arity mismatch contract violation error messages?
(define (build-struct-names name field-infos) (define (build-struct-names name field-infos)
(let ([name-str (symbol->string (syntax-e name))]) (let ([name-str (symbol->string (syntax-e name))])
(list* (datum->syntax (list* name
(datum->syntax
name name
(string->symbol (string->symbol
(string-append "struct:" name-str))) (string-append "struct:" name-str)))
@ -284,7 +285,7 @@ improve method arity mismatch contract violation error messages?
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))] (let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)] [sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
[names (build-struct-names #'name field-infos)] [names (build-struct-names #'name field-infos)]
[pred (caddr names)] [pred (cadddr names)]
[ctcs (build-contracts stx pred field-infos)]) [ctcs (build-contracts stx pred field-infos)])
(let-values ([(non-auto-fields auto-fields) (let-values ([(non-auto-fields auto-fields)
(let loop ([fields field-infos] (let loop ([fields field-infos]
@ -306,7 +307,7 @@ improve method arity mismatch contract violation error messages?
(field-info-stx (car fields)))))))]) (field-info-stx (car fields)))))))])
(with-syntax ([ctc-bindings (with-syntax ([ctc-bindings
(let ([val-bindings (if (s-info-def-vals? sinfo) (let ([val-bindings (if (s-info-def-vals? sinfo)
(map list (cdr names) ctcs) (cons (cadr names) (map list (cddr names) ctcs))
null)]) null)])
(if (s-info-def-stxs? sinfo) (if (s-info-def-stxs? sinfo)
(cons (car names) val-bindings) (cons (car names) val-bindings)

2
collects/scribblings/reference/custom-ports.scrbl
View File

@ -892,7 +892,7 @@ procedures.
result is the number of bytes written. result is the number of bytes written.
If @scheme[get-write-evt] is @scheme[#f], then If @scheme[get-write-evt] is @scheme[#f], then
@scheme[port-writes-atomic?] will produce @scheme[#f] with applied @scheme[port-writes-atomic?] will produce @scheme[#f] when applied
to the port, and the port will not be a valid argument to to the port, and the port will not be a valid argument to
procedures such as @scheme[write-bytes-avail-evt]. procedures such as @scheme[write-bytes-avail-evt].