diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 754f1f329d..1aaa6b6584 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -361,6 +361,7 @@ ([users* (get ':users #'#f)] [eval?* (get ':eval? #'#t)] [language* (get ':language #'#f)] + [requires* (get ':requires #''())] [teachpacks* (get ':teachpacks #''())] [create-text?* (get ':create-text? #'#t)] [untabify?* (get ':untabify? #'#t)] @@ -406,6 +407,7 @@ us))] [eval? eval?*] [language language*] + [requires requires*] [teachpacks teachpacks*] [create-text? create-text?*] [untabify? untabify?*] @@ -509,7 +511,8 @@ (error* uem m)] [else (error* "~a" uem)])))]) (call-with-evaluator/submission - language teachpacks submission values))]) + language (append requires teachpacks) + submission values))]) (set-run-status "running tests") (parameterize ([submission-eval (wrap-evaluator eval)]) (let-syntax ([with-submission-bindings @@ -537,6 +540,8 @@ "`untabify?' without `maxwidth'"] [(and (not eval?) coverage?) "`coverage?' without `eval?'"] + [(and (pair? requires) (pair? teachpacks)) + "`requires' and `teachpacks'"] ;; [(and textualize? coverage?) ;; "`textualize?' and `coverage?'"] [else #f])]) @@ -648,15 +653,13 @@ (and (procedure? proc) (procedure-arity-includes? proc arity))) (provide !defined) -(define-syntax !defined - (syntax-rules () - ;; expected to be used only with identifiers - [(_ id ...) (begin (with-handlers - ([exn:fail:contract:variable? - (lambda (_) - (error* "missing binding: ~a" (->disp 'id)))]) - ((submission-eval) `id)) - ...)])) +(define-syntax-rule (!defined id ...) + ;; expected to be used only with identifiers + (begin (with-handlers ([exn:fail:contract:variable? + (lambda (_) + (error* "missing binding: ~a" (->disp 'id)))]) + ((submission-eval) `id)) + ...)) (provide !procedure* !procedure) (define-syntax !procedure* @@ -674,18 +677,18 @@ (->disp 'expr) ar)))])) (define-syntax !procedure (syntax-rules () - [(_ expr) (begin (!defined expr) (!procedure* expr))] - [(_ expr arity) (begin (!defined expr) (!procedure* expr arity))])) + [(_ id) (begin (!defined id) (!procedure* id))] + [(_ id arity) (begin (!defined id) (!procedure* id arity))])) (provide !integer* !integer) -(define-syntax !integer* - (syntax-rules () - [(_ expr) - (unless (integer? ((submission-eval) `expr)) - (error* "~a is expected to be bound to an integer" (->disp 'expr)))])) -(define-syntax !integer - (syntax-rules () - [(_ expr) (begin (!defined expr) (!integer* expr))])) +(define-syntax-rule (!integer* expr) + (unless (integer? ((submission-eval) `expr)) + (error* "~a is expected to be bound to an integer" (->disp 'expr)))) +(define-syntax-rule (!integer id) + (begin (!defined id) (!integer* id))) + +(provide !eval) +(define-syntax-rule (!eval expr) ((submission-eval) `expr)) (provide !test) (define-syntax !test diff --git a/collects/handin-server/overridden-collects/fake-teachpack/htdp/guess.ss b/collects/handin-server/overridden-collects/fake-teachpack/htdp/guess.ss new file mode 100644 index 0000000000..757c4a8144 --- /dev/null +++ b/collects/handin-server/overridden-collects/fake-teachpack/htdp/guess.ss @@ -0,0 +1,31 @@ +#lang scheme/gui + +(require htdp/error lang/prim) + +(provide guess-with-gui guess-with-gui-3 guess-with-gui-list) + +(define-higher-order-primitive guess-with-gui guess-with-gui/proc + (check-guess)) +(define-higher-order-primitive guess-with-gui-3 guess-with-gui-3/proc + (check-guess)) +(define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc + (_ check-guess-list)) + +(define (convert guesses:vec) + (void)) + +(define (guess-with-gui/proc cg) + (check-proc 'guess-with-gui cg 2 'first "two arguments") + (void)) + +(define (guess-with-gui-3/proc cg) + (check-proc 'guess-with-gui-3 cg (+ 3 1) 'first "four arguments") + (void)) + +(define (guess-with-gui-list/proc n cg) + (check-arg 'guess-with-gui-list + (and (number? n) (integer? n) (>= n 1)) "positive integer" '1st n) + (check-proc 'guess-with-gui-list cg 2 'first "two arguments") + (unless (<= (expt 10 n) 2147483647) + (error 'guess-with-gui-list "the given number of digits (~a) is too large" n)) + (void)) diff --git a/collects/handin-server/overridden-collects/readme.txt b/collects/handin-server/overridden-collects/readme.txt index a73c86303f..5f502b1aab 100644 --- a/collects/handin-server/overridden-collects/readme.txt +++ b/collects/handin-server/overridden-collects/readme.txt @@ -4,3 +4,11 @@ that appear here will be used instead of ones in the PLT tree or the user-local collections. Use it to override collections that are safe for testing, for example -- avoid using actual gui. See also the documentation for `sandbox-override-collection-paths' in "doc.txt". + +This is currently used with the `teachpack' collection. Note that +mzscheme resolved collection directories based on toplevel names only, +which means that if we actually use `teachpack' for the directory +name, then files that are not here will not be searched in the usual +plt tree. Because of this the collection is called `fake-teachpack', +and checkers should specify requires in this collection if submissions +need a fake teachpack. diff --git a/collects/handin-server/scribblings/checker.scrbl b/collects/handin-server/scribblings/checker.scrbl index 8541676384..b455d22c29 100644 --- a/collects/handin-server/scribblings/checker.scrbl +++ b/collects/handin-server/scribblings/checker.scrbl @@ -1,8 +1,9 @@ #lang scribble/doc @(require "common.ss") -@define[textoption]{(Effective only when saving a textual version of - the submission files: when @scheme[:create-text?] is on.)} +@(define textoption + @t{(Effective only when saving a textual version of + the submission files: when @scheme[:create-text?] is on.)}) @title{checker} @@ -66,10 +67,14 @@ Keywords for configuring @scheme[check:]: There is no default for this, so it must be set or an error is raised.} -@item{@indexed-scheme[:teachpacks]---teachpacks for evaluating - submissions, same as the @scheme[_teachpacks] argument for - @scheme[make-evaluator] (see @schememodname[handin-server/sandbox]). - This defaults to null---no teachpacks.} +@item{@indexed-scheme[:requires]---paths for additional libraries to + require for evaluating the submission, same as the + @scheme[_requires] argument for @scheme[make-evaluator] (see + @schememodname[handin-server/sandbox]). This defaults to null---no + teachpacks.} + +@item{@indexed-scheme[:teachpacks]---an alternative name for + @scheme[:requires], kept for legacy checkers.} @item{@indexed-scheme[:create-text?]---if true, then a textual version of the submission is saved as @filepath{text.scm} in a @@ -208,8 +213,8 @@ Within the body of @scheme[check:], @scheme[users] and @scheme[submission] will be bound to the checker arguments---a (sorted) list of usernames and the submission as a byte string. In addition to the functionality below, you can use -@scheme[((submission-eval) expr)] to evaluate expressions in the -submitted code context, and you can use +@scheme[(!eval _expr)] (or @scheme[((submission-eval) '_expr)]) to +evaluate expressions in the submitted code context, and you can use @scheme[(with-submission-bindings (id ...) body ...)] to evaluate the body when @scheme[id]'s are bound to their values from the submission code.} @@ -349,6 +354,11 @@ code.} @scheme[equal?] forms are @italic{not} evaluated in the submission context.} +@defform[(!eval expr)]{ + + Evaluate an arbitrary expession in the submission context. This is + a simple shorthand for @scheme[((submission-eval) `expr)].} + @defproc*[([(!all-covered) void?] [(!all-covered [proc (string? . -> . any)]) void?])]{ @@ -372,7 +382,8 @@ code.} (lambda (where) (case (message (string-append "Incomplete coverage at "where", do you want" - " to save this submission with 10% penalty?")) + " to save this submission with 10% penalty?") + '(yes-no)) [(yes) (add-header-line! "No full coverage <*90%>") (message "Handin saved with penalty.")] [else (error "aborting submission")])))]} diff --git a/collects/handin-server/scribblings/utils.scrbl b/collects/handin-server/scribblings/utils.scrbl index 79cb7f7ca5..ab1c357e75 100644 --- a/collects/handin-server/scribblings/utils.scrbl +++ b/collects/handin-server/scribblings/utils.scrbl @@ -22,7 +22,7 @@ [language (or/c module-path? (list/c (one-of/c 'special) symbol?) (cons/c (one-of/c 'begin) list?))] - [teachpack-paths (listof path-string?)] + [require-paths (listof path-string?)] [content bytes?]) (any/c . -> . any)]{ @@ -34,7 +34,7 @@ [language (or/c module-path? (list/c (one-of/c 'special) symbol?) (cons/c (one-of/c 'begin) list?))] - [teachpack-paths (listof path-string?)] + [require-paths (listof path-string?)] [input-program any/c] [proc (any/c . -> . any)]) any]{ @@ -52,7 +52,7 @@ (or/c module-path? (list/c (one-of/c 'special) symbol?) (cons/c (one-of/c 'begin) list?))] - [teachpack-paths (listof path-string?)] + [require-paths (listof path-string?)] [submission bytes?] [proc (any/c . -> . any)]) any]{ diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 27faef70e2..be4a3548f2 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -52,9 +52,10 @@ (let ([inp (open-input-text-editor str)]) (port-count-lines! inp) inp)) -(define (make-evaluator/submission language teachpacks str) +(define (make-evaluator/submission language requires str) (let-values ([(defs interacts) (unpack-submission str)]) - (make-evaluator language teachpacks (open-input-text-editor defs)))) + (make-evaluator language #:requires requires + (open-input-text-editor defs)))) (define (evaluate-all source port eval) (let loop () @@ -160,17 +161,17 @@ (regexp-replace #rx"\n$" (get-output-string p) "")))) (define current-value-printer (make-parameter default-value-printer)) -(define (call-with-evaluator lang teachpacks program-port go) +(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)))]) (reraise-exn-as-submission-problem (lambda () - (let ([e (make-evaluator lang #:requires teachpacks program-port)]) + (let ([e (make-evaluator lang #:requires requires program-port)]) (set-run-status "executing your code") (go e)))))) -(define (call-with-evaluator/submission lang teachpacks str go) +(define (call-with-evaluator/submission lang requires str go) (let-values ([(defs interacts) (unpack-submission str)]) - (call-with-evaluator lang teachpacks (open-input-text-editor defs) go))) + (call-with-evaluator lang requires (open-input-text-editor defs) go))) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 5c134e1b23..1032b7a505 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "24sep2008") +#lang scheme/base (provide stamp) (define stamp "25sep2008") diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 41d0bbd826..c5a477940b 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -332,16 +332,12 @@ ;; transitive requires. (define (build-program language requires input-program) (let* ([body (append (if (and (pair? requires) (eq? 'begin (car requires))) - (cdr requires) - (map (lambda (r) (list #'#%require r)) - requires)) + (cdr requires) + (map (lambda (r) (list #'#%require r)) requires)) (input->code input-program 'program 1))] [use-lang (lambda (lang) `(module program ,lang . ,body))]) - (cond [(decode-language language) - => (lambda (l) - (use-lang l))] - [(module-path? language) - (use-lang language)] + (cond [(decode-language language) => use-lang] + [(module-path? language) (use-lang language)] [(and (list? language) (eq? 'begin (car language))) (append language body)] [else (error 'make-evaluator "bad language spec: ~e" language)]))) diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index 4df3f83a81..373a126416 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -146,29 +146,30 @@ (pair? obj2) (s:equal? (car obj1) (car obj2)) (s:equal? (cdr obj1) (cdr obj2))) - (and (vector? obj1) - (vector? obj2) - (equal? (vector-length obj1) (vector-length obj2)) - (let lp ((idx (sub1 (vector-length obj1)))) - (or (negative? idx) - (and (s:equal? (vector-ref obj1 idx) - (vector-ref obj2 idx)) - (lp (sub1 idx)))))) - (and (array? obj1) - (array? obj2) - (equal? (array-dimensions obj1) (array-dimensions obj2)) - (s:equal? (array->vector obj1) (array->vector obj2))) - (and (struct? obj1) - (struct? obj2) - (let-values (((obj1-type obj1-skipped?) - (struct-info obj1)) - ((obj2-type obj2-skipped?) - (struct-info obj2))) - (and (eq? obj1-type obj2-type) - (not obj1-skipped?) - (not obj2-skipped?) - (s:equal? (struct->vector obj1) - (struct->vector obj2))))))) + (if (vector? obj1) + (and (vector? obj2) + (equal? (vector-length obj1) (vector-length obj2)) + (let lp ((idx (sub1 (vector-length obj1)))) + (or (negative? idx) + (and (s:equal? (vector-ref obj1 idx) + (vector-ref obj2 idx)) + (lp (sub1 idx)))))) + ;; Not a vector + (or (and (array? obj1) + (array? obj2) + (equal? (array-dimensions obj1) (array-dimensions obj2)) + (s:equal? (array->vector obj1) (array->vector obj2))) + (and (struct? obj1) + (struct? obj2) + (let-values (((obj1-type obj1-skipped?) + (struct-info obj1)) + ((obj2-type obj2-skipped?) + (struct-info obj2))) + (and (eq? obj1-type obj2-type) + (not obj1-skipped?) + (not obj2-skipped?) + (s:equal? (struct->vector obj1) + (struct->vector obj2))))))))) (define (array-rank obj) (if (array? obj) (length (array-dimensions obj)) 0)) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss index f44741913f..ed186dce16 100644 --- a/collects/tests/mzscheme/pconvert.ss +++ b/collects/tests/mzscheme/pconvert.ss @@ -112,6 +112,7 @@ (list (make-same-test "abc" "abc") (make-same-test 'a ''a) + (make-same-test '#:abc ''#:abc) (make-same-test 8 8) (make-same-test 1/2 1/2) diff --git a/collects/tests/typed-scheme/succeed/with-handlers.ss b/collects/tests/typed-scheme/succeed/with-handlers.ss new file mode 100644 index 0000000000..cfdb88aefb --- /dev/null +++ b/collects/tests/typed-scheme/succeed/with-handlers.ss @@ -0,0 +1,10 @@ + +#lang typed-scheme + +(define: (f [i : Integer]) : (Pair String Char) + (cons "foo" #\space)) + +(define: (is-happiness-a-warm-gun?) : Boolean + (with-handlers ([integer? (lambda: ([x : Any]) #t)]) + (f 42) + #t)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index fee35aa2fc..5506b1ff4f 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -651,6 +651,9 @@ Boolean String Number) (N N N . -> . N)] + [tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))}) + (Un (-val #f) (-pair Sym (-pair Sym (-val null))))] + #;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20))] diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index aa4093b310..e862af4ce3 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -223,7 +223,7 @@ [string->path (-> -String -Path)] [file-exists? (-> -Pathlike B)] -[assq (-poly (a) (-> Univ (-lst (-pair Univ a)) a))] +[assq (-poly (a b) (a (-lst (-pair a b)) . -> . (Un (-pair a b) (-val #f))))] [build-path ((list -Pathlike*) -Pathlike* . ->* . -Path)] [string->number (-> -String (-opt N))] diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 9068659cfd..dd72df9fe2 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -301,7 +301,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax->list #'(pred? ...)))] [(action* ...) (map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))] - [body* (syntax-property #'(begin . body) 'typechecker:exn-body #t)]) + [body* (syntax-property #'(let-values () . body) 'typechecker:exn-body #t)]) (syntax-property #'(with-handlers ([pred?* action*] ...) body*) 'typechecker:with-handlers #t))])) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index bbb8303412..9ff2f8d005 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -103,16 +103,19 @@ (match ty [(Values: tys) (if (not (= (length stxs) (length tys))) - (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) + (begin + (tc-error/delayed "Expression should produce ~a values, but produces ~a values of types ~a" (length stxs) (length tys) (stringify tys)) + (map (lambda _ (Un)) stxs)) (map (lambda (stx ty a) (cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)] [else #;(log/noann stx ty) ty])) stxs tys anns))] - [ty (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) - "Expression should produce ~a values, but produces one values of type " - (length stxs) ty)]))))])) + [ty (tc-error/delayed + "Expression should produce ~a values, but produces one values of type ~a" + (length stxs) ty) + (map (lambda _ (Un)) stxs)]))))])) ;; check that e-type is compatible with ty in context of stx