Merge branch 'master' of racket-lang.org:plt

collects/htdp/testing.scrbl

@@ -1,26 +1,28 @@
 #lang scribble/doc
 
 @(require scribble/manual
-          (for-label test-engine/racket-tests))
+          (for-label test-engine/racket-tests (only-in htdp/testing generate-report)))
 
 @title{Testing} 
 
 @; -----------------------------------------------------------------------------
 @defmodule[htdp/testing #:use-sources (test-engine/racket-tests)]
 
-The library re-exports the following identifiers from test-engine/racket-tests:
+The library re-exports the following identifiers from @racketmodname[test-engine/racket-tests]
 
+@deftogether[(
 @defproc[(build-test-engine) void?]
 @defproc[(builder) void?]
 @defproc[(display-results) void?]
 @defproc[(error-handler) void?]
 @defproc[(exn:fail:wish) void?]
-@defproc[(generate-report) void?]
 @defproc[(get-test-engine) void?]
 @defproc[(reset-tests) void?]
 @defproc[(run-tests) void?]
 @defproc[(scheme-test-data) void?]
-@defproc[(signature-test-info%) void?]
+@defproc[(signature-test-info%) void?])]
+
+@defproc[(generate-report) void?]{The same as @racket[test].}
 
 
 @(require scribble/eval

collects/htdp/tests/test-docs-complete.rkt

@@ -4,6 +4,15 @@
 (define (private-module s) #true)
 (define (legacy-module s) #true)
 
+(define hidden?
+  (lambda (h)
+    ;; These identifiers are useful in some tests. They are like
+    ;; 'friend' in C++ classes. If this weren't a legacy module, I'd
+    ;; revise the architecture. -- Matthias
+    (define *hidden
+      '(draw begin-draw-sequence end-draw-sequence get-@VP get-mouse-event start-and-export))
+    (memq h *hidden)))
+
 (check-docs (quote htdp/world))
 (check-docs (quote htdp/testing))
 (check-docs (quote htdp/show-queen))
@@ -18,22 +27,15 @@
 (check-docs (quote htdp/master-play))
 (check-docs (quote htdp/lkup-gui))
 (check-docs (quote htdp/image))
-(check-docs (quote htdp/hangman))
+(check-docs (quote htdp/hangman) #:skip hidden?)
 (check-docs (quote htdp/hangman-play))
 (check-docs (quote htdp/gui))
 (check-docs (quote htdp/guess))
 (check-docs (quote htdp/guess-gui))
-(check-docs (quote htdp/graphing))
+(check-docs (quote htdp/graphing) #:skip hidden?)
 (check-docs (quote htdp/error))
 (check-docs (quote htdp/elevator))
-(check-docs (quote htdp/draw)
-  #:skip (lambda (h)
-	   ;; These identifiers are useful in some tests. They are like
-	   ;; 'friend' in C++ classes. If this weren't a legacy module, I'd
-	   ;; revise the architecture. -- Matthias
-	   (define *hidden
-	     '(draw begin-draw-sequence end-draw-sequence get-@VP get-mouse-event start-and-export))
-	   (memq h *hidden)))
+(check-docs (quote htdp/draw) #:skip hidden?)
 (check-docs (quote htdp/draw-sig) #:skip private-module)
 (check-docs (quote htdp/docs))
 (check-docs (quote htdp/dir))

collects/redex/private/reduction-semantics.rkt

@@ -481,7 +481,7 @@
   (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
        (extract-pattern-binds pat)))
 
-(define-for-syntax (check-judgment-arity judgment)
+(define-for-syntax (check-judgment-arity stx judgment)
   (syntax-case judgment ()
     [(form-name pat ...)
      (judgment-form-id? #'form-name)
@@ -492,7 +492,9 @@
           #f 
           (format "mode specifies a ~a-ary relation but use supplied ~a term~a" 
                   expected actual (if (= actual 1) "" "s"))
-          judgment)))]))
+          judgment)))]
+    [(form-name pat ...)
+     (raise-syntax-error #f "expected a judgment form name" stx #'form-name)]))
 
 (define-syntax-set (do-reduction-relation)
   (define (do-reduction-relation/proc stx)
@@ -689,8 +691,11 @@
                                                  [(_ outs) (split-by-mode (syntax->list #'pieces) mode)])
                                      (cons (to-lw/proc #'(form-name . pieces))
                                            (for/fold ([binds scs/withs]) ([out outs])
-                                                     (append (name-pattern-lws/rr out) binds))))
-                                   fvars)])]))])
+                                             (append (name-pattern-lws/rr out) binds))))
+                                   fvars)]
+                            [_
+                             ;; just skip over junk here, and expect a syntax error to be raised elsewhere
+                             (loop (cdr stuffs) label computed-label scs/withs fvars)])]))])
          (with-syntax ([(scs/withs ...) scs/withs]
                        [(fvars ...) fvars]
                        [((bind-id . bind-pat) ...) 
@@ -1055,7 +1060,7 @@
                     (raise-syntax-error orig-name "malformed computed-name clause" stx (car extras))]
                    [(judgment-holds judgment)
                     (begin
-                      (check-judgment-arity #'judgment)
+                      (check-judgment-arity stx #'judgment)
                       (cons #'judgment (loop (cdr extras))))]
                    [_
                     (raise-syntax-error orig-name "unknown extra" stx (car extras))])]))])
@@ -1873,7 +1878,7 @@
             [lang (judgment-form-lang (syntax-local-value #'form-name))]
             [nts (definition-nts lang stx syn-err-name)]
             [judgment (syntax-case stx () [(_ judgment _) #'judgment])])
-       (check-judgment-arity judgment)
+       (check-judgment-arity stx judgment)
        #`(sort #,(bind-withs syn-err-name '() lang nts (list judgment)
                              'flatten #`(list (term #,#'tmpl)) '() '())
                string<=?
@@ -1967,7 +1972,7 @@
                              description (car rest-terms) pos))
             (loop (cdr rest-modes) rest-terms rest-ctcs (+ 1 pos)))))))
 
