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

svn: r11682

Browse Source
This commit is contained in:
Eli Barzilay 2008-09-12 15:23:05 +00:00
parent 5675f4574c
commit 78632e178d
1 changed files with 22 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/handin-server/utils.ss
View File

@ -1,11 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/list (require scheme/class mred lang/posn scheme/pretty
scheme/class
mred
lang/posn
(prefix-in pc: mzlib/pconvert) (prefix-in pc: mzlib/pconvert)
scheme/pretty
(only-in "main.ss" timeout-control) (only-in "main.ss" timeout-control)
"private/run-status.ss" "private/run-status.ss"
"private/config.ss" "private/config.ss"
@ -13,29 +9,29 @@
"sandbox.ss") "sandbox.ss")
(provide (all-from-out "sandbox.ss") (provide (all-from-out "sandbox.ss")
get-conf get-conf
log-line log-line
unpack-submission unpack-submission
make-evaluator/submission make-evaluator/submission
evaluate-all evaluate-all
evaluate-submission evaluate-submission
call-with-evaluator call-with-evaluator
call-with-evaluator/submission call-with-evaluator/submission
reraise-exn-as-submission-problem reraise-exn-as-submission-problem
set-run-status set-run-status
message message
current-value-printer current-value-printer
check-proc check-proc
check-defined check-defined
look-for-tests look-for-tests
user-construct user-construct
test-history-enabled test-history-enabled
timeout-control) timeout-control)
(define (unpack-submission str) (define (unpack-submission str)
@ -76,8 +72,8 @@
(define (reraise-exn-as-submission-problem thunk) (define (reraise-exn-as-submission-problem thunk)
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(error (if (exn? exn) (error (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "exception: ~e" exn))))]) (format "exception: ~e" exn))))])
(thunk))) (thunk)))
;; ---------------------------------------- ;; ----------------------------------------
@ -98,10 +94,10 @@
(define (format-history one-test) (define (format-history one-test)
(if (test-history-enabled) (if (test-history-enabled)
(format "(begin~a)" (format "(begin~a)"
(apply string-append (map (lambda (s) (format " ~a" s)) (apply string-append (map (lambda (s) (format " ~a" s))
(reverse (test-history))))) (reverse (test-history)))))
one-test)) one-test))
(define (check-proc e result equal? f . args) (define (check-proc e result equal? f . args)
(let ([test (format "(~a~a)" f (let ([test (format "(~a~a)" f
@ -125,9 +121,7 @@
(unless ok? (unless ok?
(error (error
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e" (format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
(format-history test) (format-history test) result val)))
result
val)))
val))) val)))
(define (user-construct e func . args) (define (user-construct e func . args)
@ -138,18 +132,14 @@
(let loop ([found 0]) (let loop ([found 0])
(let ([e (read p)]) (let ([e (read p)])
(if (eof-object? e) (if (eof-object? e)
(when (found . < . count) (when (found . < . count)
(error (format "found ~a test~a for ~a, need at least ~a test~a" (error (format "found ~a test~a for ~a, need at least ~a test~a"
found found
(if (= found 1) "" "s") (if (= found 1) "" "s")
name name
count count
(if (= count 1) "" "s")))) (if (= count 1) "" "s"))))
(loop (+ found (loop (+ found (if (and (pair? e) (eq? (car e) name)) 1 0))))))))
(if (and (pair? e)
(eq? (car e) name))
1
0))))))))
(define list-abbreviation-enabled (make-parameter #f)) (define list-abbreviation-enabled (make-parameter #f))