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

svn: r11879

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
+(define-syntax-rule (!defined id ...)
-  (syntax-rules ()
   ;; expected to be used only with identifiers
-    [(_ id ...) (begin (with-handlers
+  (begin (with-handlers ([exn:fail:contract:variable?
-                           ([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))]
+    [(_ id) (begin (!defined id) (!procedure* id))]
-    [(_ expr arity) (begin (!defined expr) (!procedure* expr arity))]))
+    [(_ id arity) (begin (!defined id) (!procedure* id arity))]))
 
 (provide !integer* !integer)
-(define-syntax !integer*
+(define-syntax-rule (!integer* expr)
-  (syntax-rules ()
-    [(_ expr)
   (unless (integer? ((submission-eval) `expr))
-       (error* "~a is expected to be bound to an integer" (->disp 'expr)))]))
+    (error* "~a is expected to be bound to an integer" (->disp 'expr))))
-(define-syntax !integer
+(define-syntax-rule (!integer id)
-  (syntax-rules ()
+  (begin (!defined id) (!integer* id)))
-    [(_ expr) (begin (!defined expr) (!integer* expr))]))
+
+(provide !eval)
+(define-syntax-rule (!eval expr) ((submission-eval) `expr))
 
 (provide !test)
 (define-syntax !test

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

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.

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
+@(define textoption
-  the submission files: when @scheme[:create-text?] is on.)}
+   @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
+@item{@indexed-scheme[:requires]---paths for additional libraries to
-  submissions, same as the @scheme[_teachpacks] argument for
+  require for evaluating the submission, same as the
-  @scheme[make-evaluator] (see @schememodname[handin-server/sandbox]).
+  @scheme[_requires] argument for @scheme[make-evaluator] (see
-  This defaults to null---no teachpacks.}
+  @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
+@scheme[(!eval _expr)] (or @scheme[((submission-eval) '_expr)]) to
-submitted code context, and you can use
+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")])))]}

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

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

collects/repos-time-stamp/stamp.ss

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

collects/scheme/sandbox.ss

@@ -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))
+                         (map (lambda (r) (list #'#%require r)) requires))
-                                requires))
                        (input->code input-program 'program 1))]
          [use-lang (lambda (lang) `(module program ,lang . ,body))])
-    (cond [(decode-language language)
+    (cond [(decode-language language) => use-lang]
-           => (lambda (l)
+          [(module-path? language) (use-lang language)]
-                (use-lang l))]
-          [(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)])))

collects/srfi/63/63.ss

@@ -146,15 +146,16 @@
              (pair? obj2)
              (s:equal? (car obj1) (car obj2))
              (s:equal? (cdr obj1) (cdr obj2)))
-        (and (vector? obj1)
+        (if (vector? obj1)
-             (vector? obj2)
+            (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))

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)

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

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

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

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

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) 
+               [ty (tc-error/delayed 
-                                     "Expression should produce ~a values, but produces one values of type "
+                    "Expression should produce ~a values, but produces one values of type ~a"
-                                     (length stxs) ty)]))))]))
+                    (length stxs) ty)
+                   (map (lambda _ (Un)) stxs)]))))]))
 
 
 ;; check that e-type is compatible with ty in context of stx