Permalink
Browse files

fixing some tests

  • Loading branch information...
Danny Yoo
Danny Yoo committed Jun 1, 2011
1 parent 5445ae1 commit 35284eafbe7ccd262d41df6f584c9e4385dbd211
View
@@ -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
View
@@ -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))])))))
+
View
@@ -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])
View
@@ -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"))
View
@@ -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)
@@ -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)
@@ -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")
@@ -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")
View
@@ -6,7 +6,7 @@
(printf "test-package.rkt\n")
-(define (follow? p)
+(define (follow? src p)
#t)
(define (test s-exp)
@@ -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))

0 comments on commit 35284ea

Please sign in to comment.