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

Merge branch 'master' of git.racket-lang.org:plt

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-29 13:41:26 -06:00
commit 3b23f74fc7
5 changed files with 25 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -10,7 +10,8 @@
# a common convenient place to set the PLTADDON directory to
/add-on/
# common backups, autosaves, and lock files
# common backups, autosaves, lock files, OS meta-files
*~
\#*
.#*
.DS_Store

8
collects/racket/contract/private/base.rkt
View File

@ -27,21 +27,21 @@ improve method arity mismatch contract violation error messages?
(syntax-case stx ()
[(_ c v pos neg name loc)
(syntax/loc stx
(apply-contract c v pos neg name loc))]
(apply-contract c v pos neg name loc (current-contract-region)))]
[(_ c v pos neg)
(syntax/loc stx
(apply-contract c v pos neg #f (build-source-location #f)))]
(apply-contract c v pos neg #f (build-source-location #f) (current-contract-region)))]
[(_ c v pos neg src)
(raise-syntax-error 'contract
(string-append
"please update contract application to new protocol "
"(either 4 or 6 arguments)"))]))
(define (apply-contract c v pos neg name loc)
(define (apply-contract c v pos neg name loc usr)
(let* ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg #t))
(make-blame loc name (contract-name c) pos neg usr #t))
v)))
(define-syntax (recursive-contract stx)

11
collects/racket/contract/private/blame.rkt
View File

@ -34,7 +34,7 @@
(hash/recur (blame-original? b))))
(define-struct blame
[source value contract positive negative original?]
[source value contract positive negative user original?]
#:property prop:equal+hash
(list blame=? blame-hash blame-hash))
@ -64,12 +64,17 @@
[contract-message (show/write (blame-contract b))]
[value-message (if (blame-value b)
(format " on ~a" (show/display (blame-value b)))
"")])
(format "~a~a broke the contract ~a~a; ~a"
"")]
[user-message (if (or (blame-original? b)
(equal? (blame-positive b) (blame-user b)))
""
(format " given to ~a" (show/display (blame-user b))))])
(format "~a~a broke the contract ~a~a~a; ~a"
source-message
positive-message
contract-message
value-message
user-message
custom-message)))
(define ((show f) v)

6
collects/racket/contract/private/legacy.rkt
View File

@ -21,7 +21,8 @@
name
(unpack-blame pos)
"<<unknown party>>"
#t)
#t
name)
x
fmt
args))
@ -58,7 +59,8 @@
name
(unpack-blame (if original? pos neg))
(unpack-blame (if original? neg pos))
original?)))))
original?
name)))))
(define (legacy-property name)
(define-values [ prop pred get ]

14
collects/redex/tests/tl-test.rkt
View File

@ -646,13 +646,13 @@
(parameterize ([current-output-port sp]
[current-traced-metafunctions 'all])
(term (f 1)))
(test (get-output-string sp) ">(f 1)\n<0\n"))
(test (get-output-string sp) ">`(f 1)\n<0\n"))
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp]
[current-traced-metafunctions '(f)])
(term (f 1)))
(test (get-output-string sp) ">(f 1)\n<0\n")))
(test (get-output-string sp) ">`(f 1)\n<0\n")))
(let ()
(define-language var-lang [(x y z w) variable])
@ -1753,7 +1753,7 @@
[c (make-coverage T)])
(parameterize ([relation-coverage (list c)])
(apply-reduction-relation T (term q))
(test (and (regexp-match #px"tl-test.ss:\\d+:\\d+" (caar (covered-cases c))) #t)
(test (and (regexp-match #px"tl-test.(?:.+):\\d+:\\d+" (caar (covered-cases c))) #t)
#t))))
(let* ([R (reduction-relation
@ -1772,7 +1772,7 @@
second
(curry regexp-match #px".*:(\\d+):\\d+"))])
(< (line-no (car c)) (line-no (car d)))))]
[src-ok? (curry regexp-match? #px"tl-test.ss:\\d+:\\d+")]
[src-ok? (curry regexp-match? #px"tl-test.(?:.+):\\d+:\\d+")]
[sorted-counts (λ (cc) (map cdr (sort (covered-cases cc) <)))])
(define-metafunction empty-language
[(f 1) 1]
@ -1851,7 +1851,7 @@
(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"))
#rx"FAILED tl-test.(?:.+):[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n"))
(let ()
(define red-share (reduction-relation
@ -1870,7 +1870,7 @@
(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"))
#rx"FAILED tl-test.(?:.+):[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
(let ()
(define-metafunction empty-language [(f any) ((any))])
@ -1913,7 +1913,7 @@
(test (capture-output (test--> R #:equiv mod2=? 7 1 0) (test-results))
"One test passed.\n")
(test (capture-output (test--> R #:equiv mod2=? 7 1) (test-results))
#rx"FAILED tl-test.ss:[0-9.]+\nexpected: 1\n actual: 8\n actual: 7\n1 test failed \\(out of 1 total\\).\n"))
#rx"FAILED tl-test.(?:.+):[0-9.]+\nexpected: 1\n actual: 8\n actual: 7\n1 test failed \\(out of 1 total\\).\n"))
(let-syntax ([test-bad-equiv-arg
(λ (stx)