From c22611ca2b947fa695a046d157769ef484a3603b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Dec 2011 19:20:11 -0500 Subject: [PATCH 1/3] Fix documentation to avoid drdr warnings. --- collects/htdp/testing.scrbl | 10 ++++++---- collects/htdp/tests/test-docs-complete.rkt | 22 ++++++++++++---------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/htdp/testing.scrbl b/collects/htdp/testing.scrbl index dbae46f672..945cd6f6c5 100644 --- a/collects/htdp/testing.scrbl +++ b/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 diff --git a/collects/htdp/tests/test-docs-complete.rkt b/collects/htdp/tests/test-docs-complete.rkt index 360119f1b3..a17cf12120 100644 --- a/collects/htdp/tests/test-docs-complete.rkt +++ b/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)) From 64f9af0a843fbd287c2d8c77c65c5daa3f110c59 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Dec 2011 19:59:06 -0500 Subject: [PATCH 2/3] Minor fix to fuzzer. --- collects/tests/racket/stress/fuzz.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/racket/stress/fuzz.rkt b/collects/tests/racket/stress/fuzz.rkt index 8851117f44..1e34085774 100644 --- a/collects/tests/racket/stress/fuzz.rkt +++ b/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)) From e55ed2dc2564da4b223910d841d6fcdb02817709 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 8 Dec 2011 20:34:41 -0600 Subject: [PATCH 3/3] improve syntax error reporting for judgment-holds in reduction relations (and probably elsewhere) --- .../redex/private/reduction-semantics.rkt | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index bbfb18d3b6..ac3fa7a6e2 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/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)