diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index f4f15f90e2..b51f4adfd0 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -488,6 +488,14 @@ submission->bytes) submission maxwidth textualize? untabify? markup-prefix prefix-re)))) + (define (uem-handler e) + (let ([m (if (exn? e) (exn-message e) (format "~a" e))]) + (cond + [(procedure? uem) (uem m)] + [(not (string? uem)) + (error* "badly configured user-error-message")] + [(regexp-match? #rx"~[aesvAESV]" uem) (error* uem m)] + [else (error* "~a" uem)]))) (when create-text? (make-directory "grading") (write-text)) (when value-printer (current-value-printer value-printer)) (when coverage? (sandbox-coverage-enabled #t)) @@ -495,24 +503,10 @@ (cond [(not eval?) (let () body ...)] [language - (let ([eval - (with-handlers - ([void - (lambda (e) - (let ([m (if (exn? e) - (exn-message e) - (format "~a" e))]) - (cond - [(procedure? uem) (uem m)] - [(not (string? uem)) - (error* "badly configured ~a" - "user-error-message")] - [(regexp-match? #rx"~[aesvAESV]" uem) - (error* uem m)] - [else (error* "~a" uem)])))]) - (call-with-evaluator/submission - language (append requires teachpacks) - submission values))]) + (let ([eval (with-handlers ([void uem-handler]) + (call-with-evaluator/submission + language (append requires teachpacks) + submission values))]) (set-run-status "running tests") (parameterize ([submission-eval (wrap-evaluator eval)]) (let-syntax ([with-submission-bindings diff --git a/collects/handin-server/scribblings/utils.scrbl b/collects/handin-server/scribblings/utils.scrbl index ab1c357e75..bbdcecb5c7 100644 --- a/collects/handin-server/scribblings/utils.scrbl +++ b/collects/handin-server/scribblings/utils.scrbl @@ -21,6 +21,7 @@ @defproc[(make-evaluator/submission [language (or/c module-path? (list/c (one-of/c 'special) symbol?) + (list/c (one-of/c 'module) module-path?) (cons/c (one-of/c 'begin) list?))] [require-paths (listof path-string?)] [content bytes?]) @@ -28,11 +29,19 @@ Like @scheme[make-evaluator], but the definitions content is supplied as a submission byte string. The byte string is opened for - reading, with line-counting enabled.} + reading, with line-counting enabled. + + In addition to the language specification for + @scheme[make-evaluator], the @scheme[language] argument can be a + list that begins with @scheme['module]. In this case, + @scheme[make-module-language] is used to create an evaluator, and + the module code must be using the the specified language in its + language position.} @defproc[(call-with-evaluator [language (or/c module-path? (list/c (one-of/c 'special) symbol?) + (list/c (one-of/c 'module) module-path?) (cons/c (one-of/c 'begin) list?))] [require-paths (listof path-string?)] [input-program any/c] @@ -46,11 +55,13 @@ suitable for @scheme[language], it initializes @scheme[set-run-status] with @scheme["executing your code"], and it catches all exceptions to re-raise them in a form suitable as a - submission error.} + submission error. See @scheme[make-evaluator/submission] for + further details.} @defproc[(call-with-evaluator/submission [language (or/c module-path? (list/c (one-of/c 'special) symbol?) + (list/c (one-of/c 'module) module-path?) (cons/c (one-of/c 'begin) list?))] [require-paths (listof path-string?)] [submission bytes?] @@ -59,7 +70,8 @@ Like @scheme[call-with-evaluator], but the definitions content is supplied as a byte string. The byte string is opened for reading, - with line-counting enabled.} + with line-counting enabled. See @scheme[call-with-evaluator] and + @scheme[make-evaluator/submission] for further details.} @; JBC: this contract is probably wrong @; JBC: does this eval accept an optional namespace? diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 9ecf89f42b..9929d59073 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -48,14 +48,18 @@ ;; Execution ---------------------------------------- +(define (make-evaluator* lang reqs inp) + (if (and (list? lang) (= 2 (length lang)) (eq? 'module (car lang))) + (make-module-evaluator inp #:language (cadr lang) #:allow-read reqs) + (make-evaluator lang inp #:requires reqs))) + (define (open-input-text-editor/lines str) (let ([inp (open-input-text-editor str)]) (port-count-lines! inp) inp)) (define (make-evaluator/submission language requires str) (let-values ([(defs interacts) (unpack-submission str)]) - (make-evaluator language #:requires requires - (open-input-text-editor defs)))) + (make-evaluator* language requires (open-input-text-editor defs)))) (define (evaluate-all source port eval) (let loop () @@ -164,11 +168,12 @@ (define (call-with-evaluator lang requires program-port go) (parameterize ([error-value->string-handler (lambda (v s) ((current-value-printer) v))] - [list-abbreviation-enabled (not (or (eq? lang 'beginner) - (eq? lang 'beginner-abbr)))]) + [list-abbreviation-enabled + (not (or (equal? lang '(special beginner)) + (equal? lang '(special beginner-abbr))))]) (reraise-exn-as-submission-problem (lambda () - (let ([e (make-evaluator lang #:requires requires program-port)]) + (let ([e (make-evaluator* lang requires program-port)]) (set-run-status "executing your code") (go e))))))