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

I'd merged in some slightly broken stuff, so let's merge again.

Browse Source 
svn: r11879
This commit is contained in:
Stevie Strickland 2008-09-25 21:53:29 +00:00
commit 3b6d97e31d
15 changed files with 144 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/handin-server/checker.ss
View File

@ -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 ()
(define-syntax-rule (!defined id ...)
;; expected to be used only with identifiers
[(_ id ...) (begin (with-handlers
([exn:fail:contract:variable?
(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)
(define-syntax-rule (!integer* 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))]))
(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

31
collects/handin-server/overridden-collects/fake-teachpack/htdp/guess.ss Normal file
View File

@ -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))

8
collects/handin-server/overridden-collects/readme.txt
View File

@ -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.

29
collects/handin-server/scribblings/checker.scrbl
View File

@ -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")])))]}

6
collects/handin-server/scribblings/utils.scrbl
View File

@ -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]{

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

@ -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)))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "24sep2008")
#lang scheme/base (provide stamp) (define stamp "25sep2008")

10
collects/scheme/sandbox.ss
View File

@ -333,15 +333,11 @@
(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))
(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)])))

9
collects/srfi/63/63.ss
View File

@ -146,15 +146,16 @@
(pair? obj2)
(s:equal? (car obj1) (car obj2))
(s:equal? (cdr obj1) (cdr obj2)))
(and (vector? obj1)
(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))))))
(and (array? obj1)
;; Not a vector
(or (and (array? obj1)
(array? obj2)
(equal? (array-dimensions obj1) (array-dimensions obj2))
(s:equal? (array->vector obj1) (array->vector obj2)))
@ -168,7 +169,7 @@
(not obj1-skipped?)
(not obj2-skipped?)
(s:equal? (struct->vector obj1)
(struct->vector obj2)))))))
(struct->vector obj2)))))))))
(define (array-rank obj)
(if (array? obj) (length (array-dimensions obj)) 0))

1
collects/tests/mzscheme/pconvert.ss
View File

@ -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)

10
collects/tests/typed-scheme/succeed/with-handlers.ss Normal file
View File

@ -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))

3
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -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))]

2
collects/typed-scheme/private/base-env.ss
View File

@ -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))]

2
collects/typed-scheme/private/prims.ss
View File

@ -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))]))

11
collects/typed-scheme/private/type-annotation.ss
View File

@ -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