From 18e8f005720394eb103e5d2e3309db9671c6c649 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 22 Feb 2010 19:45:17 +0000 Subject: [PATCH 1/4] added a preference to remember the log viewer's setting svn: r18266 --- collects/drscheme/private/main.ss | 2 ++ collects/drscheme/private/unit.ss | 2 ++ 2 files changed, 4 insertions(+) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 8b63a80ca6..4db6510fa4 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -89,6 +89,8 @@ (finder:default-filters))) (application:current-app-name (string-constant drscheme)) +(preferences:set-default 'drscheme:logger-gui-tab-panel-level 0 (λ (x) (and (exact-integer? x) (<= 0 x 5)))) + (preferences:set-default 'drscheme:saved-bug-reports '() (λ (ll) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 3a65ae2abf..37e9bdaf32 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1523,7 +1523,9 @@ module browser threading seems wrong. [parent logger-panel] [callback (λ (tp evt) + (preferences:set 'drscheme:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) (update-logger-window #f))])) + (send logger-gui-tab-panel set-selection (preferences:get 'drscheme:logger-gui-tab-panel-level)) (new-logger-text) (set! logger-gui-canvas (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) From 8a11336b51936c0b465ed399f64579e2e73d75df Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 22 Feb 2010 20:06:34 +0000 Subject: [PATCH 2/4] revert this change, since it breaks insert large letters svn: r18267 --- collects/typed-scheme/private/type-contract.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 6b6f3c5915..bad2a41d95 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -136,7 +136,9 @@ (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) #`(flat-rec-contract n* #,(t->c b)))))] [(Value: #f) #'false/c] - [(Instance: (Class: _ _ (list (list name fcn) ...))) + [(Instance: (Class: _ _ (list (list name fcn) ...))) + #'(is-a?/c object%) + #; (with-syntax ([(fcn-cnts ...) (map t->c fcn)] [(names ...) name]) #'(object-contract (names fcn-cnts) ...))] From d4eee108f43e65ad988cb3661245ee13ebf02b1b Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 22 Feb 2010 20:48:31 +0000 Subject: [PATCH 3/4] schemeunit: added ryanc to plt:responsible test-suite list trampoline, make-test-suite svn: r18268 --- collects/schemeunit/private/test-suite.ss | 15 ++++++--- .../scribblings/compound-testing.scrbl | 33 +++++++++++++++---- collects/schemeunit/scribblings/misc.scrbl | 2 +- collects/schemeunit/scribblings/ui.scrbl | 4 +-- 4 files changed, 40 insertions(+), 14 deletions(-) diff --git a/collects/schemeunit/private/test-suite.ss b/collects/schemeunit/private/test-suite.ss index 155049cc2c..aa586d749c 100644 --- a/collects/schemeunit/private/test-suite.ss +++ b/collects/schemeunit/private/test-suite.ss @@ -83,15 +83,22 @@ (let ([the-name name] [the-tests (lambda (fdown fup fhere seed) + (define (run/inner x) + (cond [(schemeunit-test-suite? x) + (current-seed + (apply-test-suite x fdown fup fhere (current-seed)))] + [(list? x) + (for-each run/inner x)] + [else + (void)])) (parameterize ([current-seed seed] [current-test-case-around (test-suite-test-case-around fhere)] [current-check-around (test-suite-check-around fhere)]) (let ([t test]) - (if (schemeunit-test-suite? t) - (current-seed (apply-test-suite t fdown fup fhere (current-seed))) - t)) - ... (current-seed)))]) + (run/inner t)) + ... + (current-seed)))]) (cond [(not (string? the-name)) (raise-type-error 'test-suite "test-suite name as string" the-name)] diff --git a/collects/schemeunit/scribblings/compound-testing.scrbl b/collects/schemeunit/scribblings/compound-testing.scrbl index 870c3fe802..74011e4f68 100644 --- a/collects/schemeunit/scribblings/compound-testing.scrbl +++ b/collects/schemeunit/scribblings/compound-testing.scrbl @@ -61,15 +61,19 @@ Unlike a check or test case, a test suite is not immediately run. Instead use one of the functions described in @secref["ui"] or @secref["running"]. -@defform[(test-suite name [#:before before-thunk] [#:after after-thunk] test ...)]{ +@defform/subs[(test-suite name-expr maybe-before maybe-after test ...) + ([maybe-before (code:line) + (code:line #:before before-thunk)] + [maybe-after (code:line) + (code:line #:after after-thunk)]) + #:contracts ([name-expr string?])]{ Constructs a test suite with the given name and tests. The -tests may be test cases, constructed using -@scheme[test-begin] or @scheme[test-case], or other test -suites. +tests may be test cases, constructed using @scheme[test-begin] or +@scheme[test-case], or other test suites. The @scheme[before-thunk] and @scheme[after-thunk] are -optional thunks (functions are no argument). They are run +optional thunks (functions with no argument). They are run before and after the tests are run, respectively. Unlike a check or test case, a test suite is not immediately @@ -87,9 +91,23 @@ finished. #:after (lambda () (display "After")) (test-case "An example test" - (check-eq? 1 1))) + (check-eq? 1 1)) + (test-suite "A nested test suite" + (test-case "Another test" + (check-< 1 2)))) ] +@defproc[(make-test-suite [name string?] + [tests (listof (or/c test-case? test-suite?))] + [#:before before-thunk (-> any) void] + [#:after after-thunk (-> any) void]) + test-suite?]{ + +Constructs a test suite with the given @scheme[name] containing the +given @scheme[tests]. Unlike the @scheme[test-suite] form, the tests +are represented as a list of test values. +} + @defproc[(test-suite? (obj any)) boolean?]{ True if @scheme[obj] is a test suite, and false otherwise} @@ -118,6 +136,7 @@ the name @scheme["example-suite"]: for is just like @scheme[define-test-suite], and in addition it @scheme[provide]s the test suite.} +@;{ Finally, there is the @scheme[test-suite*] macro, which defines a test suite and test cases using a shorthand syntax: @@ -129,7 +148,7 @@ body expressions. As far I know no-one uses this macro, so it might disappear in future versions of SchemeUnit.} - +} @section{Compound Testing Evaluation Context} diff --git a/collects/schemeunit/scribblings/misc.scrbl b/collects/schemeunit/scribblings/misc.scrbl index cf73dd9598..51af0161c8 100644 --- a/collects/schemeunit/scribblings/misc.scrbl +++ b/collects/schemeunit/scribblings/misc.scrbl @@ -17,5 +17,5 @@ especially when mixed with compiled code. Use at your own risk! This example gets @scheme[make-failure-test], which is defined in a SchemeUnit test: @schemeblock[ -(require/expose schemeunit/check-test (make-failure-test)) +(require/expose schemeunit/private/check-test (make-failure-test)) ] diff --git a/collects/schemeunit/scribblings/ui.scrbl b/collects/schemeunit/scribblings/ui.scrbl index b4d30e439c..3b80a25e91 100644 --- a/collects/schemeunit/scribblings/ui.scrbl +++ b/collects/schemeunit/scribblings/ui.scrbl @@ -13,13 +13,13 @@ The textual UI is in the @schememodname[schemeunit/text-ui] module. It is run via the @scheme[run-tests] function. @defproc[(run-tests (test (or/c test-case? test-suite?)) - (verbosity (symbols 'quite 'normal 'verbose) 'normal)) + (verbosity (symbols 'quiet 'normal 'verbose) 'normal)) natural-number/c]{ The given @scheme[test] is run and the result of running it output to the @scheme[current-output-port]. The output is compatable with the (X)Emacs next-error command (as used, -for example, by (X)Emac's compile function) +for example, by (X)Emacs's compile function) The optional @scheme[verbosity] is one of @scheme['quiet], @scheme['normal], or @scheme['verbose]. Quiet output From 11b8fd4204bb3ff297ae377e4575c89c0ad31171 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 22 Feb 2010 20:57:36 +0000 Subject: [PATCH 4/4] Fix vector creation for internal field access. svn: r18269 --- collects/scheme/private/class-internal.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 2784d61608..ca2f65e767 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2576,10 +2576,10 @@ (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] - [int-field-refs (if (null? (class/c-inherits ctc)) + [int-field-refs (if (null? (class/c-inherit-fields ctc)) (class-int-field-refs cls) (make-vector field-pub-width))] - [int-field-sets (if (null? (class/c-inherits ctc)) + [int-field-sets (if (null? (class/c-inherit-fields ctc)) (class-int-field-sets cls) (make-vector field-pub-width))] [ext-field-refs (if (null? (class/c-fields ctc))