From 8b09485c3c41bd213e00aa728984c1f1634ae9c1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:21:45 +0000 Subject: [PATCH 01/27] Two more "langauge" typos svn: r17975 --- doc/release-notes/drscheme/HISTORY.txt | 2 +- doc/release-notes/redex/HISTORY.txt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 070dbe5653..39d626ac5d 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1188,7 +1188,7 @@ General - The teaching libraries are now called teachpacks. See the teachpack release notes for more information. - - DrScheme's languages have changed (again). The langauges are now: + - DrScheme's languages have changed (again). The languages are now: - Beginning Student - Intermediate Student diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 8ade9006d4..c24fc4365f 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -178,7 +178,7 @@ v4.1 (this is the first version that was included in the PLT - handling of non-terminals uses that have underscores in them now works properly (only showed up when using them - in the definition of a langauge) + in the definition of a language) - an extended language can now define multiple non-terminals together From c88a5a685674ea70991a97f35972bd5144483e7a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:21:52 +0000 Subject: [PATCH 02/27] A bunch of additional typos svn: r17976 --- .../private-combinator/combinator-parser.scm | 4 +-- .../private-combinator/errors.scm | 2 +- collects/compiler/private/xform.ss | 6 ++-- collects/ffi/objc.scrbl | 2 +- collects/ffi/sndfile.ss | 2 +- collects/framework/private/frame.ss | 2 +- collects/games/parcheesi/best-players.ss | 2 +- collects/games/slidey/slidey.ss | 8 +++--- .../handin-server/scribblings/checker.scrbl | 2 +- collects/meta/checker.ss | 2 +- collects/mred/private/wxme/text.ss | 4 +-- collects/mrlib/image-core.ss | 2 +- collects/mrlib/matrix-snip.ss | 2 +- .../mzlib/private/contract-arr-obj-helpers.ss | 16 +++++------ collects/plot/src/all/plcont.c | 2 +- collects/r6rs/scribblings/r6rs.scrbl | 2 +- collects/redex/tests/bitmap-test.ss | 2 +- collects/scheme/contract/private/ds.ss | 28 +++++++++---------- collects/scheme/match/split-rows.ss | 2 +- collects/scheme/private/string.ss | 2 +- .../guide/contracts-simple-function.scrbl | 2 +- .../scribblings/reference/eval-model.scrbl | 2 +- collects/scribblings/reference/evts.scrbl | 2 +- collects/scribblings/reference/rx.ss | 4 +-- .../scribblings/reference/sequences.scrbl | 2 +- .../scribblings/reference/stx-patterns.scrbl | 2 +- collects/srfi/19/time.ss | 2 +- .../danish-string-constants.ss | 2 +- .../english-string-constants.ss | 4 +-- .../french-string-constants.ss | 4 +-- .../german-string-constants.ss | 4 +-- .../japanese-string-constants.ss | 4 +-- .../portuguese-string-constants.ss | 2 +- .../simplified-chinese-string-constants.ss | 4 +-- .../spanish-string-constants.ss | 4 +-- .../traditional-chinese-string-constants.ss | 4 +-- collects/syntax/template.ss | 2 +- .../teachpack/2htdp/scribblings/image.scrbl | 8 +++--- collects/tests/drscheme/repl-test.ss | 2 +- .../mzscheme/benchmarks/common/graphs.sch | 10 +++---- .../benchmarks/shootout/regexmatch.ss | 4 +-- collects/typed-scheme/types/utils.ss | 4 +-- doc/release-notes/mred/HISTORY.txt | 2 +- src/mzscheme/gc/include/cord.h | 2 +- src/mzscheme/sgc/README | 2 +- src/mzscheme/src/env.c | 2 +- src/mzscheme/src/file.c | 2 +- src/mzscheme/src/schpriv.h | 2 +- src/wxmac/src/mac/wx_gdi.cc | 2 +- src/wxmac/utils/image/src/wx_imgx.h | 2 +- src/wxwindow/src/msw/wx_gdi.cxx | 2 +- src/wxxt/src/XWidgets/xwCommon.w | 2 +- src/wxxt/utils/image/src/wx_24to8.cc | 2 +- src/wxxt/utils/image/src/wx_imgx.h | 2 +- 54 files changed, 98 insertions(+), 98 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm index 02200db11d..9f21231d5b 100644 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ b/collects/combinator-parser/private-combinator/combinator-parser.scm @@ -153,7 +153,7 @@ (choice-res-errors result)) (fail-type->message (choice-res-errors result)) (make-err - (format "Found additional content after ~a, begining with '~a'." + (format "Found additional content after ~a, beginning with '~a'." (res-msg (car used-sort)) (input->output-name (car (res-rest (car used-sort))))) (and src? @@ -166,7 +166,7 @@ [(and (repeat-res? result) (fail-type? (repeat-res-stop result))) ;(printf "repeat-fail~n") (fail-type->message (repeat-res-stop result))] - [else (error 'parser (format "Internal error: recieved unexpected input ~a" + [else (error 'parser (format "Internal error: received unexpected input ~a" result))])]) (cond [(err? out) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index e5c6da9445..3bfe85507f 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -288,7 +288,7 @@ [(null? (cdr l)) (string-append "or " (car l))] [else (string-append (car l) ", " (formatter (cdr l)))]))]) (cond - [(null? l) (error 'internal-error "nice-list in combinator-parser/errors.scm recieved null list")] + [(null? l) (error 'internal-error "nice-list in combinator-parser/errors.scm received null list")] [(null? (cdr l)) (car l)] [(null? (cddr l)) (string-append (car l) " or " (cadr l))] [else (formatter l)]))) diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index 10a7b79eae..fe8f5f7d39 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -3272,7 +3272,7 @@ (define (convert-function-calls e vars &-vars c++-class live-vars complain-not-in memcpy? braces-are-aggregates?) ;; e is a single statement ;; Reverse to calculate live vars as we go. - ;; Also, it's easier to look for parens and then inspect preceeding + ;; Also, it's easier to look for parens and then inspect preceding ;; to find function calls. ;; complain-not-in is ither #f [function calls are ok], a string [not ok, string describes way], ;; or (list ok-exprs ...)) [in a rator position, only ok-expr calls are allowed, @@ -3608,7 +3608,7 @@ (not (null? (cdr assignee))) ;; ok if name starts with "_stk_" (not (regexp-match re:_stk_ (symbol->string (tok-n (car assignee))))) - ;; ok if preceeding is else or label terminator + ;; ok if preceding is else or label terminator (not (memq (tok-n (cadr assignee)) '(else |:|))) ;; assignment to field in record is ok (not (and (eq? (tok-n (cadr assignee)) '|.|) @@ -3617,7 +3617,7 @@ (null? (cdddr assignee)))) ;; ok if preceded by XFORM_OK_ASSIGN (not (eq? (tok-n (cadr assignee)) 'XFORM_OK_ASSIGN)) - ;; ok if preceeding is `if', `until', etc. + ;; ok if preceding is `if', `until', etc. (not (and (parens? (cadr assignee)) (pair? (cddr assignee)) (memq (tok-n (caddr assignee)) '(if while for until)))))) diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index d5daa229e1..7678699d73 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -236,7 +236,7 @@ Returns the class of an object (or the meta-class of a class).} boolean?]{ Adds a method to a class. The @scheme[type] argument must be a FFI C -type (@seeCtype) that matches both @scheme[imp] and and the not +type (@seeCtype) that matches both @scheme[imp] and the not Objective-C type string @scheme[type-encoding].} @defproc[(class_addIvar [cls _Class] [name string?] [size exact-nonnegative-integer?] diff --git a/collects/ffi/sndfile.ss b/collects/ffi/sndfile.ss index a3dd4358c7..2ccaf9f5e9 100644 --- a/collects/ffi/sndfile.ss +++ b/collects/ffi/sndfile.ss @@ -23,7 +23,7 @@ (error '_sndfile "got a NULL pointer (bad info?)"))))) ;; sf_count_t is a count type that depends on the operating system however it -;; seems to be a long int for all teh supported ones so in this scase we just +;; seems to be a long int for all the supported ones so in this scase we just ;; define it as two ints. (define _sf-count-t _int64) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index e6facf4935..154af717ea 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -543,7 +543,7 @@ ;; this flag is specific to this frame ;; the true state of the info panel is ;; the combination of this flag and the - ;; the 'framework:show-status-line preference + ;; 'framework:show-status-line preference ;; as shown in update-info-visibility (define info-hidden? #f) (define/public (hide-info) diff --git a/collects/games/parcheesi/best-players.ss b/collects/games/parcheesi/best-players.ss index aa74a87a8b..6110fd3c92 100644 --- a/collects/games/parcheesi/best-players.ss +++ b/collects/games/parcheesi/best-players.ss @@ -316,7 +316,7 @@ careful charlie [(eq? their-loc 'start) (let ([their-enter-spot (get-enter-pos (pawn-color pawn))]) ;; this code assumes that the enter-pos's are not within 6 of - ;; where the board indicies wrap around. + ;; where the board indices wrap around. (cond [(= my-loc their-enter-spot) (add-single-roll-chances 5) diff --git a/collects/games/slidey/slidey.ss b/collects/games/slidey/slidey.ss index 07888d3b23..5e28f5ffb7 100644 --- a/collects/games/slidey/slidey.ss +++ b/collects/games/slidey/slidey.ss @@ -252,10 +252,10 @@ (define/private (draw-cell draw-i draw-j) (let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)]) (let* ([dc (get-dc)] - [indicies (board-ref board draw-i draw-j)]) - (if indicies - (let ([bm-i (loc-x indicies)] - [bm-j (loc-y indicies)]) + [indices (board-ref board draw-i draw-j)]) + (if indices + (let ([bm-i (loc-x indices)] + [bm-j (loc-y indices)]) (let-values ([(xs ys ws hs) (ij->xywh bm-i bm-j)]) (send dc set-pen pict-pen) (send dc set-brush pict-brush) diff --git a/collects/handin-server/scribblings/checker.scrbl b/collects/handin-server/scribblings/checker.scrbl index 54bc9d8b86..e191ae13dc 100644 --- a/collects/handin-server/scribblings/checker.scrbl +++ b/collects/handin-server/scribblings/checker.scrbl @@ -152,7 +152,7 @@ Keywords for configuring @scheme[check:]: @item{@indexed-scheme[:student-line]---when a submission is converted to text, it begins with lines describing the students that have submitted it; this is used to specify the format of these lines. It - is a string with holes that that @scheme[user-substs] fills out. + is a string with holes that @scheme[user-substs] fills out. The default is @scheme["Student: {username} ({Full Name} <{Email}>)"], which requires @scheme["Full Name"] and @scheme["Email"] entries in the server's extra-fields configuration. These lines are prefixed diff --git a/collects/meta/checker.ss b/collects/meta/checker.ss index f5bf56c1c2..e9e61f9f4d 100644 --- a/collects/meta/checker.ss +++ b/collects/meta/checker.ss @@ -190,7 +190,7 @@ (provide tree-filter) ;; (string -> any) tree -> tree -;; If the filter returns '+ or '- this qualifies or disqualifies the the +;; If the filter returns '+ or '- this qualifies or disqualifies the ;; current tree immediately, otherwise recurse down directories. If any other ;; result is returned for directories scanning continues, and for files they ;; are included if the result is not #f. diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index f5a45d4529..3c07bc7a5d 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -1519,7 +1519,7 @@ (if (and gsnip (has-flag? (snip->flags gsnip) HARD-NEWLINE) (eq? (snip->next gsnip) snip)) - ;; preceeding snip was a newline, so the new slip belongs on the next line: + ;; preceding snip was a newline, so the new slip belongs on the next line: (let* ([oldline (snip->line gsnip)] [inserted-new-line? (if (mline-next oldline) @@ -4188,7 +4188,7 @@ (has-flag? (snip->flags gsnip) NEWLINE) (not (has-flag? (snip->flags gsnip) HARD-NEWLINE))) (begin - ;; we want the snip on the same line as the preceeding snip: + ;; we want the snip on the same line as the preceding snip: (if (snip->next gsnip) (insert-snip (snip->next gsnip) snip) (append-snip snip)) diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index 51444167b6..ef6dc81232 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -9,7 +9,7 @@ work right. Most of the exports are just for use in 2htdp/image (technically, 2htdp/private/image-more). The main use of this library is the snip class addition it -does (and any code that that does not depend on +does (and any code that does not depend on has been moved out). diff --git a/collects/mrlib/matrix-snip.ss b/collects/mrlib/matrix-snip.ss index ff6d5bd4ea..1a82069945 100644 --- a/collects/mrlib/matrix-snip.ss +++ b/collects/mrlib/matrix-snip.ss @@ -64,7 +64,7 @@ (super-new) (set-snipclass matrix-snip-class))) -;; the snip class for matricies +;; the snip class for matrices (define matrix-snip-class% (class cache-image-snip-class% (super-new) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 9d4d9800e8..377f975b89 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -350,7 +350,7 @@ (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indices (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) (with-syntax ([(name-dom-contract-x ...) @@ -393,7 +393,7 @@ (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indices (syntax (rng ...)))] [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))]) (values @@ -493,7 +493,7 @@ [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indices (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [dom-rest-x (car (generate-temporaries (list (syntax rest))))] [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] @@ -503,7 +503,7 @@ [(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indices (syntax (rng ...)))] [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))] [arity (length (syntax->list (syntax (dom ...))))]) @@ -566,7 +566,7 @@ [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indices (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [dom-rest-x (car (generate-temporaries (list (syntax rest))))] [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] @@ -688,7 +688,7 @@ (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indices (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) (values @@ -1126,10 +1126,10 @@ (syntax (let ([name rhs]) name)))] [else to-be-named]))) -;; generate-indicies : syntax[list] -> (cons number (listof number)) +;; generate-indices : syntax[list] -> (cons number (listof number)) ;; given a syntax list of length `n', returns a list containing ;; the number n followed by th numbers from 0 to n-1 -(define (generate-indicies stx) +(define (generate-indices stx) (let ([n (length (syntax->list stx))]) (cons n (let loop ([i n]) diff --git a/collects/plot/src/all/plcont.c b/collects/plot/src/all/plcont.c index d94d2da2d7..e05846c021 100644 --- a/collects/plot/src/all/plcont.c +++ b/collects/plot/src/all/plcont.c @@ -469,7 +469,7 @@ c_plcont(PLFLT **f, PLINT nx, PLINT ny, PLINT kx, PLINT lx, * The subrange of indices used for contouring is kx to lx in the x * direction and from ky to ly in the y direction. The array of contour * levels is clevel(nlevel), and "pltr" is the name of a function which - * transforms array indicies into world coordinates. + * transforms array indices into world coordinates. * * Note that the fortran-like minimum and maximum indices (kx, lx, ky, ly) * are translated into more C-like ones. I've only kept them as they are diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl index c663abb531..ffccce56b2 100644 --- a/collects/r6rs/scribblings/r6rs.scrbl +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -216,7 +216,7 @@ a version as a sequence of exact, non-negative integers. Roughly, such a name is converted to a PLT Scheme module pathname (see @secref[#:doc guide-src "module-paths"]) by concatenating the symbols with a @litchar{/} separator, and then appending the version integers each -with a preceeding @litchar{-}. As a special case, when an @|r6rs| path +with a preceding @litchar{-}. As a special case, when an @|r6rs| path contains a single symbol (optionally followed by a version), a @schemeidfont{main} symbol is effectively inserted after the initial symbol. See below for further encoding considerations. diff --git a/collects/redex/tests/bitmap-test.ss b/collects/redex/tests/bitmap-test.ss index 5b2bf981d7..9bc12d9697 100644 --- a/collects/redex/tests/bitmap-test.ss +++ b/collects/redex/tests/bitmap-test.ss @@ -71,7 +71,7 @@ ;; and a 'where' in the second clause (test (render-metafunction T) "metafunction-T.png") -;; in this test, teh `x' is italic and the 'z' is sf, since 'x' is in the grammar, and 'z' is not. +;; in this test, the `x' is italic and the 'z' is sf, since 'x' is in the grammar, and 'z' is not. (test (render-lw lang (to-lw ((λ (x) (x x)) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index 6568e52499..73f9bf424f 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -76,8 +76,8 @@ it around flattened out. [struct-maker struct-maker/val] [predicate predicate/val] [contract-name (add-suffix "-contract")] - [(selector-indicies ...) (nums-up-to field-count/val)] - [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] + [(selector-indices ...) (nums-up-to field-count/val)] + [(selector-indices+1 ...) (map add1 (nums-up-to field-count/val))] [(ctc-x ...) (generate-temporaries (syntax (fields ...)))] [(f-x ...) f-x/vals] [((f-xs ...) ...) f-xs/vals] @@ -113,7 +113,7 @@ it around flattened out. (lambda (k v) (when (unknown? v) (let ([proc (unknown-proc v)]) - (let ([new (proc (wrap-get stct selector-indicies+1) ...)]) + (let ([new (proc (wrap-get stct selector-indices+1) ...)]) (cond [(unknown? new) (set! any-unknown? #t)] @@ -177,7 +177,7 @@ it around flattened out. (cond [(raw-predicate stct) ;; found the original value - (values #f (get stct selector-indicies) ...)] + (values #f (get stct selector-indices) ...)] [(opt-wrap-predicate stct) (let ((inner (opt-wrap-get stct 0))) @@ -187,11 +187,11 @@ it around flattened out. (let-values ([(inner-stct fields ...) (loop inner)]) (let-values ([(fields ...) (enforcer stct fields ...)]) (opt-wrap-set stct 0 #f) - (opt-wrap-set stct selector-indicies+1 fields) ... + (opt-wrap-set stct selector-indices+1 fields) ... (values stct fields ...)))) ;; found a cached version - (values #f (opt-wrap-get stct selector-indicies+1) ...)))] + (values #f (opt-wrap-get stct selector-indices+1) ...)))] [(wrap-predicate stct) (let ([inner (wrap-get stct 0)]) (if inner @@ -201,19 +201,19 @@ it around flattened out. (let-values ([(fields ...) (rewrite-fields stct contract/info fields ...)]) (wrap-set stct 0 #f) - (wrap-set stct selector-indicies+1 fields) ... + (wrap-set stct selector-indices+1 fields) ... (evaluate-attrs stct contract/info) (values stct fields ...)))) ;; found a cached version of the value - (values #f (wrap-get stct selector-indicies+1) ...)))]))]) + (values #f (wrap-get stct selector-indices+1) ...)))]))]) (cond [(opt-wrap-predicate stct) (opt-wrap-get stct i+1)] [(wrap-predicate stct) (wrap-get stct i+1)]))) (define (rewrite-fields parent contract/info ctc-x ...) (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info) - selector-indicies)] + selector-indices)] [ctc (if (procedure? ctc-field) (ctc-field f-xs ...) ctc-field)] @@ -232,8 +232,8 @@ it around flattened out. (define (stronger-lazy-contract? a b) (and (contract-predicate b) (check-sub-contract? - (contract-get a selector-indicies) - (contract-get b selector-indicies)) ...)) + (contract-get a selector-indices) + (contract-get b selector-indices)) ...)) (define (lazy-contract-proj ctc) (λ (pos-blame neg-blame src-info orig-str positive-position?) @@ -286,7 +286,7 @@ it around flattened out. (contract-maker ctc-x ... #f))) (define (selectors x) - (burrow-in x 'selectors selector-indicies)) ... + (burrow-in x 'selectors selector-indices)) ... (define (burrow-in struct selector-name i) (cond @@ -306,7 +306,7 @@ it around flattened out. (define (lazy-contract-name ctc) (do-contract-name 'struct/c 'struct/dc - (list (contract-get ctc selector-indicies) ...) + (list (contract-get ctc selector-indices) ...) '(fields ...) (contract-get ctc field-count))) @@ -315,7 +315,7 @@ it around flattened out. #f (+ field-count 1) ;; extra field is for synthesized attribute ctcs ;; it is a list whose first element is - ;; a procedure (called once teh attrs are known) that + ;; a procedure (called once the attrs are known) that ;; indicates if the test passes. the rest of the elements are ;; procedures that build the attrs ;; this field is #f when there is no synthesized attrs diff --git a/collects/scheme/match/split-rows.ss b/collects/scheme/match/split-rows.ss index ebaba107d9..c2cb4ce992 100644 --- a/collects/scheme/match/split-rows.ss +++ b/collects/scheme/match/split-rows.ss @@ -5,7 +5,7 @@ (provide split-rows) ;; split-rows : Listof[Row] -> Listof[Listof[Row]] -;; takes a matrix, and returns a list of matricies +;; takes a matrix, and returns a list of matrices ;; each returned matrix does not require the mixture rule to do compilation of ;; the first column. (define (split-rows rows [acc null]) diff --git a/collects/scheme/private/string.ss b/collects/scheme/private/string.ss index f1de9e5c71..789b4f9b56 100644 --- a/collects/scheme/private/string.ss +++ b/collects/scheme/private/string.ss @@ -98,7 +98,7 @@ (let ([s (read-bytes drop input-port)]) (when out (display s out))) - ;; Get the matching part, and shift matching indicies + ;; Get the matching part, and shift matching indices (let ([s (read-bytes (- (cdar m) drop) input-port)]) (cons s (map (lambda (p) diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index 437f38647e..23e8381d0b 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -285,7 +285,7 @@ and thus used as a contract. But many other values also play double duty as contracts. For example, if your function accepts a number or @scheme[#f], -@scheme[(or/c number? #f)] sufficies. Similarly, the @scheme[result/c] contract +@scheme[(or/c number? #f)] suffices. Similarly, the @scheme[result/c] contract could have been written with a @scheme[0] in place of @scheme[zero?]. Even better, if you use a regular expression as a contract, the contract diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index e65caaf16b..2413479573 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -470,7 +470,7 @@ form is evaluated: 3] ] -The substition and @tech{location}-generation step of procedure +The substitution and @tech{location}-generation step of procedure application requires that the argument is a @tech{value}. Therefore, in @scheme[((lambda (x) (+ x 10)) (+ 1 2))], the @scheme[(+ 1 2)] sub-expression must be simplified to the @tech{value} @scheme[3], and diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index b423652918..590309821d 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/collects/scribblings/reference/evts.scrbl @@ -111,7 +111,7 @@ types can generate events (see @scheme[prop:evt]). @item{@scheme[_choice] --- an event returned by @scheme[choice-evt] is ready when one or more of the @scheme[_evt]s supplied to - @scheme[chocie-evt] are ready. If the choice event is chosen, one of + @scheme[choice-evt] are ready. If the choice event is chosen, one of its ready @scheme[_evt]s is chosen pseudo-randomly, and the result is the chosen @scheme[_evt]'s result.} diff --git a/collects/scribblings/reference/rx.ss b/collects/scribblings/reference/rx.ss index b4894db403..57302e8fe9 100644 --- a/collects/scribblings/reference/rx.ss +++ b/collects/scribblings/reference/rx.ss @@ -59,8 +59,8 @@ Lrange ::= ^ Lrange contains _^_ | Srange Lrange contains everything in Srange #co Look ::= (?=Regexp) Match if Regexp matches #mode | (?!Regexp) Match if Regexp doesn't match #mode - | (?<=Regexp) Match if Regexp matches preceeding #mode - | (? template portion is a vector, ;; contents like the list in map -;; - (box map) => template portion is a box with substition +;; - (box map) => template portion is a box with substitution ;; - #s(ellipses elem count map) => template portion is an ellipses-generated list ;; - #s(ellipses-quote map) => template has a quoting ellipses ;; - #s(prefab v map) => template portion is a prefab diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 4a40b50c49..3987ae00d8 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -237,7 +237,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ Constructs an arbitrary regular star polygon (a generalization of the regular polygons). The polygon is enclosed by a regular polygon with @scheme[side-count] sides each @scheme[side-length] long. The polygon is actually constructed by going from vertex to - vertex around the regular polgon, but skipping over every @scheme[step-count] verticies. + vertex around the regular polgon, but skipping over every @scheme[step-count] vertices. For examples, if @scheme[side-count] is @scheme[5] and @scheme[step-count] is @scheme[2], then this function produces a shape just like @scheme[star]. @@ -250,15 +250,15 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ } -@defproc*[([(polygon [verticies (listof posn?)] +@defproc*[([(polygon [vertices (listof posn?)] [mode mode?] [color image-color?]) image?] - [(polygon [verticies (listof posn?)] + [(polygon [vertices (listof posn?)] [outline-mode (or/c 'outline "outline")] [pen-or-color (or/c pen? image-color?)]) image?])]{ - Constructs a polygon connecting the given verticies. + Constructs a polygon connecting the given vertices. @mode/color-text diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index d86a2949af..874ddeed0e 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -1133,7 +1133,7 @@ tmp-load-filename ; given a filename "foo", we perform two operations on the contents ; of the file "foo.ss". First, we insert its contents into the REPL ; directly, and second, we use the load command. We compare the - ; the results of these operations against expected results. + ; results of these operations against expected results. (define ((run-single-test execute-text-start escape language-cust) in-vector) ;(printf "\n>> testing ~s\n" (test-program in-vector)) (let* ([program (test-program in-vector)] diff --git a/collects/tests/mzscheme/benchmarks/common/graphs.sch b/collects/tests/mzscheme/benchmarks/common/graphs.sch index bd846f4075..791aadcbff 100644 --- a/collects/tests/mzscheme/benchmarks/common/graphs.sch +++ b/collects/tests/mzscheme/benchmarks/common/graphs.sch @@ -55,7 +55,7 @@ state)))) ; Given the size of a vector and a procedure which -; sends indicies to desired vector elements, create +; sends indices to desired vector elements, create ; and return the vector. (define proc->vector (lambda (size f) @@ -278,7 +278,7 @@ ; vertex. Each entry is a bool indicating if the edge exists. ; The diagonal of the matrix is never examined. ; Make-minimal? returns a procedure which tests if a labelling -; of the verticies is such that the matrix is minimal. +; of the vertices is such that the matrix is minimal. ; If it is, then the procedure returns the result of folding over ; the elements of the automoriphism group. If not, it returns #f. ; The folding is done by calling folder via @@ -382,11 +382,11 @@ ; Fold over rooted directed graphs with bounded out-degree. -; Size is the number of verticies (including the root). Max-out is the +; Size is the number of vertices (including the root). Max-out is the ; maximum out-degree for any vertex. Folder is called via ; (folder edges state) ; where edges is a list of length size. The ith element of the list is -; a list of the verticies j for which there is an edge from i to j. +; a list of the vertices j for which there is an edge from i to j. ; The last vertex is the root. (define fold-over-rdg (lambda (size max-out folder state) @@ -622,7 +622,7 @@ ;;; ==== test input ==== -; Produces all directed graphs with N verticies, distinguished root, +; Produces all directed graphs with N vertices, distinguished root, ; and out-degree bounded by 2, upto isomorphism (there are 44). ;(define go diff --git a/collects/tests/mzscheme/benchmarks/shootout/regexmatch.ss b/collects/tests/mzscheme/benchmarks/shootout/regexmatch.ss index 94a22d9381..a8805fbe19 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/regexmatch.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/regexmatch.ss @@ -12,7 +12,7 @@ (module regexmatch mzscheme (define rx (string-append - "(?:^|[^0-9\\(])" ; (1) preceeding non-digit or bol + "(?:^|[^0-9\\(])" ; (1) preceding non-digit or bol "(" ; (2) area code "\\(([0-9][0-9][0-9])\\)" ; (3) is either 3 digits in parens "|" ; or @@ -22,7 +22,7 @@ "([0-9][0-9][0-9])" ; (5) exchange is 3 digits "[ -]" ; separator is either space or dash "([0-9][0-9][0-9][0-9])" ; (6) last 4 digits - "(?:[^0-9]|$)" ; must be followed by a non-digit + "(?:[^0-9]|$)" ; must be followed by a non-digit )) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 7545417592..85d4aa5b97 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -125,7 +125,7 @@ ;; substitute many variables ;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]] -;; subst-all : substition Type -> Type +;; subst-all : substitution Type -> Type (define (subst-all s t) (for/fold ([t t]) ([e s]) (match e @@ -309,4 +309,4 @@ ;; a parameter for the current polymorphic structure being defined ;; to allow us to prevent non-regular datatypes -(define current-poly-struct (make-parameter #f)) \ No newline at end of file +(define current-poly-struct (make-parameter #f)) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index b7cf89b6be..112dc6d5ea 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1360,7 +1360,7 @@ System: is just the right height to display one line of text. inherits from mred:wrapping-canvas% mred:frame-title-canvas% - updates the title of the frame when it recieves focus + updates the title of the frame when it receives focus events. inherits from mred:wrapping-canvas% - all of the "connection maintenence" ie edits that know which canvses they are in, frames that know which canvas is the most recently diff --git a/src/mzscheme/gc/include/cord.h b/src/mzscheme/gc/include/cord.h index 926089e86f..9082cc984a 100644 --- a/src/mzscheme/gc/include/cord.h +++ b/src/mzscheme/gc/include/cord.h @@ -299,7 +299,7 @@ size_t CORD_rchr(CORD x, size_t i, int c); /* the correct buffer size. */ /* 4. Most of the conversions are implement through the native */ /* vsprintf. Hence they are usually no faster, and */ -/* idiosyncracies of the native printf are preserved. However, */ +/* idiosyncrasies of the native printf are preserved. However, */ /* CORD arguments to CORD_sprintf and CORD_vsprintf are NOT copied; */ /* the result shares the original structure. This may make them */ /* very efficient in some unusual applications. */ diff --git a/src/mzscheme/sgc/README b/src/mzscheme/sgc/README index ed1306af54..361e6085be 100644 --- a/src/mzscheme/sgc/README +++ b/src/mzscheme/sgc/README @@ -2,7 +2,7 @@ SenoraGC is a relatively portable conservative GC for a slightly cooperative environment. The collector is intended mainly for debugging and memory tracing, but -it can also act as a reasonbaly effecient, general-purpose, +it can also act as a reasonbaly efficient, general-purpose, conservative collector. The standard MzScheme build uses SGC for certain platforms where Boehm's GC hasn't been ported, yet (notably, OSKit and BeOS). diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 60e7d2c208..9b01a0f8de 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -3335,7 +3335,7 @@ static void register_transitive_use(Optimize_Info *info, int pos, int j) void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map) { /* A closure map lists the captured variables for a closure; the - indices are resolved two new indicies in the second phase of + indices are resolved two new indices in the second phase of compilation. */ Optimize_Info *frame; int i, j, pos = 0, lpos = 0, tu; diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c index 81fd269655..eb2ad06a5e 100644 --- a/src/mzscheme/src/file.c +++ b/src/mzscheme/src/file.c @@ -2643,7 +2643,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta, /* Originally, it made sense to just perform build operations directly on string representations, because it was simple enough. Over the years, though, as we refined the path syntax for Windows - to deal with all of its idiosyncracies, this has gotten completely + to deal with all of its idiosyncrasies, this has gotten completely out of hand. */ { #define PN_BUF_LEN 256 diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 0e67fe98cf..54487f5a2b 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2832,7 +2832,7 @@ typedef struct Scheme_Module_Phase_Exports Scheme_Object *kernel_exclusion; /* we allow up to two exns, but they must be shadowed */ Scheme_Object *kernel_exclusion2; - Scheme_Hash_Table *ht; /* maps external names to array indicies; created lazily */ + Scheme_Hash_Table *ht; /* maps external names to array indices; created lazily */ } Scheme_Module_Phase_Exports; typedef struct Scheme_Module_Exports diff --git a/src/wxmac/src/mac/wx_gdi.cc b/src/wxmac/src/mac/wx_gdi.cc index 3710f5d76b..d7ab3904fd 100644 --- a/src/wxmac/src/mac/wx_gdi.cc +++ b/src/wxmac/src/mac/wx_gdi.cc @@ -606,7 +606,7 @@ wxCursor::wxCursor(wxBitmap *mask, wxBitmap *bm, int hotSpotX, int hotSpotY) } } - c = new WXGC_PTRS wxColour(); /* to recieve bit values */ + c = new WXGC_PTRS wxColour(); /* to receive bit values */ cMacCustomCursor = new WXGC_ATOMIC Cursor; diff --git a/src/wxmac/utils/image/src/wx_imgx.h b/src/wxmac/utils/image/src/wx_imgx.h index 289ed50cd5..7d5099edd8 100644 --- a/src/wxmac/utils/image/src/wx_imgx.h +++ b/src/wxmac/utils/image/src/wx_imgx.h @@ -401,7 +401,7 @@ typedef struct { byte *pic; /* image data */ #endif #endif -/* indicies into conv24MB */ +/* indices into conv24MB */ #define CONV24_8BIT 0 #define CONV24_24BIT 1 #define CONV24_SEP1 2 diff --git a/src/wxwindow/src/msw/wx_gdi.cxx b/src/wxwindow/src/msw/wx_gdi.cxx index 15762ca9b8..c9d0a9cb80 100644 --- a/src/wxwindow/src/msw/wx_gdi.cxx +++ b/src/wxwindow/src/msw/wx_gdi.cxx @@ -1377,7 +1377,7 @@ wxCursor::wxCursor(wxBitmap *bm, wxBitmap *mask, int hotSpotX, int hotSpotY) mask_dc = temp_mask_mdc; } - c = new wxColour(); /* to recieve bit values */ + c = new wxColour(); /* to receive bit values */ /* Windows wants cursor data in terms of an "and" bit array and "xor" bit array. */ diff --git a/src/wxxt/src/XWidgets/xwCommon.w b/src/wxxt/src/XWidgets/xwCommon.w index d7586244b9..bb9cf10486 100644 --- a/src/wxxt/src/XWidgets/xwCommon.w +++ b/src/wxxt/src/XWidgets/xwCommon.w @@ -222,7 +222,7 @@ to define them here. They will end up in the private(!) header file. @ A private variable is used to track the keyboard focus, but only while traversal is on. If |traversal_focus| is |True|, it means that -the widget has keyboard focus and that that focus is a result of +the widget has keyboard focus and that focus is a result of keyboard traversal. It also means that the widget's border is highlighted, although that is only visible if the |highlightThickness| is positive. diff --git a/src/wxxt/utils/image/src/wx_24to8.cc b/src/wxxt/utils/image/src/wx_24to8.cc index a6fa1f8952..1891aba5ae 100644 --- a/src/wxxt/utils/image/src/wx_24to8.cc +++ b/src/wxxt/utils/image/src/wx_24to8.cc @@ -886,7 +886,7 @@ int wxImage::QuickCheck(byte *pic24, int w, int h, int maxcol) finds more than 'maxcol' colors, it returns '0'. If it DOESN'T, it does the 24-to-8 conversion by simply sticking the colors it found into a colormap, and changing instances of a color in pic24 into colormap - indicies (in pic) */ + indices (in pic) */ unsigned long colors[256],col; int i, nc, low, high, mid; diff --git a/src/wxxt/utils/image/src/wx_imgx.h b/src/wxxt/utils/image/src/wx_imgx.h index c495d32c40..a01865d42b 100644 --- a/src/wxxt/utils/image/src/wx_imgx.h +++ b/src/wxxt/utils/image/src/wx_imgx.h @@ -382,7 +382,7 @@ typedef struct { byte *pic; /* image data */ #endif #endif -/* indicies into conv24MB */ +/* indices into conv24MB */ #define CONV24_8BIT 0 #define CONV24_24BIT 1 #define CONV24_SEP1 2 From 5c54f3a5aceaf5b7e8e94049c98e5b88d3055dd7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:21:56 +0000 Subject: [PATCH 03/27] Use `readline-input' for the port name, since `readline' makes error messages confusing. svn: r17977 --- collects/readline/pread.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss index 35931fa3af..3ce370f151 100644 --- a/collects/readline/pread.ss +++ b/collects/readline/pread.ss @@ -191,7 +191,7 @@ (bytes-set! tgt left LF) (set! buffer #f) (add1 left)]))]))) - (make-input-port 'readline reader #f close!))) + (make-input-port 'readline-input reader #f close!))) ;; -------------------------------------------------------------------------- ;; Reading functions From 18c8e41fac201d84a308b42f57f2dc5cc5107e2d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:21:59 +0000 Subject: [PATCH 04/27] Make it possible for the last expression in the body of a generator to return any number of values. They will be collected and used as the repeat-forever result of calling the generator again. Note: there's an exception for using no values -- instead of returning no values forever, use void, since no values can be more surprising, and it can happen when someone uses something like (generator (yield 1) (yield 2) (yield 3)) since the result of `yield' is (values). (This will change in a following commit, but even then it will be popular since people will usually invoke the generator with no arguments which leads to the zero values. Could be solved if you use (g (void)) -- but that's awkward, I think.) svn: r17978 --- collects/scheme/generator.ss | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index a8be9c3fae..81b9bb8961 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -56,10 +56,18 @@ (shift-at yield-tag k (set! cont k) value)) (reset-at yield-tag (parameterize ([current-yielder yielder]) - (let ([retval (begin body0 body ...)]) - ;; normal return: - (set! cont (lambda () retval)) - retval)))) + (call-with-values + (lambda () (begin body0 body ...)) + ;; only a normal return gets here + (case-lambda + ;; Note: in this case, the generator was invoked with no + ;; arguments, so returning no values is more symmetric. But + ;; this is a common case, and probably people would expect a + ;; void result more than no values. + [() (set! cont void)] + [(r) (set! cont (lambda () r))] + [rs (set! cont (lambda () (apply values rs)))])) + (cont)))) (define (generator) (cont)) generator)) From 505034ea26acbb63b9537735a361d166ad3b21b9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:01 +0000 Subject: [PATCH 05/27] The generator function can now be used to send values to the generator. For example, (define g (generator (yield (yield (yield 1))))) (list (g) (g 2) (g 3) (g 4) (g) (g)) evaluates to '(1 2 3 4 4 4). This is something that Python does (as a generator.send method), which might be useful for using generators as co-routines, and it is actually easy to implement since sending values is exactly what we get when the generator call is actually calling the saved continuation. So most of the change is dealing with the technicalities of throwing an error when the generator is called with some arguments, when that's done after it's terminated (at the stage where it's repeating the last value for ever). A few tests added for this. svn: r17979 --- collects/scheme/generator.ss | 45 ++++++++++++++++++++-------------- collects/tests/mzscheme/for.ss | 17 +++++++------ 2 files changed, 36 insertions(+), 26 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index 81b9bb8961..addd84d507 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -51,24 +51,33 @@ (define-syntax-rule (generator body0 body ...) (let () - (define (cont) - (define (yielder value) - (shift-at yield-tag k (set! cont k) value)) - (reset-at yield-tag - (parameterize ([current-yielder yielder]) - (call-with-values - (lambda () (begin body0 body ...)) - ;; only a normal return gets here - (case-lambda - ;; Note: in this case, the generator was invoked with no - ;; arguments, so returning no values is more symmetric. But - ;; this is a common case, and probably people would expect a - ;; void result more than no values. - [() (set! cont void)] - [(r) (set! cont (lambda () r))] - [rs (set! cont (lambda () (apply values rs)))])) - (cont)))) - (define (generator) (cont)) + (define cont + (case-lambda + [() + (define (yielder value) + (shift-at yield-tag k (set! cont k) value)) + (reset-at yield-tag + (parameterize ([current-yielder yielder]) + (define ret + (call-with-values + (lambda () (begin body0 body ...)) + ;; get here only on at the end of the generator + (case-lambda + ;; Note: in this case, the generator was invoked with no + ;; arguments, so returning no values is more symmetric. + ;; But this is a common case, and probably people would + ;; expect a void result more than no values. + [() void] + [(r) (lambda () r)] + [rs (lambda () (apply values rs))]))) + (set! cont (case-lambda + [() (ret)] + [_ (error 'generator "cannot send values to a ~a" + "generator that has terminated")])) + (ret)))] + [_ (error 'generator + "cannot send a value to a generator before it starts")])) + (define (generator . xs) (apply cont xs)) generator)) (define-syntax-rule (infinite-generator body0 body ...) diff --git a/collects/tests/mzscheme/for.ss b/collects/tests/mzscheme/for.ss index 192268e5ad..b7a36af631 100644 --- a/collects/tests/mzscheme/for.ss +++ b/collects/tests/mzscheme/for.ss @@ -235,15 +235,16 @@ (for/list ([x (in-generator (helper 0) (helper 1) (helper 2))]) x))) +(let ([g (lambda () (generator (yield 1) (yield 2) (yield 3)))]) + (let ([g (g)]) (test '(1 2 3) list (g) (g) (g))) + (let ([g (g)]) (test '(1 2 3 10 10) list (g) (g) (g) (g 10) (g))) + (let ([g (generator (yield (yield (yield 1))))]) + (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g)))) + (let* ([helper (lambda (pred num) - (for ([i (in-range 0 3)]) - (yield (pred (+ i num)))))] - [g1 (generator - (helper odd? 1) - (yield 'odd))] - [g2 (generator - (helper even? 1) - (yield 'even))]) + (for ([i (in-range 0 3)]) (yield (pred (+ i num)))))] + [g1 (generator (helper odd? 1) (yield 'odd))] + [g2 (generator (helper even? 1) (yield 'even))]) (test '(#t #f #f #t #t #f odd even) 'yield-helper (list (g1) (g2) (g1) (g2) (g1) (g2) (g1) (g2)))) From f1dcf49d38f454c5fe9a62113ac85f189648aad8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:04 +0000 Subject: [PATCH 06/27] Added `generator-state', implemented using a local state (which also simplifies the code that raises an error from the last change). svn: r17980 --- collects/scheme/generator.ss | 68 ++++++++++++++++++++-------------- collects/tests/mzscheme/for.ss | 9 ++++- 2 files changed, 48 insertions(+), 29 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index addd84d507..27f08bc027 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -4,7 +4,7 @@ scheme/control scheme/stxparam scheme/splicing) -(provide yield generator in-generator infinite-generator +(provide yield generator generator-state in-generator infinite-generator sequence->generator sequence->repeated-generator) ;; (define-syntax-parameter yield @@ -50,36 +50,48 @@ (define yield-tag (make-continuation-prompt-tag)) (define-syntax-rule (generator body0 body ...) - (let () - (define cont + (let ([state 'fresh]) + (define (cont) + (define (yielder value) + (shift-at yield-tag k (set! cont k) value)) + (set! state 'running) + (reset-at yield-tag + (parameterize ([current-yielder yielder]) + (call-with-values + (lambda () (begin body0 body ...)) + ;; get here only on at the end of the generator + (case-lambda + ;; Note: in the first case, the generator was invoked with no + ;; arguments, so returning no values is more symmetric. But + ;; this is a common case, and probably people would expect a + ;; void result more than no values. + [() (set! cont void)] + [(r) (set! cont (lambda () r))] + [rs (set! cont (lambda () (apply values rs)))])) + (set! state 'done) + (cont)))) + (define (err) + (error 'generator "cannot send a value to a ~a generator" state)) + (define generator (case-lambda - [() - (define (yielder value) - (shift-at yield-tag k (set! cont k) value)) - (reset-at yield-tag - (parameterize ([current-yielder yielder]) - (define ret - (call-with-values - (lambda () (begin body0 body ...)) - ;; get here only on at the end of the generator - (case-lambda - ;; Note: in this case, the generator was invoked with no - ;; arguments, so returning no values is more symmetric. - ;; But this is a common case, and probably people would - ;; expect a void result more than no values. - [() void] - [(r) (lambda () r)] - [rs (lambda () (apply values rs))]))) - (set! cont (case-lambda - [() (ret)] - [_ (error 'generator "cannot send values to a ~a" - "generator that has terminated")])) - (ret)))] - [_ (error 'generator - "cannot send a value to a generator before it starts")])) - (define (generator . xs) (apply cont xs)) + [() (cont)] + ;; yield-tag means return the state (see `generator-state' below) + [(x) (cond [(eq? x yield-tag) state] + [(eq? state 'running) (cont x)] + [else (err)])] + [xs (if (eq? state 'running) (apply cont xs) (err))])) generator)) +;; Get the state -- this is a hack: uses yield-tag as a hidden value that makes +;; the generator return its state. Protect against grabbing this tag (eg, with +;; (generator-state values)) by inspecting the result (so it can still be +;; deceived, but that will be harmless). +(define (generator-state g) + (let ([s (and (procedure? g) (procedure-arity-includes? g 1) (g yield-tag))]) + (if (memq s '(fresh running done)) + s + (raise-type-error 'generator-state "generator" g)))) + (define-syntax-rule (infinite-generator body0 body ...) (generator (let loop () body0 body ... (loop)))) diff --git a/collects/tests/mzscheme/for.ss b/collects/tests/mzscheme/for.ss index b7a36af631..6b503b6c00 100644 --- a/collects/tests/mzscheme/for.ss +++ b/collects/tests/mzscheme/for.ss @@ -239,7 +239,14 @@ (let ([g (g)]) (test '(1 2 3) list (g) (g) (g))) (let ([g (g)]) (test '(1 2 3 10 10) list (g) (g) (g) (g 10) (g))) (let ([g (generator (yield (yield (yield 1))))]) - (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g)))) + (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g))) + (let ([g (g)]) + (test '(fresh 1 running 2 running 3 running last done) + list (generator-state g) (g) + (generator-state g) (g) + (generator-state g) (g) + (generator-state g) (g 'last) + (generator-state g)))) (let* ([helper (lambda (pred num) (for ([i (in-range 0 3)]) (yield (pred (+ i num)))))] From 2f62cb192ef8bfdc3b66dade337d327e87078947 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:07 +0000 Subject: [PATCH 07/27] Allow using `yield' with any number of arguments which will be returned as multiple values. (These `case-lambda's are for making it fast, which is probably stupid given how slow this is anyway.) svn: r17981 --- collects/scheme/generator.ss | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index 27f08bc027..03cc85c53c 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -44,16 +44,21 @@ (lambda (v) (error 'yield "must be called in the context of a generator")))) -(define (yield value) - ((current-yielder) value)) +(define yield + (case-lambda [() ((current-yielder))] + [(v) ((current-yielder) v)] + [vs (apply (current-yielder) vs)])) (define yield-tag (make-continuation-prompt-tag)) (define-syntax-rule (generator body0 body ...) (let ([state 'fresh]) (define (cont) - (define (yielder value) - (shift-at yield-tag k (set! cont k) value)) + (define yielder + (case-lambda + [() (shift-at yield-tag k (set! cont k) (values))] + [(v) (shift-at yield-tag k (set! cont k) v)] + [vs (shift-at yield-tag k (set! cont k) (apply values vs))])) (set! state 'running) (reset-at yield-tag (parameterize ([current-yielder yielder]) From 3a08648dabadc3719f34d08629375022245a774e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:09 +0000 Subject: [PATCH 08/27] Added a `running' state, which is visible only from inside the generator. (Also considered making it an error when the generator is called while it is running, but that doesn't allow (yield (yield X)) fun.) svn: r17982 --- collects/scheme/generator.ss | 28 +++++++++++++++++++--------- collects/tests/mzscheme/for.ss | 9 ++++++++- 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index 03cc85c53c..068afb5b6e 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -55,10 +55,14 @@ (let ([state 'fresh]) (define (cont) (define yielder + ;; this `case-lambda' is ... um ... for "speed"... (case-lambda - [() (shift-at yield-tag k (set! cont k) (values))] - [(v) (shift-at yield-tag k (set! cont k) v)] - [vs (shift-at yield-tag k (set! cont k) (apply values vs))])) + [() (set! state 'suspended) + (shift-at yield-tag k (set! cont k) (values))] + [(v) (set! state 'suspended) + (shift-at yield-tag k (set! cont k) v)] + [vs (set! state 'suspended) + (shift-at yield-tag k (set! cont k) (apply values vs))])) (set! state 'running) (reset-at yield-tag (parameterize ([current-yielder yielder]) @@ -75,16 +79,22 @@ [rs (set! cont (lambda () (apply values rs)))])) (set! state 'done) (cont)))) - (define (err) - (error 'generator "cannot send a value to a ~a generator" state)) + (define (err [what "send a value to"]) + (error 'generator "cannot ~a a ~a generator" what state)) (define generator (case-lambda - [() (cont)] + [() (if #t ; (memq state '(fresh suspended done)) + (begin (set! state 'running) (cont)) + (err "call"))] ;; yield-tag means return the state (see `generator-state' below) [(x) (cond [(eq? x yield-tag) state] - [(eq? state 'running) (cont x)] + [(memq state '(suspended running)) + (set! state 'running) + (cont x)] [else (err)])] - [xs (if (eq? state 'running) (apply cont xs) (err))])) + [xs (if (memq state '(suspended running)) + (begin (set! state 'running) (apply cont xs)) + (err))])) generator)) ;; Get the state -- this is a hack: uses yield-tag as a hidden value that makes @@ -93,7 +103,7 @@ ;; deceived, but that will be harmless). (define (generator-state g) (let ([s (and (procedure? g) (procedure-arity-includes? g 1) (g yield-tag))]) - (if (memq s '(fresh running done)) + (if (memq s '(fresh running suspended done)) s (raise-type-error 'generator-state "generator" g)))) diff --git a/collects/tests/mzscheme/for.ss b/collects/tests/mzscheme/for.ss index 6b503b6c00..1d61983e4d 100644 --- a/collects/tests/mzscheme/for.ss +++ b/collects/tests/mzscheme/for.ss @@ -241,9 +241,16 @@ (let ([g (generator (yield (yield (yield 1))))]) (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g))) (let ([g (g)]) - (test '(fresh 1 running 2 running 3 running last done) + (test '(fresh 1 suspended 2 suspended 3 suspended last done) list (generator-state g) (g) (generator-state g) (g) + (generator-state g) (g) + (generator-state g) (g 'last) + (generator-state g))) + (letrec ([g (generator (yield (generator-state g)) + (yield (generator-state g)))]) + (test '(fresh running suspended running suspended last done) + list (generator-state g) (g) (generator-state g) (g) (generator-state g) (g 'last) (generator-state g)))) From d5822a3ee583c49e8b32775910479004e202457f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:12 +0000 Subject: [PATCH 09/27] Remove the special case hack for getting zero values at the end of a generator. This will make this: (generator (yield 1) (yield)) also repeat # when it's done which will be very confusing. Better just add a note in the docs on (generator (yield 1)) returning no values when it's done. Also, remove some of the `case-lambda' optimizations... svn: r17983 --- collects/scheme/generator.ss | 26 +++++++------------------- 1 file changed, 7 insertions(+), 19 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index 068afb5b6e..f209902b71 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -54,31 +54,19 @@ (define-syntax-rule (generator body0 body ...) (let ([state 'fresh]) (define (cont) - (define yielder - ;; this `case-lambda' is ... um ... for "speed"... - (case-lambda - [() (set! state 'suspended) - (shift-at yield-tag k (set! cont k) (values))] - [(v) (set! state 'suspended) - (shift-at yield-tag k (set! cont k) v)] - [vs (set! state 'suspended) - (shift-at yield-tag k (set! cont k) (apply values vs))])) + (define (yielder . vs) + (set! state 'suspended) + (shift-at yield-tag k (set! cont k) (apply values vs))) (set! state 'running) (reset-at yield-tag (parameterize ([current-yielder yielder]) (call-with-values (lambda () (begin body0 body ...)) ;; get here only on at the end of the generator - (case-lambda - ;; Note: in the first case, the generator was invoked with no - ;; arguments, so returning no values is more symmetric. But - ;; this is a common case, and probably people would expect a - ;; void result more than no values. - [() (set! cont void)] - [(r) (set! cont (lambda () r))] - [rs (set! cont (lambda () (apply values rs)))])) - (set! state 'done) - (cont)))) + (lambda rs + (set! state 'done) + (set! cont (lambda () (apply values rs))) + (cont)))))) (define (err [what "send a value to"]) (error 'generator "cannot ~a a ~a generator" what state)) (define generator From 2368290cdb88bbe88942afe551c2629391d7822e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:15 +0000 Subject: [PATCH 10/27] Test now that the generator is not in a running state when it's called. The previous problem was just a bug. svn: r17984 --- collects/scheme/generator.ss | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss index f209902b71..79a5939be1 100644 --- a/collects/scheme/generator.ss +++ b/collects/scheme/generator.ss @@ -64,16 +64,15 @@ (lambda () (begin body0 body ...)) ;; get here only on at the end of the generator (lambda rs - (set! state 'done) - (set! cont (lambda () (apply values rs))) + (set! cont (lambda () (set! state 'done) (apply values rs))) (cont)))))) (define (err [what "send a value to"]) (error 'generator "cannot ~a a ~a generator" what state)) (define generator (case-lambda - [() (if #t ; (memq state '(fresh suspended done)) - (begin (set! state 'running) (cont)) - (err "call"))] + [() (if (eq? state 'running) + (err "call") + (begin (set! state 'running) (cont)))] ;; yield-tag means return the state (see `generator-state' below) [(x) (cond [(eq? x yield-tag) state] [(memq state '(suspended running)) From 536d0266df06a286785583f37612a8c861fb99ac Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:17 +0000 Subject: [PATCH 11/27] Use unsafe operations in `sort'. It has been running in safe mode for a while with no errors reported, and this change is done now when there's time before the next release. svn: r17985 --- collects/scheme/private/sort.ss | 37 +++++++++++++++++---------------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index a528b57ce9..bea358fa20 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -24,16 +24,16 @@ doing these checks. |# -;; This code works with unsafe operations, but don't use it for a while to -;; catch potential problems. -;; (#%require (rename '#%unsafe i+ unsafe-fx+) -;; (rename '#%unsafe i- unsafe-fx-) -;; (rename '#%unsafe i= unsafe-fx=) -;; (rename '#%unsafe i< unsafe-fx<) -;; (rename '#%unsafe i<= unsafe-fx<=) -;; (rename '#%unsafe i>> unsafe-fxrshift) -;; (rename '#%unsafe vref unsafe-vector-ref) -;; (rename '#%unsafe vset! unsafe-vector-set!)) +;; This code works with unsafe operations, if there are problems, the commented +;; chunk of code below can be used to run it in safe mode. +(#%require (rename '#%unsafe i+ unsafe-fx+) + (rename '#%unsafe i- unsafe-fx-) + (rename '#%unsafe i= unsafe-fx=) + (rename '#%unsafe i< unsafe-fx<) + (rename '#%unsafe i<= unsafe-fx<=) + (rename '#%unsafe i>> unsafe-fxrshift) + (rename '#%unsafe vref unsafe-vector-ref) + (rename '#%unsafe vset! unsafe-vector-set!)) (define sort (let () @@ -42,14 +42,15 @@ doing these checks. [(dr (foo . pattern) template) (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) -(define-syntax-rule (i+ x y) (+ x y)) -(define-syntax-rule (i- x y) (- x y)) -(define-syntax-rule (i= x y) (= x y)) -(define-syntax-rule (i< x y) (< x y)) -(define-syntax-rule (i<= x y) (<= x y)) -(define-syntax-rule (i>> x y) (arithmetic-shift x (- y))) -(define-syntax-rule (vref v i) (vector-ref v i)) -(define-syntax-rule (vset! v i x) (vector-set! v i x)) +;; Use this to make it safe: +;; (define-syntax-rule (i+ x y) (+ x y)) +;; (define-syntax-rule (i- x y) (- x y)) +;; (define-syntax-rule (i= x y) (= x y)) +;; (define-syntax-rule (i< x y) (< x y)) +;; (define-syntax-rule (i<= x y) (<= x y)) +;; (define-syntax-rule (i>> x y) (arithmetic-shift x (- y))) +;; (define-syntax-rule (vref v i) (vector-ref v i)) +;; (define-syntax-rule (vset! v i x) (vector-set! v i x)) (define-syntax-rule (sort-internal-body v *> n 1)] [n/2+ (i- n n/2-)]) From a4954b774da5f239db5f84fe9e0c234e2988c460 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:21 +0000 Subject: [PATCH 12/27] Use optional arguments instead of `case-lambda'. svn: r17986 --- collects/scheme/sandbox.ss | 34 ++++++++++++++-------------------- 1 file changed, 14 insertions(+), 20 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index d958780c51..897f94183c 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -761,28 +761,22 @@ (cond [(eof-object? r) (terminate+kill! #t #t)] [(eq? (car r) 'exn) (raise (cdr r))] [else (apply values (cdr r))]))])) - (define get-uncovered - (case-lambda - [() (get-uncovered #t)] - [(prog?) (get-uncovered prog? 'program)] - [(prog? src) - (unless uncovered - (error 'get-uncovered-expressions "no coverage information")) - (let ([uncovered (if prog? (car uncovered) ((cadr uncovered)))]) - (if src - (filter (lambda (x) (equal? src (syntax-source x))) uncovered) - uncovered))])) + (define (get-uncovered [prog? #t] [src 'program]) + (unless uncovered + (error 'get-uncovered-expressions "no coverage information")) + (let ([uncovered (if prog? (car uncovered) ((cadr uncovered)))]) + (if src + (filter (lambda (x) (equal? src (syntax-source x))) uncovered) + uncovered))) (define (output-getter p) (if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p)) - (define input-putter - (case-lambda - [() (input-putter input)] - [(arg) (cond [(not input) - (error 'put-input "evaluator input is not 'pipe")] - [(or (string? arg) (bytes? arg)) - (display arg input) (flush-output input)] - [(eof-object? arg) (close-output-port input)] - [else (error 'put-input "bad argument: ~e" arg)])])) + (define (input-putter [arg input]) + (cond [(not input) + (error 'put-input "evaluator input is not 'pipe")] + [(or (string? arg) (bytes? arg)) + (display arg input) (flush-output input)] + [(eof-object? arg) (close-output-port input)] + [else (error 'put-input "bad argument: ~e" arg)])) (define (evaluator expr) (if (evaluator-message? expr) (let ([msg (evaluator-message-msg expr)]) From 2cc4429c6250c275bac8554adb2a1037048e5c27 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:23 +0000 Subject: [PATCH 13/27] When constructing code, use the `object-name' of the input port *only* if it's coming from a file -- not when it's a string. In that case, use `#f' for the name, so other code (specifically, `input->code') will use 'program. svn: r17987 --- collects/scheme/sandbox.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 897f94183c..f94f682779 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -430,8 +430,8 @@ (define (input->port inp) ;; returns #f when it can't create a port (cond [(input-port? inp) inp] - [(string? inp) (open-input-string inp)] - [(bytes? inp) (open-input-bytes inp)] + [(string? inp) (open-input-string inp #f)] + [(bytes? inp) (open-input-bytes inp #f)] [(path? inp) (open-input-file inp)] [else #f])) From 0725ba7608ecf464689254d877082e53e53aa89f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 03:22:26 +0000 Subject: [PATCH 14/27] Reformat svn: r17988 --- collects/scheme/sandbox.ss | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index f94f682779..000eb3c1ba 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -826,13 +826,12 @@ ;; set up the IO context [current-input-port (let ([inp (sandbox-input)]) - (cond - [(not inp) null-input] - [(input->port inp) => values] - [(and (procedure? inp) (procedure-arity-includes? inp 0)) (inp)] - [(eq? 'pipe inp) - (let-values ([(i o) (make-pipe)]) (set! input o) i)] - [else (error 'make-evaluator "bad sandbox-input: ~e" inp)]))] + (cond [(not inp) null-input] + [(input->port inp) => values] + [(and (procedure? inp) (procedure-arity-includes? inp 0)) (inp)] + [(eq? 'pipe inp) + (let-values ([(i o) (make-pipe)]) (set! input o) i)] + [else (error 'make-evaluator "bad sandbox-input: ~e" inp)]))] [current-output-port (make-output 'output (sandbox-output) (lambda (o) (set! output o)))] [current-error-port (make-output 'error-output (sandbox-error-output) From 578637c691ec0301554d0170ff6ba713446c1790 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Fri, 5 Feb 2010 04:49:49 +0000 Subject: [PATCH 15/27] Added types for missing hash table operations. svn: r17989 --- collects/typed-scheme/private/base-env.ss | 31 ++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 6f8bad78fa..1e273d7c4a 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -365,11 +365,20 @@ [(-Path) (-lst -Path)])] [hash? (make-pred-ty (make-HashtableTop))] +[hash-eq? (-> (make-HashtableTop) B)] +[hash-eqv? (-> (make-HashtableTop) B)] +[hash-weak? (-> (make-HashtableTop) B)] [make-hash (-poly (a b) (-> (-HT a b)))] [make-hasheq (-poly (a b) (-> (-HT a b)))] +[make-hasheqv (-poly (a b) (-> (-HT a b)))] [make-weak-hash (-poly (a b) (-> (-HT a b)))] [make-weak-hasheq (-poly (a b) (-> (-HT a b)))] +[make-weak-hasheqv (-poly (a b) (-> (-HT a b)))] +[make-immutable-hash (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] +[make-immutable-hasheq (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] +[make-immutable-hasheqv (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] +[hash-set (-poly (a b) ((-HT a b) a b . -> . (-HT a b)))] [hash-set! (-poly (a b) ((-HT a b) a b . -> . -Void))] [hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))] [hash-ref (-poly (a b c) @@ -379,6 +388,25 @@ [hash-ref! (-poly (a b) (cl-> [((-HT a b) a (-> b)) b] [((-HT a b) a b) b]))] +[hash-has-key? (-poly (a b) (-> (-HT a b) a B))] +[hash-update! (-poly (a b) + (cl-> [((-HT a b) a (-> b b)) -Void] + [((-HT a b) a (-> b b) (-> a)) -Void] + [((-HT a b) a (-> b b) a) -Void]))] +[hash-update (-poly (a b) + (cl-> [((-HT a b) a (-> b b)) (-HT a b)] + [((-HT a b) a (-> b b) (-> a)) (-HT a b)] + [((-HT a b) a (-> b b) a) (-HT a b)]))] +[hash-remove (-poly (a b) ((-HT a b) a . -> . (-HT a b)))] +[hash-remove! (-poly (a b) ((-HT a b) a . -> . -Void))] +[hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))] +[hash-for-each (-poly (a b c) (-> (-HT a b) (-> a b c) -Void))] +[hash-count (-poly (a b) (-> (-HT a b) -Nat))] +[hash-copy (-poly (a b) (-> (-HT a b) (-HT a b)))] +[eq-hash-code (-poly (a) (-> a -Integer))] +[eqv-hash-code (-poly (a) (-> a -Integer))] +[equal-hash-code (-poly (a) (-> a -Integer))] +[equal-secondary-hash-code (-poly (a) (-> a -Integer))] [hash-iterate-first (-poly (a b) ((-HT a b) . -> . (Un (-val #f) -Integer)))] [hash-iterate-next (-poly (a b) @@ -428,9 +456,6 @@ [make-directory (-> -Path -Void)] -[hash-for-each (-poly (a b c) - (-> (-HT a b) (-> a b c) -Void))] - [delete-file (-> -Pathlike -Void)] [make-namespace (->opt [(Un (-val 'empty) (-val 'initial))] -Namespace)] [make-base-namespace (-> -Namespace)] From f2852257bb0987a0ffd5ca51d06ac0adf3d4a34d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Fri, 5 Feb 2010 05:22:49 +0000 Subject: [PATCH 16/27] Added types for char->integer and integer->char. svn: r17990 --- collects/typed-scheme/private/base-env.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 1e273d7c4a..2a9355da15 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -209,6 +209,8 @@ [char-downcase (-> -Char -Char)] [char-titlecase (-> -Char -Char)] [char-foldcase (-> -Char -Char)] +[char->integer (-> -Nat -Char)] +[integer->char (-> -Char -Nat)] [string-normalize-nfd (-> -String -String)] [string-normalize-nfkd (-> -String -String)] From f9ae636aead96beb7ceac5fbeb5a0fd2185c08ac Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Fri, 5 Feb 2010 06:24:44 +0000 Subject: [PATCH 17/27] Oops, got the types of char->integer and integer->char backwards. svn: r17991 --- collects/typed-scheme/private/base-env.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 2a9355da15..31495f596f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -209,8 +209,8 @@ [char-downcase (-> -Char -Char)] [char-titlecase (-> -Char -Char)] [char-foldcase (-> -Char -Char)] -[char->integer (-> -Nat -Char)] -[integer->char (-> -Char -Nat)] +[char->integer (-> -Char -Nat)] +[integer->char (-> -Nat -Char)] [string-normalize-nfd (-> -String -String)] [string-normalize-nfkd (-> -String -String)] From 44445c32105bce4cca34c9046746184ccc8cafa3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 5 Feb 2010 08:50:44 +0000 Subject: [PATCH 18/27] Welcome to a new PLT day. svn: r17992 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 0a50f30c16..ee67ea6dd0 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "4feb2010") +#lang scheme/base (provide stamp) (define stamp "5feb2010") From 46b61873aa30e2df022429a182a5ad2002d3914f Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Fri, 5 Feb 2010 17:06:05 +0000 Subject: [PATCH 19/27] Move lazy global initialization to init_fun svn: r17994 --- src/mzscheme/src/fun.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 86e35a220a..782c5c4b44 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -548,9 +548,11 @@ scheme_init_fun (Scheme_Env *env) REGISTER_SO(is_method_symbol); REGISTER_SO(scheme_inferred_name_symbol); REGISTER_SO(cont_key); + REGISTER_SO(barrier_prompt_key); is_method_symbol = scheme_intern_symbol("method-arity-error"); scheme_inferred_name_symbol = scheme_intern_symbol("inferred-name"); cont_key = scheme_make_symbol("k"); /* uninterned */ + barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */ REGISTER_SO(scheme_default_prompt_tag); { @@ -2150,11 +2152,6 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Schem if (!new_thread) { prompt->is_barrier = 1; } - - if (!barrier_prompt_key) { - REGISTER_SO(barrier_prompt_key); - barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */ - } } #ifdef MZ_PRECISE_GC From ccbe173d0833ddf6e023a2e73cd9f2036239a1d5 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Fri, 5 Feb 2010 17:06:13 +0000 Subject: [PATCH 20/27] Places GC fixes svn: r17995 --- src/mzscheme/gc2/newgc.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 32640c0b10..4cacc57f08 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -1866,6 +1866,7 @@ static void Master_collect() { } else { printf("%i SIGNALED BUT NOT COLLECTED\n", i); + children_ready = 0; } } if (children_ready) { From ce7c7eac7b265d92627c140b75ed8f8586652ed0 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Fri, 5 Feb 2010 17:28:00 +0000 Subject: [PATCH 21/27] Removed unused parameters to grab_continuation svn: r17996 --- src/mzscheme/src/fun.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 782c5c4b44..06783af495 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -5058,9 +5058,9 @@ call_cc (int argc, Scheme_Object *argv[]) static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int composable, Scheme_Object *prompt_tag, Scheme_Cont *sub_cont, Scheme_Prompt *prompt, - Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos, - Scheme_Prompt *barrier_prompt, Scheme_Prompt *effective_barrier_prompt, - Scheme_Meta_Continuation *barrier_cont, MZ_MARK_POS_TYPE barrier_pos) + Scheme_Meta_Continuation *prompt_cont, + Scheme_Prompt *effective_barrier_prompt + ) { Scheme_Cont *cont; @@ -5697,8 +5697,7 @@ internal_call_cc (int argc, Scheme_Object *argv[]) } cont = grab_continuation(p, 0, composable, prompt_tag, sub_cont, - prompt, prompt_cont, prompt_pos, - barrier_prompt, effective_barrier_prompt, barrier_cont, barrier_pos); + prompt, prompt_cont, effective_barrier_prompt); scheme_zero_unneeded_rands(p); @@ -6104,7 +6103,7 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, /* Grab a continuation so that we capture the current Scheme stack, etc.: */ - saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, 0, NULL, NULL, NULL, 0); + saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, NULL); if (p->meta_prompt) saved->prompt_stack_start = p->meta_prompt->stack_boundary; From 17f83a5a54e43abfbcdca5ea1958c9eb0f62a02b Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Fri, 5 Feb 2010 20:49:10 +0000 Subject: [PATCH 22/27] Corrected contract of datum->syntax source locations. svn: r17997 --- collects/scribblings/reference/stx-ops.scrbl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 4969cd889f..3bce8c6399 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -145,13 +145,13 @@ needed to strip lexical and source-location information recursively.} (list/c any/c (or/c exact-positive-integer? #f) (or/c exact-nonnegative-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-positive-integer? #f)) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f)) (vector/c any/c (or/c exact-positive-integer? #f) (or/c exact-nonnegative-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-positive-integer? #f))) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f))) #f] [prop (or/c syntax? #f) #f] [cert (or/c syntax? #f) #f]) From bf77c690f4d1a97fb530ea23602bf590f32f2479 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 5 Feb 2010 23:00:07 +0000 Subject: [PATCH 23/27] fix let/ec: and let/cc: svn: r18000 --- collects/typed-scheme/private/annotate-classes.ss | 7 +++++++ collects/typed-scheme/private/prims.ss | 4 ++-- collects/typed-scheme/ts-reference.scrbl | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/annotate-classes.ss b/collects/typed-scheme/private/annotate-classes.ss index 09b369d60d..0264868d9c 100644 --- a/collects/typed-scheme/private/annotate-classes.ss +++ b/collects/typed-scheme/private/annotate-classes.ss @@ -14,6 +14,13 @@ #:with ty (syntax-property #'name 'type-label) #:with ann-name #'name)) +(define-splicing-syntax-class (param-annotated-name trans) + #:attributes (name ty ann-name) + #:description "type-annotated identifier" + #:literals (:) + (pattern [~seq name:id : ty] + #:with ann-name (syntax-property #'name 'type-label (trans #'ty)))) + (define-syntax-class annotated-binding #:attributes (name ty ann-name binding rhs) (pattern (~and whole [:annotated-name rhs:expr]) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 6d91e099c2..81f9e014f2 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -340,6 +340,6 @@ This file defines two sorts of primitives. All of them are provided into any mod (let () (define ((mk l/c) stx) (syntax-parse stx - [(_ k:annotated-name . body) - (quasisyntax/loc stx (#,l/c k.name . body))])) + [(_ (~var k (param-annotated-name (lambda (s) #`(#,s -> (U))))) . body) + (quasisyntax/loc stx (#,l/c k.ann-name . body))])) (values (mk #'let/cc) (mk #'let/ec)))) diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index 3e7731dc74..9ad4989cd2 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -132,7 +132,7 @@ result of @scheme[_loop] (and thus the result of the entire @deftogether[[ @defform[(let/cc: v : t . body)] @defform[(let/ec: v : t . body)]]]{Type-annotated versions of -@scheme[let/cc] and @scheme[let/ec].} +@scheme[let/cc] and @scheme[let/ec]. @scheme[t] is the type that will be provided to the continuation @scheme[v].} @subsection{Anonymous Functions} From ecb9961bc074b29a16f301318f5b84ab4ef65da8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 6 Feb 2010 08:50:38 +0000 Subject: [PATCH 24/27] Welcome to a new PLT day. svn: r18002 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index ee67ea6dd0..8840b63e8b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "5feb2010") +#lang scheme/base (provide stamp) (define stamp "6feb2010") From 43e74725bf096c7eb0cace7930ebf7c7abe0bda0 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 6 Feb 2010 16:05:32 +0000 Subject: [PATCH 25/27] Synch German string constants with latest. svn: r18003 --- collects/string-constants/german-string-constants.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index 4bffcae76f..e2c26b9436 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -951,6 +951,7 @@ (initial-language-category "Sprache am Anfang") (no-language-chosen "Keine Sprache ausgewählt") + (module-language-name "Sprache aus Quelltext ermitteln") (module-language-one-line-summary "List die #lang-Zeile, um die tatsächliche Sprache zu ermitteln.") (module-language-auto-text "Automatisch Zeile mit #lang") ;; shows up in the details section of the module language From 75a60162b0f173d19d6ac5bd3d4c3b434c9243e4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 6 Feb 2010 17:13:49 +0000 Subject: [PATCH 26/27] another attempt to get the drscheme gui test suite in shape to be run by drdr svn: r18004 --- collects/tests/drscheme/drscheme-test-util.ss | 44 ++++++--- collects/tests/drscheme/io.ss | 27 +++--- collects/tests/drscheme/language-test.ss | 5 +- .../tests/drscheme/module-lang-test-utils.ss | 1 - collects/tests/drscheme/module-lang-test.ss | 13 +-- collects/tests/drscheme/repl-test.ss | 92 +++++++++---------- collects/tests/drscheme/run.sh | 7 ++ collects/tests/drscheme/syncheck-test.ss | 37 +++----- collects/tests/drscheme/teachpack.ss | 5 +- 9 files changed, 115 insertions(+), 116 deletions(-) create mode 100644 collects/tests/drscheme/run.sh diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index d529b5a917..f140b7772f 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -11,7 +11,7 @@ [use-get/put-dialog (-> (-> any) path? void?)] [set-module-language! (->* () (boolean?) void?)]) - (provide fire-up-drscheme + (provide fire-up-drscheme-and-run-tests save-drscheme-window-as do-execute test-util-error @@ -622,13 +622,35 @@ ;; but just to print and return. (define orig-display-handler (error-display-handler)) - (define (fire-up-drscheme) - (dynamic-require 'drscheme #f) - - ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it) - (uncaught-exception-handler - (λ (x) - (if (exn? x) - (orig-display-handler (exn-message x) x) - (fprintf (current-error-port) "uncaught exception ~s\n" x)) - (exit 1)))) \ No newline at end of file + (define (fire-up-drscheme-and-run-tests run-test) + (let () + ;; change the preferences system so that it doesn't write to + ;; a file; partly to avoid problems of concurrency in drdr + ;; but also to make the test suite easier for everyone to run. + (let ([prefs-table (make-hash)]) + (fw:preferences:low-level-put-preferences + (lambda (names vals) + (for-each (lambda (name val) (hash-set! prefs-table name val)) + names vals))) + (fw:preferences:low-level-get-preference + (lambda (name [fail (lambda () #f)]) + (hash-ref prefs-table name fail)))) + + (dynamic-require 'drscheme #f) + + ;; set all preferences to their defaults (some pref values may have + ;; been read by this point, but hopefully that won't affect much + ;; of the startup of drscheme) + (fw:preferences:restore-defaults) + + (thread (λ () + (let ([orig-display-handler (error-display-handler)]) + (uncaught-exception-handler + (λ (x) + (if (exn? x) + (orig-display-handler (exn-message x) x) + (fprintf (current-error-port) "uncaught exception ~s\n" x)) + (exit 1)))) + (run-test) + (exit))) + (yield (make-semaphore 0)))) \ No newline at end of file diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 442550537d..8665a42459 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -183,20 +183,15 @@ add this test: (define drs-frame #f) (define interactions-text #f) -(let ([s (make-semaphore)]) - (fire-up-drscheme) - (thread - (λ () - (set! drs-frame (wait-for-drscheme-frame)) - (set! interactions-text (send drs-frame get-interactions-text)) - (set-language-level! (list #rx"Pretty Big")) - (clear-definitions drs-frame) - (do-execute drs-frame) - - (output-err-port-checking) ;; must come first - ;(long-io/execute-test) - (reading-test) - (semaphore-post s))) - (yield s) - (exit)) +(fire-up-drscheme-and-run-tests + (λ () + (set! drs-frame (wait-for-drscheme-frame)) + (set! interactions-text (send drs-frame get-interactions-text)) + (set-language-level! (list #rx"Pretty Big")) + (clear-definitions drs-frame) + (do-execute drs-frame) + + (output-err-port-checking) ;; must come first + ;;(long-io/execute-test) + (reading-test))) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 11bc5c7c69..cfed7e29c8 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -1352,7 +1352,4 @@ the settings above should match r5rs (go pretty-big) (go r5rs)) -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore))) \ No newline at end of file +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index af9295d51e..4dc6289b12 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -129,7 +129,6 @@ error-ranges-expected (send interactions-text get-error-ranges))))]))))) - (define drs 'not-yet-drs-frame) (define interactions-text 'not-yet-interactions-text) (define definitions-text 'not-yet-definitions-text) diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index 83bbecea9f..7b9dc8a5ee 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -141,7 +141,7 @@ (provide s) (define-syntax (s stx) e))} @t{(require m) s} - @rx{module-lang-test-tmp2.ss:1:[67][90]: compile: bad syntax; + @rx{compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1$}) (test @t{(module tmp mzscheme @@ -247,11 +247,7 @@ f (f) -- - #t - #:error-ranges - (λ (defs ints) - (list (make-srcloc ints 3 3 107 1) - (make-srcloc ints 3 2 106 3)))) + #t) ;; test protection against user-code changing the namespace (test @t{#lang scheme/base @@ -265,7 +261,4 @@ (require "drscheme-test-util.ss") -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore 0))) \ No newline at end of file +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 874ddeed0e..c2dfb6d793 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -73,7 +73,7 @@ This produces an ACK message backtrace-image-string " " file-image-string - " ../../mred/private/snipfile.ss:")) + " .*mred/private/snipfile.ss:")) "[0-9]+:[0-9]+: " (regexp-quote str)))) @@ -190,8 +190,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -266,8 +266,8 @@ This produces an ACK message "define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+") 'interactions #f void @@ -305,8 +305,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -350,8 +350,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -417,8 +417,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") 'definitions #f void @@ -457,8 +457,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type ; given #" "expt: expected argument of type ; given #" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #") 'definitions #f void @@ -507,8 +507,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "1\n2\nreference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") 'definitions #f void @@ -620,8 +620,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f\n15" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type ; given #f\n15" "expt: expected argument of type ; given #f\n15" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15") 'definitions #f void @@ -644,12 +644,12 @@ This produces an ACK message ;; should produce a syntax object with a turn-down triangle. (mktest "(write (list (syntax x)))" - (#rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})") + (#rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})") 'interactions #f void @@ -685,12 +685,12 @@ This produces an ACK message (mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" - (#rx"#" - #rx"#" - #rx"#" - #rx"#" - #rx"#" - #rx"#") + (#rx"#" + #rx"#" + #rx"#" + #rx"#" + #rx"#" + #rx"#") 'interactions #f void @@ -719,8 +719,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type ; given #f" "expt: expected argument of type ; given #f" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f") 'definitions #f void @@ -796,8 +796,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3" "procedure application: expected procedure, given: 3; arguments were: 3" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3") 'definitions #f void @@ -898,8 +898,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -1069,7 +1069,8 @@ This produces an ACK message (define backtrace-image-string "{stop-multi.png}") (define file-image-string "{stop-22x22.png}") -(define tmp-load-directory +(define tmp-load-directory (find-system-path 'temp-dir) + #; (normal-case-path (normalize-path (collection-path "tests" "drscheme")))) @@ -1080,8 +1081,6 @@ This produces an ACK message (define tmp-load3-short-filename "repl-test-tmp3.ss") (define tmp-load3-filename (build-path tmp-load-directory tmp-load3-short-filename)) -tmp-load-filename - (define (cleanup-tmp-files) (when (file-exists? tmp-load-filename) (delete-file tmp-load-filename)) (when (file-exists? tmp-load3-filename) (delete-file tmp-load3-filename))) @@ -1515,13 +1514,10 @@ tmp-load-filename (string-append a b))) -(let () - (fire-up-drscheme) - (wait-for-drscheme-frame) ;; after this point, it is safe to set the exit handler - (exit-handler - (let ([eh (exit-handler)]) - (λ (val) - (cleanup-tmp-files) - (eh val)))) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore 0))) +(exit-handler + (let ([eh (exit-handler)]) + (λ (val) + (cleanup-tmp-files) + (eh val)))) + +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/run.sh b/collects/tests/drscheme/run.sh new file mode 100644 index 0000000000..1f8cefae07 --- /dev/null +++ b/collects/tests/drscheme/run.sh @@ -0,0 +1,7 @@ +#!/bin/sh -x +mred module-lang-test.ss && +mred repl-test.ss && +mred io.ss && +mred language-test.ss && +mred syncheck-test.ss && +mred teachpack.ss diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index 18a0555c03..82b016b909 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -849,28 +849,21 @@ trigger runtime errors in check syntax. (list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (define (main) - (let ([s (make-semaphore 0)]) - (thread - (λ () - (let ([drs (wait-for-drscheme-frame)]) - (set-language-level! (list "Pretty Big")) - (do-execute drs) - (let* ([defs (send drs get-definitions-text)] - [filename (make-temporary-file "syncheck-test~a")]) - (let-values ([(dir _1 _2) (split-path filename)]) - (send defs save-file filename) - (preferences:set 'framework:coloring-active #f) - (for-each (run-one-test (normalize-path dir)) tests) - (preferences:set 'framework:coloring-active #t) - (send defs save-file) ;; clear out autosave - (send defs set-filename #f) - (delete-file filename) - ;; let the app die. - (semaphore-post s)))))) - (fire-up-drscheme) - (yield s) - (printf "Tests complete.\n") - (exit))) + (fire-up-drscheme-and-run-tests + (λ () + (let ([drs (wait-for-drscheme-frame)]) + (set-language-level! (list "Pretty Big")) + (do-execute drs) + (let* ([defs (send drs get-definitions-text)] + [filename (make-temporary-file "syncheck-test~a")]) + (let-values ([(dir _1 _2) (split-path filename)]) + (send defs save-file filename) + (preferences:set 'framework:coloring-active #f) + (for-each (run-one-test (normalize-path dir)) tests) + (preferences:set 'framework:coloring-active #t) + (send defs save-file) ;; clear out autosave + (send defs set-filename #f) + (delete-file filename))))))) (define ((run-one-test save-dir) test) (let* ([drs (wait-for-drscheme-frame)] diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index 3e03dc5ff4..57417db162 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -238,7 +238,4 @@ ;(bad-tests) (test-built-in-teachpacks)) -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore))) +(fire-up-drscheme-and-run-tests run-test) From 2c602a08c444c852a7c72ccb751abde9e5d5f352 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 6 Feb 2010 19:05:35 +0000 Subject: [PATCH 27/27] svn: r18006 --- .../2htdp/tests/robby-optimization-gone.ss | 20 ------------------- 1 file changed, 20 deletions(-) delete mode 100644 collects/2htdp/tests/robby-optimization-gone.ss diff --git a/collects/2htdp/tests/robby-optimization-gone.ss b/collects/2htdp/tests/robby-optimization-gone.ss deleted file mode 100644 index 528df04b92..0000000000 --- a/collects/2htdp/tests/robby-optimization-gone.ss +++ /dev/null @@ -1,20 +0,0 @@ -#lang scheme/gui - -(require 2htdp/universe) -(require 2htdp/image) - -(define s "") -(define x 1) - -(big-bang 1 - (on-tick (lambda (w) - (begin - (set! x (+ x 1)) - (if (= x 3) 0 1)))) - (stop-when zero?) - (on-draw (lambda (w) - (begin - (set! s (string-append "-" s)) - (rectangle 1 1 'solid 'green))))) - -(unless (string=? s "---") (error 'world-update-test "failed! ~s" s))