-(define-for-syntax (mode-check mode clauses nts syn-err-name)
+(define-for-syntax (mode-check mode clauses nts syn-err-name orig-stx)
   (define ((check-template bound-anywhere) temp bound)
     (let check ([t temp])
       (syntax-case t (unquote)
@@ -2009,7 +2014,7 @@
     (syntax-case clause ()
       [(conc . prems)
        (let-values ([(conc-in conc-out) (split-body #'conc)])
-         (check-judgment-arity #'conc)
+         (check-judgment-arity orig-stx #'conc)
          (define acc-out
            (for/fold ([acc (foldl pat-pos acc-init conc-in)])
                      ([prem (drop-ellipses #'prems)])
@@ -2022,7 +2027,7 @@
                        [(form-name . _)
                         (if (judgment-form-id? #'form-name)
                             (let-values ([(prem-in prem-out) (split-body prem)])
-                              (check-judgment-arity prem)
+                              (check-judgment-arity orig-stx prem)
                               (for ([pos prem-in]) (tmpl-pos pos acc))
                               (foldl pat-pos acc prem-out))
                             (raise-syntax-error syn-err-name "expected judgment form name" #'form-name))]
@@ -2125,7 +2130,7 @@
   (syntax-case stx ()
     [(_ judgment-form-name lang mode clauses ctcs full-def syn-err-name)
      (let ([nts (definition-nts #'lang #'full-def (syntax-e #'syn-err-name))])
-       (mode-check (syntax->datum #'mode) (syntax->list #'clauses) nts (syntax-e #'syn-err-name))
+       (mode-check (syntax->datum #'mode) (syntax->list #'clauses) nts (syntax-e #'syn-err-name) stx)
        (do-compile-judgment-form-proc
         (syntax-e #'judgment-form-name) 
         (syntax->datum #'mode) 

collects/tests/racket/stress/fuzz.rkt

@@ -34,7 +34,7 @@
    ["-s" seed "random seed" (set! seed0 (string->number seed))]
    ["--oo" "forever" (set! forever? #t)]
    #:once-any
-   ["-f" file "filename to run"     (set! file file)]
+   ["-f" file* "filename to run"     (set! file file*)]
    ["-d" dir* "dir to run"          (set! dir dir*)]
    ["-c" "run over all collections" (set! dir (find-collects-dir))]
    #:args () (void))