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

fixing some tests

Browse Source
This commit is contained in:
Danny Yoo 2011-06-01 14:18:15 -04:00
parent 5445ae1afc
commit 35284eafbe
10 changed files with 85 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -18,6 +18,11 @@ test-compiler:
racket tests/test-compiler.rkt
test-parse-bytecode-on-collects:
raco make -v --disable-inline tests/test-parse-bytecode-on-collects.rkt
racket tests/test-parse-bytecode-on-collects.rkt
test-earley:
raco make -v --disable-inline tests/test-earley.rkt
racket tests/test-earley.rkt

44
call-with-timeout.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket/base
(provide (struct-out exn:fail:timeout)
call-with-timeout)
(define-struct (exn:fail:timeout exn:fail) (msecs))
(define-struct good-value (v))
(define-struct bad-value (exn))
;; call-with-timeout: (-> any) number -> any
;; Calls a thunk, with a given timeout.
(define (call-with-timeout thunk timeout)
(let ([ch (make-channel)]
[alarm-e
(alarm-evt (+ (current-inexact-milliseconds)
timeout))])
(let* ([cust (make-custodian)]
[th (parameterize ([current-custodian cust])
(thread (lambda ()
(channel-put ch
(with-handlers ([void
(lambda (e)
(make-bad-value e))])
(make-good-value (thunk)))))))])
(let ([result (sync ch
(handle-evt alarm-e
(lambda (false-value)
(begin0
(make-bad-value
(make-exn:fail:timeout
"timeout"
(current-continuation-marks)
timeout))
(custodian-shutdown-all cust)
(kill-thread th)))))])
(cond
[(good-value? result)
(good-value-v result)]
[(bad-value? result)
(raise (bad-value-exn result))])))))

21
get-module-bytecode.rkt
View File

@ -10,11 +10,6 @@
(define-runtime-path kernel-language-path
"lang/kernel.rkt")
(define base-namespace
(lookup-language-namespace
#;'racket/base
`(file ,(path->string kernel-language-path)))
#;(make-base-namespace))
(define (get-module-bytecode x)
(let ([compiled-code
@ -37,8 +32,9 @@
(get-output-bytes op))))
;; Tries to use get-module-code to grab at module bytecode. Sometimes this fails
;; because it appears get-module-code tries to write to compiled/.
;; Tries to use get-module-code to grab at module bytecode. Sometimes
;; this fails because it appears get-module-code tries to write to
;; compiled/.
(define (get-compiled-code-from-path p)
(with-handlers ([void (lambda (exn)
;; Failsafe: try to do it from scratch
@ -48,6 +44,17 @@
(get-module-code p)))
(define base-namespace
(lookup-language-namespace
#;'racket/base
`(file ,(path->string kernel-language-path)))
#;(make-base-namespace))
(define (get-compiled-code-from-port ip)
(parameterize ([read-accept-reader #t]
[current-namespace base-namespace])

10
js-assembler/package.rkt
View File

@ -8,6 +8,8 @@
(prefix-in racket: racket/base))
;; TODO: put proper contracts here
(provide package
package-anonymous
@ -97,14 +99,14 @@
(let ([packaging-configuration
(make-Configuration
;; should-follow?
(lambda (p) #t)
(lambda (src p) #t)
;; on
(lambda (ast stmts)
(lambda (src ast stmts)
(assemble/write-invoke stmts op)
(fprintf op "(MACHINE, function() { "))
;; after
(lambda (ast stmts)
(lambda (src ast stmts)
(fprintf op " }, FAIL, PARAMS);"))
;; last
@ -156,7 +158,7 @@ EOF
;; write-standalone-code: source output-port -> void
(define (write-standalone-code source-code op)
(package-anonymous source-code
#:should-follow? (lambda (p) #t)
#:should-follow? (lambda (src p) #t)
#:output-port op)
(fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n"))

8
tests/test-analyzer.rkt
View File

@ -1,8 +0,0 @@
#lang racket/base
(require "../make.rkt"
"../make-structs.rkt")
;; For some reason, this is breaking. Why?
(make (list (make-ModuleSource (build-path "make.rkt")))
debug-configuration)

2
tests/test-browser-evaluate.rkt
View File

@ -6,7 +6,7 @@
(printf "test-browser-evaluate.rkt\n")
(define should-follow? (lambda (p) #t))
(define should-follow? (lambda (src p) #t))
(define evaluate (make-evaluate
(lambda (program op)

2
tests/test-conform-browser.rkt
View File

@ -21,7 +21,7 @@
(fprintf op "var innerInvoke = ")
(package-anonymous (make-SexpSource program)
#:should-follow? (lambda (p) #t)
#:should-follow? (lambda (src p) #t)
#:output-port op)
(fprintf op "();\n")

2
tests/test-earley-browser.rkt
View File

@ -23,7 +23,7 @@
(fprintf op "var innerInvoke = ")
(package-anonymous (make-SexpSource program)
#:should-follow? (lambda (p) #t)
#:should-follow? (lambda (src path) #t)
#:output-port op)
(fprintf op "();\n")

2
tests/test-package.rkt
View File

@ -6,7 +6,7 @@
(printf "test-package.rkt\n")
(define (follow? p)
(define (follow? src p)
#t)
(define (test s-exp)

15
tests/test-parse-bytecode-on-collects.rkt
View File

@ -7,6 +7,7 @@
;; read-syntax: cannot load snip-class reader
(require "../parser/parse-bytecode.rkt"
"../call-with-timeout.rkt"
racket/list
racket/path)
@ -20,6 +21,8 @@
[else
p]))))
(define failures '())
(for ([path (in-directory collects-dir)])
@ -28,11 +31,17 @@
(flush-output)
(let ([start-time (current-inexact-milliseconds)])
(with-handlers ((exn:fail? (lambda (exn)
(set! failures (cons path failures))
(printf "FAILED! ~a" (exn-message exn)))))
(void (parse-bytecode path))
(set! failures (cons (list path exn)
failures))
(printf "FAILED: ~a\n" (exn-message exn)))))
(call-with-timeout (lambda ()
(void (parse-bytecode path)))
;; timeout
1000)
(let ([end-time (current-inexact-milliseconds)])
(printf "~a msecs\n" (inexact->exact (floor (- end-time start-time)))))))))
(unless (empty? failures)
(printf "Failed on: ~s" failures))