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

trying to fight runtime errors

Browse Source
This commit is contained in:
Danny Yoo 2012-10-23 17:53:44 -06:00
parent 433a73aefa
commit 6cb8309ea0
1 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
tests/browser-harness.rkt
View File

@ -23,18 +23,18 @@
(define evaluate (make-evaluate (define evaluate (make-evaluate
(lambda (program op) (lambda (program op)
(fprintf op "(function () {") (fprintf op "(function () {")
(newline op) (newline op)
(when first-run (when first-run
(display (get-runtime) op) (display (get-runtime) op)
(set! first-run #f)) (set! first-run #f))
(display "return (function(succ, fail, params) { (display "return (function(succ, fail, params) {
var machine = new plt.runtime.Machine(); var machine = new plt.runtime.Machine();
plt.runtime.currentMachine = machine;" op) plt.runtime.currentMachine = machine;" op)
(package program (package program
#:should-follow-children? (lambda (src) #t) #:should-follow-children? (lambda (src) #t)
#:output-port op) #:output-port op)
@ -59,15 +59,15 @@
s s
"<path:...>")) "<path:...>"))
;; We use a customized error structure that supports ;; We use a customized error structure that supports
;; source location reporting. ;; source location reporting.
(define-struct (exn:fail:error-on-test exn:fail) (define-struct (exn:fail:error-on-test exn:fail)
(srcloc) (srcloc)
#:property prop:exn:srclocs #:property prop:exn:srclocs
(lambda (a-struct) (lambda (a-struct)
(list (exn:fail:error-on-test-srcloc a-struct)))) (list (exn:fail:error-on-test-srcloc a-struct))))
@ -86,9 +86,9 @@
[else [else
(printf " error!\n") (printf " error!\n")
(displayln (exn-message (make-exn:fail:error-on-test (displayln (exn-message (make-exn:fail:error-on-test
(format "Expected ~s, got ~s" exp output) (format "Expected ~s, got ~s" exp output)
(current-continuation-marks) (current-continuation-marks)
(loc-thunk))))]))) (loc-thunk))))])))
@ -100,15 +100,17 @@
(syntax-e (syntax-e
#'source-file-path) #'source-file-path)
".expected")]) ".expected")])
#'(test source-file-path expected-file-path))] #'(test source-file-path expected-file-path))]
[(_ original-source-file-path original-expected-file-path) [(_ original-source-file-path original-expected-file-path)
(with-syntax ([stx stx] (with-syntax ([stx stx]
[source-file-path (parameterize ([current-directory [source-file-path (parameterize ([current-directory
(current-load-relative-directory)]) (or (current-load-relative-directory)
(current-directory))])
(normalize-path (syntax-e #'original-source-file-path)))] (normalize-path (syntax-e #'original-source-file-path)))]
[expected-file-path (parameterize ([current-directory [expected-file-path (parameterize ([current-directory
(current-load-relative-directory)]) (or (current-load-relative-directory)
(current-directory))])
(normalize-path (syntax-e #'original-expected-file-path)))]) (normalize-path (syntax-e #'original-expected-file-path)))])
(quasisyntax/loc #'stx (quasisyntax/loc #'stx
(test/loc original-source-file-path source-file-path (test/loc original-source-file-path source-file-path
@ -119,6 +121,6 @@
'#,(syntax-column #'stx) '#,(syntax-column #'stx)
'#,(syntax-position #'stx) '#,(syntax-position #'stx)
'#,(syntax-span #'stx))))))])) '#,(syntax-span #'stx))))))]))
(provide test) (provide test)