diff --git a/collects/compiler/cm.ss b/collects/compiler/cm.ss index fda77af2bb..e489f2109e 100644 --- a/collects/compiler/cm.ss +++ b/collects/compiler/cm.ss @@ -107,10 +107,8 @@ [(< zo-sec ss-sec) (error 'compile-zo "date for newly created .zo file (~a @ ~a) ~ is before source-file date (~a @ ~a)~a" - zo-name - (format-time (seconds->date zo-sec)) - ss-name - (format-time (seconds->date ss-sec)) + zo-name (format-time zo-sec) + ss-name (format-time ss-sec) (if (> ss-sec (current-seconds)) ", which appears to be in the future" ""))])) diff --git a/collects/compiler/private/known.ss b/collects/compiler/private/known.ss index bd4b4eb526..de307b0b5d 100644 --- a/collects/compiler/private/known.ss +++ b/collects/compiler/private/known.ss @@ -2,7 +2,7 @@ ;; (c) 1996-1997 Sebastian Good ;; (c) 1997-2001 PLT -;; Sets the the real annotation for zodiac:binding AST nodes, +;; Sets the real annotation for zodiac:binding AST nodes, ;; setting the known? and known-val fields as possible. ;; Known-value analysis is used for constant propagation, but diff --git a/collects/compiler/private/rep.ss b/collects/compiler/private/rep.ss index 529e614c4f..6867da0b6f 100644 --- a/collects/compiler/private/rep.ss +++ b/collects/compiler/private/rep.ss @@ -1,4 +1,4 @@ -;; Representation choosing phase of the the compiler +;; Representation choosing phase of the compiler ;; (c) 1996-1997 Sebastian Good ;; (c) 1997-201 PLT diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 6a8dd409c9..8d5df632f8 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -1254,8 +1254,8 @@ TODO (thread (λ () - ;; forward system events the the user's logger, - ;; and record any events that happen on the user's logger to show in the GUI + ;; forward system events the user's logger, and record any + ;; events that happen on the user's logger to show in the GUI (let ([sys-evt (make-log-receiver drscheme:init:system-logger 'debug)] [user-evt (make-log-receiver user-logger 'debug)]) (let loop () diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt index f696e62cc2..f528ab78b6 100644 --- a/collects/embedded-gui/doc.txt +++ b/collects/embedded-gui/doc.txt @@ -93,8 +93,8 @@ Add the given alignment as a child after the existing child > (send an-alignment-parent delete-child child) -> void child : (is-a?/c alignment<%>) -Deletes a child from the the alignments - +Deletes a child from the alignments + > (send an-alignment-parent is-shown?) -> boolean? True if the alignment is being shown (accounting for its parent being shown) diff --git a/collects/embedded-gui/private/aligned-pasteboard.ss b/collects/embedded-gui/private/aligned-pasteboard.ss index 363b9d27fc..b742f88067 100644 --- a/collects/embedded-gui/private/aligned-pasteboard.ss +++ b/collects/embedded-gui/private/aligned-pasteboard.ss @@ -74,7 +74,7 @@ (set! alignment child)))) #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments (define/public (delete-child child) (if alignment (if (eq? child alignment) diff --git a/collects/embedded-gui/private/interface.ss b/collects/embedded-gui/private/interface.ss index cb41a94bb3..bbc1b498e6 100644 --- a/collects/embedded-gui/private/interface.ss +++ b/collects/embedded-gui/private/interface.ss @@ -66,7 +66,7 @@ add-child #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments delete-child #;(-> boolean?) diff --git a/collects/embedded-gui/private/verthoriz-alignment.ss b/collects/embedded-gui/private/verthoriz-alignment.ss index def03e2528..145c732229 100644 --- a/collects/embedded-gui/private/verthoriz-alignment.ss +++ b/collects/embedded-gui/private/verthoriz-alignment.ss @@ -137,7 +137,7 @@ (link (send tail prev) child tail)))) #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments (define/public (delete-child child) (send child show/hide false) (let ([p (send child prev)] diff --git a/collects/embedded-gui/scribblings/alignment-parent.scrbl b/collects/embedded-gui/scribblings/alignment-parent.scrbl index 4cbf614fcf..9e2d5ad103 100644 --- a/collects/embedded-gui/scribblings/alignment-parent.scrbl +++ b/collects/embedded-gui/scribblings/alignment-parent.scrbl @@ -13,7 +13,7 @@ Add the given alignment as a child after the existing child.} @defmethod[(delete-child [child (is-a?/c alignment<%>)]) void?]{ -Deletes a child from the the alignments.} +Deletes a child from the alignments.} @defmethod[(is-shown?) boolean?]{ diff --git a/collects/eopl/private/sllgen.ss b/collects/eopl/private/sllgen.ss index be0933b30a..f226548c9e 100644 --- a/collects/eopl/private/sllgen.ss +++ b/collects/eopl/private/sllgen.ss @@ -1442,7 +1442,7 @@ ;; make-symbol, make-number, and make-string are supported ;; alternates, but are deprecated. - ;; the classname becomes the the name of token. + ;; the classname becomes the name of token. ;; if multiple actions are possible, do the one that appears here ;; first. make-string is first, so literal strings trump identifiers. diff --git a/collects/ffi/magick.ss b/collects/ffi/magick.ss index 4a4f38e2e8..06de1cc501 100644 --- a/collects/ffi/magick.ss +++ b/collects/ffi/magick.ss @@ -1123,7 +1123,7 @@ (defmagick* MagickGetReleaseDate : -> _string) -;; MagickGetResourceLimit returns the the specified resource in megabytes. +;; MagickGetResourceLimit returns the specified resource in megabytes. (defmagick* MagickGetResourceLimit : _ResourceType -> _ulong) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index c85f5de883..3ef7215773 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -1428,7 +1428,7 @@ This function is not symmetric in red, green, and blue, so it is important to pass red, green, and blue components of the colors in - the the proper order. The first three arguments are red, green and + the proper order. The first three arguments are red, green and blue for the first color, respectively, and the second three arguments are red green and blue for the second color, respectively.}) diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss index 0671752af2..22a4e13cd2 100644 --- a/collects/framework/preferences.ss +++ b/collects/framework/preferences.ss @@ -355,7 +355,7 @@ the state transitions / contracts are: ((p f) ((weak? #f))) @{This function adds a callback which is called with a symbol naming a - preference and it's value, when the preference changes. + preference and its value, when the preference changes. @scheme[preferences:add-callback] returns a thunk, which when invoked, removes the callback from this preference. @@ -406,7 +406,7 @@ the state transitions / contracts are: preferences to turn the preference value for @scheme[symbol] into a printable value. @scheme[unmarshall] will be called when the user's preferences are read from the file to transform the printable value - into it's internal representation. If @scheme[preference:set-un/marshall] + into its internal representation. If @scheme[preference:set-un/marshall] is never called for a particular preference, the values of that preference are assumed to be printable. @@ -450,7 +450,7 @@ the state transitions / contracts are: (parameter/c (-> (listof symbol?) (listof any/c) any)) put-preference @{This parameter's value - is called when to save preference the preferences. Its interface should + is called to save preference the preferences. Its interface should be just like mzlib's @scheme[put-preference].}) (proc-doc/names @@ -477,7 +477,7 @@ the state transitions / contracts are: @{Caches all of the current values of the preferences and returns them. For any preference that has marshalling and unmarshalling set (see @scheme[preferences:set-un/marshall]), the preference value is - copied by passing it thru the marshalling and unmarshalling process. + copied by passing it through the marshalling and unmarshalling process. Other values are not copied, but references to them are instead saved. See also @scheme[preferences:restore-prefs-snapshot].})) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 391bf360b2..f2e48fd16a 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -382,7 +382,7 @@ WARNING: printf is rebound in the body of the unit to always (and (string? color) (send the-color-database find-color color))) (error 'highlight-range - "expected a color or a string in the the-color-database for the third argument, got ~e" color)) + "expected a color or a string in the-color-database for the third argument, got ~e" color)) (unless (memq style '(rectangle hollow-ellipse ellipse dot)) (error 'highlight-range "expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style)) diff --git a/collects/frtime/demos/analog-clock.ss b/collects/frtime/demos/analog-clock.ss index 5bc0369be8..25bd7e858b 100644 --- a/collects/frtime/demos/analog-clock.ss +++ b/collects/frtime/demos/analog-clock.ss @@ -106,7 +106,7 @@ (build-list 12 create-number))) ;; Define the hour hand of the clock. -;; The hour hand is based on the the-hour and the-minute in order to +;; The hour hand is based on the-hour and the-minute in order to ;; make it move smoothly around the clock. (define hour-hand (make-line clock-center diff --git a/collects/games/ginrummy/ginrummy.ss b/collects/games/ginrummy/ginrummy.ss index 94c80d4565..43ecb736fb 100644 --- a/collects/games/ginrummy/ginrummy.ss +++ b/collects/games/ginrummy/ginrummy.ss @@ -200,7 +200,7 @@ (3loop (cons (car group) pre) (list (cadr group) (caddr group) (car post)) (cdr post))))))]) - ;; Try the value-sorted list, the the suit-sorted list, then... + ;; Try the value-sorted list, the suit-sorted list, then... (max (find-set value-sorted) (find-set suit-sorted) ;; the suit-sorted list with with Aces at the end instead of the diff --git a/collects/graphics/scribblings/traditional-turtles.scrbl b/collects/graphics/scribblings/traditional-turtles.scrbl index 54442717c2..26d76687b5 100644 --- a/collects/graphics/scribblings/traditional-turtles.scrbl +++ b/collects/graphics/scribblings/traditional-turtles.scrbl @@ -47,6 +47,10 @@ Turns the turtle @scheme[theta] radians counter-clockwise.} Erases the turtles window.} +@defproc[(home) void?]{ + +Leaves only one turtle, in the start position.} + @defform[(split expr ...)]{ Spawns a new turtle where the turtle is currently located. In order to diff --git a/collects/graphics/turtle-sig.ss b/collects/graphics/turtle-sig.ss index 60feede3c3..b49e359269 100644 --- a/collects/graphics/turtle-sig.ss +++ b/collects/graphics/turtle-sig.ss @@ -1,7 +1,7 @@ #lang scheme/signature turtles -clear +clear home turn turn/radians move move-offset draw draw-offset diff --git a/collects/graphics/turtle-unit.ss b/collects/graphics/turtle-unit.ss index 82016f0475..94d813033e 100644 --- a/collects/graphics/turtle-unit.ss +++ b/collects/graphics/turtle-unit.ss @@ -227,6 +227,13 @@ (set! lines-in-drawing null) (clear-window))) +(define home + (lambda () + (flip-icons) + (set! turtles-cache empty-cache) + (set! turtles-state (list clear-turtle)) + (flip-icons))) + ;; cache elements: (define-struct c-forward (distance)) (define-struct c-turn (angle)) diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 6f68ba9964..758d3e7efe 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -341,7 +341,7 @@ This directory contains the following files and sub-directories: Multiple submissions for a particular user in different groups will be rejected. - Inactive assignment directories are used by the the HTTPS status web + Inactive assignment directories are used by the HTTPS status web server.} @item{@filepath{/checker.ss} (optional): a module diff --git a/collects/handin-server/scribblings/utils.scrbl b/collects/handin-server/scribblings/utils.scrbl index 58aed5c1a0..5913de293b 100644 --- a/collects/handin-server/scribblings/utils.scrbl +++ b/collects/handin-server/scribblings/utils.scrbl @@ -35,7 +35,7 @@ @scheme[make-evaluator], the @scheme[language] argument can be a list that begins with @scheme['module]. In this case, @scheme[make-module-language] is used to create an evaluator, and - the module code must be using the the specified language in its + the module code must be using the specified language in its language position. In this case, the @scheme[requires-paths] argument is used only for paths that are allowed to be accessed (the @scheme[_allow-read] argument to @scheme[make-evaluator], since the diff --git a/collects/lang/private/TODO b/collects/lang/private/TODO new file mode 100644 index 0000000000..7f7f0cfc8b --- /dev/null +++ b/collects/lang/private/TODO @@ -0,0 +1,41 @@ +If we eliminate char from HtDP/I, we need to add re-think the following +functions: + +integer->char -- 1string version + +char->integer -- 1string version + +string->list -- explode + +list->string -- implode + +char-numeric? -- in a sense string->number is enough + (number? (string->number s)) + +char-alphabetic? -- + (andmap (lambda (c) + (or (string<=? "A" x "Z") (string<=? "a" x "z"))) + (string->list s)) + +char-whitespace? -- (andmap char-whitespace? s) + +char-upper-case? -- (string<=? "A" x "Z") + +char-lower-case? -- (string<=? "a" x "z") + +char-upcase string-upcase + +char-downcase string-downcase + +make-string : Nat Char -> String + Nat String1 -> String + +string : Char ... -> String + delete, string-append is enough + +string-ref : String Nat -> Char + ith + +NOTE: +substring consumes 2 or 3 arguments + diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index 00b32bbeb2..13a4c7f8f9 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -98,7 +98,7 @@ destination snip's bounding box where a straight line between the centers of the snip would intersect. The @scheme[arrow-point-ok?] function returns @scheme[#t] -when the point specified by its arguments is inside the the +when the point specified by its arguments is inside the smallest rectangle that covers both the source and destination snips, but is outside of both of the rectangles that surround the source and destination snips themselves. diff --git a/collects/mrlib/scribblings/name-message.scrbl b/collects/mrlib/scribblings/name-message.scrbl index a63945bba8..9f7c790ccf 100644 --- a/collects/mrlib/scribblings/name-message.scrbl +++ b/collects/mrlib/scribblings/name-message.scrbl @@ -67,7 +67,7 @@ saying that there is no file name until the file is saved.} @defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{ The result of this method is used for the background color -when redrawing the the name message. If it is @scheme[#f], the +when redrawing the name message. If it is @scheme[#f], the OS's default panel background is used. } diff --git a/collects/mysterx/doc.txt b/collects/mysterx/doc.txt index 1f03606869..410d93352d 100644 --- a/collects/mysterx/doc.txt +++ b/collects/mysterx/doc.txt @@ -22,7 +22,7 @@ _MysterX_ Two Windows DLLs support low-level operations in MysterX: "myspage.dll" and "myssink.dll". Both are installed in the registry - (using `REGSVR32 ') when Setup PLT runs the the MysterX + (using `REGSVR32 ') when Setup PLT runs the MysterX post-installer. If you move the location of your PLT installation, you may need to re-run Setup PLT to make MysterX work. Neither of these DLLs is specific to a PLT Scheme version, so it's ok for one diff --git a/collects/mysterx/scribblings/overview.scrbl b/collects/mysterx/scribblings/overview.scrbl index 3e50282e93..13c74f70aa 100644 --- a/collects/mysterx/scribblings/overview.scrbl +++ b/collects/mysterx/scribblings/overview.scrbl @@ -13,7 +13,7 @@ Recent versions of Windows come with DCOM; DCOM packages for Windows Two Windows DLLs support low-level operations in MysterX: @filepath{myspage.dll} and @filepath{myssink.dll}. Both are installed in the registry (using @exec{regsvr32.exe}) when Setup PLT runs the -the MysterX post-installer. If you move the location of your PLT +MysterX post-installer. If you move the location of your PLT installation, you may need to re-run Setup PLT to make MysterX work. Neither of these DLLs is specific to a PLT Scheme version, so it's ok for one version of PLT Scheme to use the DLLs registered by diff --git a/collects/mzlib/process.ss b/collects/mzlib/process.ss index 21d246b83a..24775a39d0 100644 --- a/collects/mzlib/process.ss +++ b/collects/mzlib/process.ss @@ -71,7 +71,11 @@ (define (streamify-out cout out get-thread?) (if (and cout (not (file-stream-port? cout))) - (let ([t (thread (lambda () (copy-port out cout)))]) + (let ([t (thread (lambda () + (dynamic-wind + void + (lambda () (copy-port out cout)) + (lambda () (close-input-port out)))))]) (and get-thread? t)) out)) diff --git a/collects/openssl/mzssl.ss b/collects/openssl/mzssl.ss index 360be33d60..45ca03e2a9 100644 --- a/collects/openssl/mzssl.ss +++ b/collects/openssl/mzssl.ss @@ -648,7 +648,7 @@ (lambda (len non-block? enable-break?) (let ([out-blocked? (pump-output mzssl)]) (if (zero? len) - ;; Flush request; all data is in the the SSL + ;; Flush request; all data is in the SSL ;; stream, but make sure it's gone ;; through the ports: (begin diff --git a/collects/parser-tools/parser-tools.scrbl b/collects/parser-tools/parser-tools.scrbl index 86f1163c82..97486ed62d 100644 --- a/collects/parser-tools/parser-tools.scrbl +++ b/collects/parser-tools/parser-tools.scrbl @@ -272,7 +272,7 @@ error.} @defparam[file-path source any/c]{ - A parameter that the the lexer uses as the source location if it + A parameter that the lexer uses as the source location if it raises a @scheme[exn:fail:rad] error. Setting this parameter allows DrScheme, for example, to open the file containing the error.} diff --git a/collects/profile/sampler.ss b/collects/profile/sampler.ss index 692cb45ce9..7529135373 100644 --- a/collects/profile/sampler.ss +++ b/collects/profile/sampler.ss @@ -23,7 +23,7 @@ ;; start at 0, since threads are likely to run before a sample is ;; collected. ;; - Finally, the part is a snapshot of the thread's stack, as -;; grabbed by `continuation-mark-set->context'. The the values in these +;; grabbed by `continuation-mark-set->context'. The values in these ;; snapshots are interned to reduce memory load. ;; The results are collected sequentially, so they're always sorted from the ;; newest to the oldest. Remember that these results should be considered diff --git a/collects/profj/libs/java/lang/Boolean.java b/collects/profj/libs/java/lang/Boolean.java index 07c7d06766..63b9afc24f 100644 --- a/collects/profj/libs/java/lang/Boolean.java +++ b/collects/profj/libs/java/lang/Boolean.java @@ -145,7 +145,7 @@ public final class Boolean implements Serializable /** * Returns the Boolean TRUE if and only if the given - * String is equal, ignoring case, to the the String "true", otherwise + * String is equal, ignoring case, to the String "true", otherwise * it will return the Boolean FALSE. * * @param s the string to convert diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss index a2e9ea79c0..3cb88cbb92 100644 --- a/collects/r6rs/main.ss +++ b/collects/r6rs/main.ss @@ -9,7 +9,8 @@ FIXME: (require (for-syntax scheme/base syntax/kerncase "private/parse-ref.ss" - scheme/provide-transform)) + scheme/provide-transform) + "private/no-set.ss") (provide (rename-out [module-begin #%module-begin])) @@ -232,6 +233,12 @@ FIXME: orig ex)]))) exs) + (add-no-set!-identifiers (map (lambda (ex) + (syntax-case ex () + [(rename (id ex-id)) + #'id] + [id ex])) + exs)) (with-syntax ([((ex ...) ...) (map (lambda (ex) (syntax-case ex () diff --git a/collects/r6rs/private/identifier-syntax.ss b/collects/r6rs/private/identifier-syntax.ss index a84350f18a..dfc87c79e3 100644 --- a/collects/r6rs/private/identifier-syntax.ss +++ b/collects/r6rs/private/identifier-syntax.ss @@ -1,26 +1,27 @@ #lang scheme/base (require (for-syntax scheme/base) - (for-template (only-in scheme/base set! #%app))) + (for-template "no-set.ss" + (only-in scheme/base #%app set!))) (provide identifier-syntax) (define-syntax (identifier-syntax stx) - (syntax-case* stx (set!) (lambda (a b) - (free-template-identifier=? a b)) + (syntax-case* stx (r6rs:set!) (lambda (a b) + (free-template-identifier=? a b)) [(identifier-syntax template) #'(... (make-set!-transformer (lambda (stx) (syntax-case stx (set!) [(set! . _) (raise-syntax-error - #f - "cannot assign to identifier macro" - stx)] + #f + "cannot assign to identifier macro" + stx)] [(_ arg ...) #'(template arg ...)] [_ #'template]))))] [(identifier-syntax [id1 template1] - [(set! id2 pat) template2]) + [(r6rs:set! id2 pat) template2]) (and (identifier? #'id1) (identifier? #'id2)) #'(... diff --git a/collects/r6rs/private/no-set.ss b/collects/r6rs/private/no-set.ss new file mode 100644 index 0000000000..fe3b43b567 --- /dev/null +++ b/collects/r6rs/private/no-set.ss @@ -0,0 +1,33 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/boundmap)) + +(provide (for-syntax add-no-set!-identifiers) + r6rs:set!) + +;; Provided identifier cannot be `set!'ed. The list +;; is relevant only within the module being compiled. +(define-for-syntax no-set!-identifiers (make-free-identifier-mapping)) + +(define-for-syntax (add-no-set!-identifiers ids) + (for ([id (in-list ids)]) + (free-identifier-mapping-put! no-set!-identifiers id #t))) + +(define-for-syntax (no-set!-identifier? id) + (free-identifier-mapping-get no-set!-identifiers id (lambda () #f))) + +;; ---------------------------------------- + +(define-syntax (r6rs:set! stx) + (syntax-case stx () + [(_ id rhs) + (identifier? #'id) + (if (no-set!-identifier? #'id) + (raise-syntax-error + #f + "cannot mutate exported identifier" + stx + #'id) + (syntax/loc stx (set! id rhs)))] + [(_ . rest) + (syntax/loc stx (set! . rest))])) diff --git a/collects/r6rs/private/reconstruct.ss b/collects/r6rs/private/reconstruct.ss new file mode 100644 index 0000000000..95d3c9175f --- /dev/null +++ b/collects/r6rs/private/reconstruct.ss @@ -0,0 +1,4 @@ +#lang scheme/base + +(provide reconstruction-memory) +(define reconstruction-memory (make-weak-hasheq)) diff --git a/collects/redex/doc.txt b/collects/redex/doc.txt index dfab824865..34a310f375 100644 --- a/collects/redex/doc.txt +++ b/collects/redex/doc.txt @@ -540,7 +540,7 @@ c. This form extends the reduction relation in its first argument with the rules specified in . They should -have the same shape as the the rules (including the `with' +have the same shape as the rules (including the `with' clause) in an ordinary reduction-relation. If the original reduction-relation has a rule with the same diff --git a/collects/redex/pict.ss b/collects/redex/pict.ss index 10cc69a8ea..d5ebef2e4b 100644 --- a/collects/redex/pict.ss +++ b/collects/redex/pict.ss @@ -12,6 +12,7 @@ (symbols 'compact-vertical 'vertical 'vertical-overlapping-side-conditions + 'horizontal-left-align 'horizontal)) (provide reduction-rule-style/c) diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss index b6cb0df392..5125fb3686 100644 --- a/collects/redex/private/core-layout.ss +++ b/collects/redex/private/core-layout.ss @@ -75,16 +75,6 @@ (equal? (lw-e thing-in-hole) 'hole)) (list (blank) context (blank)) (list (blank) context "" "[" thing-in-hole "]"))))) - (in-named-hole ,(λ (args) - (let ([name (lw-e (list-ref args 2))] - [context (list-ref args 3)] - [thing-in-hole (list-ref args 4)]) - (if (and (lw? thing-in-hole) - (equal? (lw-e thing-in-hole) 'hole)) - (list (blank) context "[]" - (basic-text (format "~a" name) (non-terminal-subscript-style))) - (list (blank) context "" "[" thing-in-hole "]" - (basic-text (format "~a" name) (non-terminal-subscript-style))))))) (hide-hole ,(λ (args) (list (blank) (list-ref args 2) diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index 43d3e8edff..9a97ceac3a 100644 --- a/collects/redex/private/pict.ss +++ b/collects/redex/private/pict.ss @@ -127,7 +127,7 @@ (define current-label-extra-space (make-parameter 0)) (define reduction-relation-rule-separation (make-parameter 4)) -(define (rule-picts->pict/horizontal rps) +(define ((rule-picts->pict/horizontal left-column-align) rps) (let* ([sep 2] [max-rhs (apply max 0 @@ -160,8 +160,8 @@ (blank) sep (blank) (blank) (blank)))) rps)) - (list* rtl-superimpose ctl-superimpose ltl-superimpose) - (list* rtl-superimpose ctl-superimpose ltl-superimpose) + (list* left-column-align ctl-superimpose ltl-superimpose) + (list* left-column-align ctl-superimpose ltl-superimpose) (list* sep sep (+ sep (current-label-extra-space))) 2))) (define arrow-space (make-parameter 0)) @@ -326,7 +326,10 @@ [(compact-vertical) rule-picts->pict/compact-vertical] [(vertical-overlapping-side-conditions) rule-picts->pict/vertical-overlapping-side-conditions] - [else rule-picts->pict/horizontal])) + [(horizontal-left-align) + (rule-picts->pict/horizontal ltl-superimpose)] + [else ;; horizontal + (rule-picts->pict/horizontal rtl-superimpose)])) (define (mk-arrow-pict sz style) (let ([cache (make-hash)]) @@ -454,6 +457,7 @@ (let ([ps-setup (make-object ps-setup%)]) (send ps-setup copy-from (current-ps-setup)) (send ps-setup set-file filename) + (send ps-setup set-mode 'file) (parameterize ([current-ps-setup ps-setup]) (make-object post-script-dc% #f #f)))) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 7fdb50eb2c..4b4c450d90 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -453,12 +453,18 @@ (for-each loop nexts))))) all-top-levels) - (let ([name-ht (make-hasheq)] + (let ([name-table (make-hasheq)] [lang-nts (language-id-nts lang-id orig-name)]) + (hash-set! name-table #f 0) + ;; name table maps symbols for the rule names to their syntax objects and to a counter indicating what + ;; order the names were encountered in. The current value of the counter is stored in the table at key '#f'. (with-syntax ([lang-id lang-id] [(top-level ...) (get-choices stx orig-name ht lang-id main-arrow - name-ht lang-id allow-zero-rules?)] - [(rule-names ...) (hash-map name-ht (λ (k v) k))] + name-table lang-id allow-zero-rules?)] + [(rule-names ...) + (begin + (hash-remove! name-table #f) + (map car (sort (hash-map name-table (λ (k v) (list k (list-ref v 1)))) < #:key cadr)))] [lws lws] [domain-pattern-side-conditions-rewritten @@ -660,9 +666,11 @@ (raise-syntax-errors orig-name "same name on multiple rules" stx - (list (hash-ref name-table name-sym) + (list (car (hash-ref name-table name-sym)) (syntax name)))) - (hash-set! name-table name-sym (syntax name)) + (let ([num (hash-ref name-table #f)]) + (hash-set! name-table #f (+ num 1)) + (hash-set! name-table name-sym (list (syntax name) num))) (when the-name (raise-syntax-errors orig-name @@ -773,6 +781,7 @@ (define (union-reduction-relations fst snd . rst) (let ([name-ht (make-hasheq)] + [counter 0] [lst (list* fst snd rst)] [first-lang (reduction-relation-lang fst)]) (for-each @@ -783,14 +792,15 @@ (for-each (λ (name) (when (hash-ref name-ht name #f) (error 'union-reduction-relations "multiple rules with the name ~s" name)) - (hash-set! name-ht name #t)) + (hash-set! name-ht name counter) + (set! counter (+ counter 1))) (reduction-relation-rule-names red))) - lst) + (reverse lst)) ;; reverse here so the names get put into the hash in the proper (backwards) order (build-reduction-relation #f first-lang (reverse (apply append (map reduction-relation-make-procs lst))) - (hash-map name-ht (λ (k v) k)) + (map car (sort (hash-map name-ht list) < #:key cadr)) (apply append (map reduction-relation-lws lst)) `any))) @@ -1008,8 +1018,8 @@ (with-syntax ([(side-conditions-rewritten ...) (map (λ (x) (rewrite-side-conditions/check-errs lang-nts - #t 'define-metafunction + #t x)) (syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] [dom-side-conditions-rewritten @@ -1398,7 +1408,7 @@ (for-each (λ (name) (let ([x (syntax->datum name)]) - (when (memq x '(any number string variable natural integer real variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross ...)) + (when (memq x '(any number string variable natural integer real variable-except variable-prefix hole name in-hole hide-hole side-condition cross ...)) (raise-syntax-error 'language (format "cannot use pattern language keyword ~a as non-terminal" x) @@ -1772,10 +1782,7 @@ (equal? str1 (substring str2 0 (string-length str1))))) -;; The struct selector extracts the reduction relation rules, which -;; are in reverse order compared to the way the reduction relation was written -;; in the program text. So reverse them. -(define (reduction-relation->rule-names x) +(define (reduction-relation->rule-names x) (reverse (reduction-relation-rule-names x))) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index 58da06c255..2d41087d01 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -33,7 +33,7 @@ (define (expected-arguments name stx) (raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx)) (let loop ([term orig-stx]) - (syntax-case term (side-condition variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross) + (syntax-case term (side-condition variable-except variable-prefix hole name in-hole hide-hole side-condition cross) [(side-condition pre-pat (and)) ;; rewriting metafunctions (and possibly other things) that have no where, etc clauses ;; end up with side-conditions that are empty 'and' expressions, so we just toss them here. @@ -58,20 +58,15 @@ [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] [variable-prefix (expected-arguments 'variable-prefix term)] [hole term] - [(hole a) #`(hole #,(loop #'a))] - [(hole a ...) (raise-syntax-error what "hole expected to stand alone or to have one argument")] [(name x y) #`(name #,(loop #'x) #,(loop #'y))] [(name x ...) (expected-exact 'name 2 term)] [name (expected-arguments 'name term)] [(in-hole a b) #`(in-hole #,(loop #'a) #,(loop #'b))] [(in-hole a ...) (expected-exact 'in-hole 2 term)] [in-hole (expected-arguments 'in-hole term)] - [(in-named-hole a b c) #`(in-named-hole #,(loop #'a) #,(loop #'b) #,(loop #'c))] - [(in-named-hole a ...) (expected-exact 'in-named-hole 3 term)] - [in-named-hole (expected-arguments 'in-named-hole term)] [(hide-hole a) #`(hide-hole #,(loop #'a))] - [(in-named-hole a ...) (expected-exact 'hide-hole 1 term)] - [in-named-hole (expected-arguments 'hide-hole term)] + [(hide-hole a ...) (expected-exact 'hide-hole 1 term)] + [hide-hole (expected-arguments 'hide-hole term)] [(cross a) #`(cross #,(loop #'a))] [(cross a ...) (expected-exact 'cross 1 term)] [cross (expected-arguments 'cross term)] @@ -96,17 +91,12 @@ (let loop ([stx orig-stx] [names null] [depth 0]) - (syntax-case stx (name in-hole in-named-hole side-condition) + (syntax-case stx (name in-hole side-condition) [(name sym pat) (identifier? (syntax sym)) (loop (syntax pat) (cons (make-id/depth (syntax sym) depth) names) depth)] - [(in-named-hole hlnm sym pat1 pat2) - (identifier? (syntax sym)) - (loop (syntax pat1) - (loop (syntax pat2) names depth) - depth)] [(in-hole pat1 pat2) (loop (syntax pat1) (loop (syntax pat2) names depth) diff --git a/collects/redex/private/struct.ss b/collects/redex/private/struct.ss index 569a0c82d1..0627ffa9c3 100644 --- a/collects/redex/private/struct.ss +++ b/collects/redex/private/struct.ss @@ -82,8 +82,8 @@ make-procs/check-domain)]) (make-reduction-relation lang all-make-procs - (append (reduction-relation-rule-names orig-reduction-relation) - rule-names) + (append rule-names + (reduction-relation-rule-names orig-reduction-relation)) lws ;; only keep new lws for typesetting (map (λ (make-proc) (make-proc lang)) all-make-procs)))] [else diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index 20b7e03cbb..e739cc8f7c 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -34,7 +34,7 @@ (define (rewrite/has-term-let-bound-id? stx) (let loop ([stx stx] [depth 0]) - (syntax-case stx (unquote unquote-splicing in-hole in-named-hole hole) + (syntax-case stx (unquote unquote-splicing in-hole hole) [(metafunc-name arg ...) (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index a35495e14a..969de8825b 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -546,6 +546,20 @@ (test (term (f ((((x)))))) (term x))) + (let () + (define-language lamv + (z variable hole)) + + (define-metafunction lamv + foo : z -> any + [(foo hole) dontcare] + [(foo variable) docare]) + + (test (term (foo hole)) + (term dontcare)) + (test (term (foo y)) + (term docare))) + ;; test that tracing works properly ;; note that caching comes into play here (which is why we don't see the recursive calls) (let () @@ -1117,6 +1131,58 @@ (test (apply-reduction-relation red2 (term (X q))) (list (term (X z)) (term (X w))))) + (test (reduction-relation->rule-names + (reduction-relation + empty-language + (--> x y a))) + '(a)) + + (test (reduction-relation->rule-names + (reduction-relation + empty-language + (--> x y a) + (--> y z b) + (--> z w c))) + '(a b c)) + + (test (reduction-relation->rule-names + (reduction-relation + empty-language + (--> x y a) + (--> y z b) + (--> z w c) + (--> p q z) + (--> q r y) + (--> r p x))) + '(a b c z y x)) + + (test (reduction-relation->rule-names + (extend-reduction-relation + (reduction-relation + empty-language + (--> x y a) + (--> y z b) + (--> z w c)) + empty-language + (--> p q z) + (--> q r y) + (--> r p x))) + '(a b c z y x)) + + (test (reduction-relation->rule-names + (union-reduction-relations + (reduction-relation + empty-language + (--> x y a) + (--> y z b) + (--> z w c)) + (reduction-relation + empty-language + (--> p q z) + (--> q r y) + (--> r p x)))) + '(a b c z y x)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; examples from doc.txt diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 91fd81ad86..683503f318 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -8,7 +8,7 @@ scheme/pretty scheme/contract mrlib/graph - (only-in slideshow/pict pict? text dc-for-text-size) + (only-in slideshow/pict pict? text dc-for-text-size text-style/c) redex)) @(define-syntax (defpattech stx) @@ -778,7 +778,7 @@ where the @tt{==>} relation is defined by reducing in the context This form extends the reduction relation in its first argument with the rules specified in @scheme[more]. They should -have the same shape as the the rules (including the `with' +have the same shape as the rules (including the `with' clause) in an ordinary @scheme[reduction-relation]. If the original reduction-relation has a rule with the same @@ -887,9 +887,7 @@ The @scheme[define-metafunction] form builds a function on sexpressions according to the pattern and right-hand-side expressions. The first argument indicates the language used to resolve non-terminals in the pattern expressions. Each of -the rhs-expressions is implicitly wrapped in @|tttterm|. In -addition, recursive calls in the right-hand side of the -metafunction clauses should appear inside @|tttterm|. +the rhs-expressions is implicitly wrapped in @|tttterm|. If specified, the side-conditions are collected with @scheme[and] and used as guards on the case being matched. The @@ -1672,14 +1670,17 @@ multi-line right-hand sides. This parameter controls the style used by default for the reduction relation. It can be @scheme['horizontal], where the left and -right-hand sides of the reduction rule are beside each other -or @scheme['vertical], where the left and right-hand sides of the -reduction rule are above each other. -The @scheme['compact-vertical] style moves the reduction arrow -to the second line and uses less space between lines. -Finally, in the @scheme['vertical-overlapping-side-conditions] variant, the side-conditions don't contribute to -the width of the pict, but are just overlaid on the second -line of each rule. +right-hand sides of the reduction rule are beside each other or +@scheme['vertical], where the left and right-hand sides of the +reduction rule are above each other. The @scheme['compact-vertical] +style moves the reduction arrow to the second line and uses less space +between lines. The @scheme['vertical-overlapping-side-conditions] +variant, the side-conditions don't contribute to the width of the +pict, but are just overlaid on the second line of each rule. The +@scheme['horizontal-left-align] style is like the @scheme['horizontal] +style, but the left-hand sides of the rules are aligned on the left, +instead of on the right. + } @defthing[reduction-rule-style/c flat-contract?]{ diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 0c7b240f08..998af489ba 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -7,6 +7,8 @@ scheme/splicing r6rs/private/qq-gen r6rs/private/exns + r6rs/private/no-set + (for-syntax r6rs/private/reconstruct) (prefix-in r5rs: r5rs) (only-in r6rs/private/readtable rx:number) scheme/bool) @@ -27,7 +29,7 @@ (rename-out [r5rs:if if]) ;; 11.4.4 - set! + (rename-out [r6rs:set! set!]) ;; 11.4.5 cond else => case @@ -268,8 +270,8 @@ (lambda (stx) (if (identifier? stx) (syntax/loc stx r6rs-/) - (syntax-case stx (set!) - [(set! . _) + (syntax-case stx (r6rs:set!) + [(r6rs:set! . _) (raise-syntax-error #f "cannot mutate imported identifier" stx)] @@ -561,11 +563,14 @@ [(symbol? r) (error 'macro "transformer result included a raw symbol: ~e" r)] - [(mpair? r) (datum->syntax - stx - (cons (wrap (mcar r) stx) - (wrap (mcdr r) stx)) - stx)] + [(mpair? r) + (let ([istx (or (hash-ref reconstruction-memory r #f) + stx)]) + (datum->syntax + istx + (cons (wrap (mcar r) stx) + (wrap (mcdr r) stx)) + istx))] [(vector? r) (datum->syntax stx (list->vector diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index 6404d5bb5b..03eb0af3c6 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/collects/rnrs/syntax-case-6.ss @@ -2,10 +2,13 @@ (require (for-syntax scheme/base) r6rs/private/qq-gen + r6rs/private/reconstruct scheme/mpair r6rs/private/exns (for-syntax syntax/template - r6rs/private/check-pattern)) + r6rs/private/check-pattern) + (for-template (only-in scheme/base set!) + r6rs/private/no-set)) (provide make-variable-transformer (rename-out [r6rs:syntax-case syntax-case] @@ -104,7 +107,12 @@ l)]))))) (define (make-variable-transformer proc) - (make-set!-transformer proc)) + (make-set!-transformer + (lambda (stx) + (syntax-case* stx (set!) free-template-identifier=? + [(set! . rest) + (proc (syntax/loc stx (r6rs:set! . rest)))] + [else (proc stx)])))) (define unwrapped-tag (gensym)) @@ -179,6 +187,8 @@ ;; ---------------------------------------- (define (unwrap-reconstructed data stx datum) + (when (mpair? datum) + (hash-set! reconstruction-memory datum (datum->syntax stx 'memory stx))) datum) (define (unwrap-pvar data stx) @@ -187,7 +197,10 @@ (cond [(syntax? v) (if (eq? (syntax-source v) unwrapped-tag) - (loop (syntax-e v)) + (let ([r (loop (syntax-e v))]) + (when (mpair? r) + (hash-set! reconstruction-memory r (datum->syntax v 'memory v))) + r) v)] [(pair? v) (mcons (loop (car v)) (loop (cdr v)))] diff --git a/collects/scheme/function.ss b/collects/scheme/function.ss index ffe2962b95..d60c1a670d 100644 --- a/collects/scheme/function.ss +++ b/collects/scheme/function.ss @@ -1,6 +1,10 @@ #lang scheme/base -(provide negate curry curryr) +(provide const negate curry curryr) + +(define (const c) + (define (const . _) c) + (make-keyword-procedure const const)) (define (negate f) (unless (procedure? f) (raise-type-error 'negate "procedure" f)) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index cedd06621c..25820d9c9d 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -8,6 +8,8 @@ empty empty? + make-list + drop take split-at @@ -81,6 +83,12 @@ (define empty? (lambda (l) (null? l))) (define empty '()) +(define (make-list n x) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'make-list "non-negative exact integer" n)) + (let loop ([n n] [r '()]) + (if (zero? n) r (loop (sub1 n) (cons x r))))) + ;; internal use below (define (drop* list n) ; no error checking, returns #f if index is too large (if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n))))) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index cf8b4d4c83..38bbbed2db 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -1,5 +1,6 @@ #lang scheme/base (require (for-syntax scheme/base + scheme/list syntax/kerncase syntax/boundmap syntax/define @@ -312,7 +313,7 @@ [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) - (car def-ctxes))] + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) @@ -330,7 +331,7 @@ [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) - (car def-ctxes))] + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index bd3dc7565c..383e1426b6 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -151,12 +151,38 @@ (list last) (cons (f (car l)) (loop (cdr l)))))) + (define (check-fold name proc init l more) + (unless (procedure? proc) + (apply raise-type-error name "procedure" 0 proc init l more)) + (unless (list? l) + (apply raise-type-error name "list" 2 proc init l more)) + (if (null? more) + (unless (procedure-arity-includes? proc 2) + (raise-mismatch-error name "arity mismatch, does not accept 1 argument: " proc)) + (let ([len (length l)]) + (let loop ([more more][n 3]) + (unless (null? more) + (unless (list? (car more)) + (apply raise-type-error name "list" n proc init l more)) + (unless (= len (length (car more))) + (raise-mismatch-error name + "given list does not have the same size as the first list: " + (car more))) + (loop (cdr more) (add1 n)))) + (unless (procedure-arity-includes? proc (+ 2 (length more))) + (raise-mismatch-error name + (format "arity mismatch, does not accept ~a arguments: " + (add1 (length more))) + proc))))) + (define foldl (case-lambda [(f init l) + (check-fold 'foldl f init l null) (let loop ([init init] [l l]) (if (null? l) init (loop (f (car l) init) (cdr l))))] [(f init l . ls) + (check-fold 'foldl f init l ls) (let loop ([init init] [ls (cons l ls)]) (cond [(andmap pair? ls) (loop (apply f (mapadd car ls init)) (map cdr ls))] @@ -167,11 +193,13 @@ (define foldr (case-lambda [(f init l) + (check-fold 'foldr f init l null) (let loop ([init init] [l l]) (if (null? l) init (f (car l) (loop init (cdr l)))))] [(f init l . ls) + (check-fold 'foldr f init l ls) (let loop ([ls (cons l ls)]) (cond [(andmap pair? ls) (apply f (mapadd car ls (loop (map cdr ls))))] @@ -232,7 +260,7 @@ (define compose (case-lambda - [(f) (if (procedure? f) + [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))] [(f g) @@ -247,6 +275,7 @@ (call-with-values (lambda () (g a)) f)) (lambda args (call-with-values (lambda () (apply g args)) f)))))] + [() values] [(f . more) (if (procedure? f) (let ([m (apply compose more)]) diff --git a/collects/schemeunit/scribblings/philosophy.scrbl b/collects/schemeunit/scribblings/philosophy.scrbl index 7215fb2b98..9095c9039a 100644 --- a/collects/schemeunit/scribblings/philosophy.scrbl +++ b/collects/schemeunit/scribblings/philosophy.scrbl @@ -110,7 +110,7 @@ which is the ancestor of SchemeUnit and the most widely used frameworks in Java, .Net, Python, and Ruby, and many other languages. That this is insufficient for all users is apparent if one considers the proliferation of ``simpler'' -testing frameworks in Scheme such as SRFI-78, or the the +testing frameworks in Scheme such as SRFI-78, or the practice of beginner programmers. Unfortunately these simpler methods are inadequate for testing larger systems. To the best of my knowledge SchemeUnit is the only diff --git a/collects/scribble/reader.ss b/collects/scribble/reader.ss index 802fe119f6..fe4bf7ba57 100644 --- a/collects/scribble/reader.ss +++ b/collects/scribble/reader.ss @@ -213,13 +213,13 @@ ;; sorts things out (remove prefix and suffix newlines, adds indentation if ;; needed) (define (done-items xs) - ;; a column marker is either a non-negative integer N (saying the the - ;; following code came from at column N), or a negative integer -N (saying - ;; that the following code came from column N but no need to add - ;; indentation at this point because it is at the openning of a {...}); - ;; `get-lines*' is careful not to include column markers before a newline - ;; or the end of the text, and a -N marker can only come from the beginning - ;; of the text (and it's never there if the text began with a newline) + ;; a column marker is either a non-negative integer N (saying the following + ;; code came from at column N), or a negative integer -N (saying that the + ;; following code came from column N but no need to add indentation at this + ;; point because it is at the openning of a {...}); `get-lines*' is careful + ;; not to include column markers before a newline or the end of the text, + ;; and a -N marker can only come from the beginning of the text (and it's + ;; never there if the text began with a newline) (if (andmap eol-syntax? xs) ;; nothing to do (reverse xs) diff --git a/collects/scribblings/drscheme/prefs.scrbl b/collects/scribblings/drscheme/prefs.scrbl index 899b591e2f..745b7db824 100644 --- a/collects/scribblings/drscheme/prefs.scrbl +++ b/collects/scribblings/drscheme/prefs.scrbl @@ -123,7 +123,7 @@ The preferences dialog consists of several panels. window is below the definitions window.} @item{@PrefItem{Always show the #lang line in the Module language} -- - If checked, the module language always shows the the @hash-lang[] + If checked, the module language always shows the @hash-lang[] line (even when it would ordinarily be scrolled off of the page), assuming that the @hash-lang[] line is the first line in the file. } diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 04ab79bb71..1a0b3f3439 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -365,7 +365,7 @@ values: @itemize[ on to the original function, for example, have a binding for it. Note that each function can hold onto one callback value (it is stored in a weak hash table), so if you need to use a function in - multiple callbacks you will need to use one of the the last two + multiple callbacks you will need to use one of the last two options below. (This is the default, as it is fine in most cases.)} @item{@scheme[#f] means that the callback value is not held. This may diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index cece0eb29b..8dcb5ed6af 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -387,7 +387,7 @@ @method[text:searching<%> set-replace-start]) and the closest search hit following @tt{replace-start} does not collapse with an adjacent bubble,the result will include - that bubble. If the the closest search hit after + that bubble. If the closest search hit after @tt{replace-start} is collpased with another bubble, then the search hit is not reflected in the result. diff --git a/collects/scribblings/guide/contracts-structure.scrbl b/collects/scribblings/guide/contracts-structure.scrbl index 6f1e18a180..21a56763a3 100644 --- a/collects/scribblings/guide/contracts-structure.scrbl +++ b/collects/scribblings/guide/contracts-structure.scrbl @@ -135,7 +135,7 @@ check the fields of the data structure, but sometimes this can have disastrous effects on the performance of a program that does not, itself, inspect the entire data structure. -As an example, consider the the binary search tree +As an example, consider the binary search tree search algorithm. A binary search tree is like a binary tree, except that the numbers are organized in the tree to make searching the tree fast. In particular, for each diff --git a/collects/scribblings/guide/namespaces.scrbl b/collects/scribblings/guide/namespaces.scrbl index a8f5a360eb..0980215b66 100644 --- a/collects/scribblings/guide/namespaces.scrbl +++ b/collects/scribblings/guide/namespaces.scrbl @@ -376,7 +376,7 @@ scheme/base (dynamic-require file 'plug-in%)))) ] -The anchor bound by @scheme[namespace-attach-module] connects the the +The anchor bound by @scheme[namespace-attach-module] connects the run time of a module with the namespace in which a module is loaded (which might differ from the current namespace). In the above example, since the enclosing module requires diff --git a/collects/scribblings/guide/regexp.scrbl b/collects/scribblings/guide/regexp.scrbl index 0e9f650827..73c1ae13d6 100644 --- a/collects/scribblings/guide/regexp.scrbl +++ b/collects/scribblings/guide/regexp.scrbl @@ -532,7 +532,7 @@ is represented by @scheme[#f] @tech{Submatch}es can be used in the insert string argument of the procedures @scheme[regexp-replace] and @scheme[regexp-replace*]. The insert string can use @litchar{\}@math{n} as a @deftech{backreference} -to refer back to the @math{n}th submatch, which is the the substring +to refer back to the @math{n}th submatch, which is the substring that matched the @math{n}th subpattern. A @litchar{\0} refers to the entire match, and it can also be specified as @litchar{\&}. diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index e924f9b841..32a5231e30 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -65,7 +65,7 @@ If you've used DrScheme before with something other than a program that starts @hash-lang[], DrScheme will remember the last language that you used, instead of inferring the language from the @hash-lang[] line. In that case, use the @menuitem["Language" "Choose Language..."] -menu item. In the the dialog that appears, select the first item, +menu item. In the dialog that appears, select the first item, which is @onscreen{Module}. Put the @hash-lang[] line above in the top text area, still. diff --git a/collects/scribblings/inside/namespaces.scrbl b/collects/scribblings/inside/namespaces.scrbl index 33d0728a83..c97ba9a896 100644 --- a/collects/scribblings/inside/namespaces.scrbl +++ b/collects/scribblings/inside/namespaces.scrbl @@ -29,7 +29,7 @@ A @as-index{module}'s set of top-level bindings is implemented using the same machinery as a namespace. Use @cppi{scheme_primitive_module} to create a new @cpp{Scheme_Env*} that represents a primitive module. The name provided to @cppi{scheme_primitive_module} is subject -to prefixing through the @scheme[current-module-name-prefix] parameter +to change through the @scheme[current-module-declare-name] parameter (which is normally set by the module name resolver when auto-loading module files). After installing variables into the module with @cppi{scheme_add_global}, etc., call @@ -129,8 +129,8 @@ available as @cppi{scheme_config}.} [Scheme_Object* name] [Scheme_Env* for_env])]{ -Prepares a new primitive module whose name is the symbol @var{name} (plus any - prefix that is active via @scheme[current-module-name-prefix]). The +Prepares a new primitive module whose name is the symbol @var{name} (or an + alternative that is active via @scheme[current-module-declare-name]). The module will be declared within the namespace @var{for_env}. The result is a @cpp{Scheme_Env *} value that can be used with @cpp{scheme_add_global}, etc., but it represents a module instead diff --git a/collects/scribblings/inside/structures.scrbl b/collects/scribblings/inside/structures.scrbl index 7285b6391c..1d1924c8d5 100644 --- a/collects/scribblings/inside/structures.scrbl +++ b/collects/scribblings/inside/structures.scrbl @@ -15,7 +15,7 @@ type's name. Instances of a structure type are created with @cppi{scheme_struct_ref} and @cppi{scheme_struct_set} functions access or modify a field of a structure. -The the structure procedure values and names generated by +The structure procedure values and names generated by @cpp{scheme_make_struct_values} and @cpp{scheme_make_struct_names} can be restricted by passing any combination of these flags: diff --git a/collects/scribblings/inside/values.scrbl b/collects/scribblings/inside/values.scrbl index 77c40eb4e3..53f9ea7173 100644 --- a/collects/scribblings/inside/values.scrbl +++ b/collects/scribblings/inside/values.scrbl @@ -598,7 +598,7 @@ Finds (or creates) the symbol matching the given nul-terminated, ASCII [int len])]{ Creates or finds a symbol given the symbol's length in UTF-8-encoding - bytes. The the case of @var{name} is not normalized.} + bytes. The case of @var{name} is not normalized.} @function[(Scheme_Object* scheme_intern_exact_char_symbol [mzchar* name] @@ -625,7 +625,7 @@ Creates an uninterned symbol given the symbol's length in [int len])]{ Creates or finds a keyword given the keywords length in UTF-8-encoding - bytes. The the case of @var{name} is not normalized, and it should + bytes. The case of @var{name} is not normalized, and it should not include the leading hash and colon of the keyword's printed form.} @function[(Scheme_Object* scheme_intern_exact_char_keyword diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index a8f0075699..2117c1d273 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -87,7 +87,7 @@ for end users.} @defproc*[([(raise-type-error [name symbol?][expected string?][v any/c]) any] - [(raise-type-error [name symbol?][expected string?][bad-pos exact-nonnegative-integer?][v any/c]) any])]{ + [(raise-type-error [name symbol?][expected string?][bad-pos exact-nonnegative-integer?][v any/c] ...) any])]{ Creates an @scheme[exn:fail:contract] value and @scheme[raise]s it as an exception. The @scheme[name] argument is used as the source diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index 558864c586..3f95d386d0 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -184,7 +184,7 @@ Analogous to @scheme[call-with-input-file], but passing @scheme[path], [#:mode mode-flag (or/c 'binary 'text) 'binary]) any]{ Like @scheme[call-with-input-file], but the newly opened port is -closed whenever control escapes the the dynamic extent of the +closed whenever control escapes the dynamic extent of the @scheme[call-with-input-file*] call, whether through @scheme[proc]'s return, a continuation application, or a prompt-based abort.} @@ -195,7 +195,7 @@ return, a continuation application, or a prompt-based abort.} 'replace 'truncate 'truncate/replace) 'error]) any]{ Like @scheme[call-with-output-file], but the newly opened port is -closed whenever control escapes the the dynamic extent of the +closed whenever control escapes the dynamic extent of the @scheme[call-with-output-file*] call, whether through @scheme[proc]'s return, a continuation application, or a prompt-based abort.} diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 7534bf111b..81cf228d7b 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -152,7 +152,9 @@ paths. Parts of @scheme[str] that do not form a valid path are not included in the returned list.} -@defproc[(find-executable-path [program-sub path-string?][related-sub path-string?][deepest? any/c #f]) +@defproc[(find-executable-path [program-sub path-string?] + [related-sub (or/c path-string? #f) #f] + [deepest? any/c #f]) (or/c path? #f)]{ Finds a path for the executable @scheme[program-sub], returning diff --git a/collects/scribblings/reference/hashes.scrbl b/collects/scribblings/reference/hashes.scrbl index 75b3f9e023..f193ec32cb 100644 --- a/collects/scribblings/reference/hashes.scrbl +++ b/collects/scribblings/reference/hashes.scrbl @@ -23,7 +23,7 @@ via @scheme[equal?], @scheme[eqv?], or @scheme[eq?], and keys are retained either strongly or weakly (see @secref["weakbox"]). A hash table is also either mutable or immutable. Immutable tables support constant-time access and update, just like mutable hash tables; the -the constant on immutable operations is usually larger, but the +constant on immutable operations is usually larger, but the functional nature of immutable hash tables can pay off in certain algorithms. diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 407e75b6d4..57d412de56 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -63,7 +63,7 @@ Returns @scheme[#t] if @scheme[v] is a namespace-anchor value, @defproc[(namespace-anchor->empty-namespace [a namespace-anchor?]) namespace?]{ Returns an empty namespace that shares a @tech{module registry} with -the source of the anchor, and whose @tech{base phase} the the +the source of the anchor, and whose @tech{base phase} the @tech{phase} in which the anchor was created. If the anchor is from a @scheme[define-namespace-anchor] form in a @@ -369,13 +369,13 @@ result is the namespace in which the referenced variable is defined.} @defproc[(variable-reference->resolved-module-path [varref variable-reference?]) - resolved-module-path?]{ + (or/c resolved-module-path? #f)]{ If @scheme[varref] refers to a @tech{module-level variable}, the result is a @tech{resolved module path} naming the module. If @scheme[varref] refers to a @tech{top-level variable}, then the -@exnraise[exn:fail:contract].} +result is @scheme[#f].} @defproc[(variable-reference->phase [varref variable-reference?]) exact-nonnegative-integer?]{ diff --git a/collects/scribblings/reference/package.scrbl b/collects/scribblings/reference/package.scrbl index fc966df479..9b56433a6c 100644 --- a/collects/scribblings/reference/package.scrbl +++ b/collects/scribblings/reference/package.scrbl @@ -41,7 +41,7 @@ expressions within the body (and, in particular, the definitions can refer to each other). However, @scheme[define-package] handles @scheme[define*], @scheme[define*-syntax], @scheme[define*-values], @scheme[define*-syntaxes], and -@scheme[open*-syntaxes] specially: the bindings introduced by those +@scheme[open*-package] specially: the bindings introduced by those forms within a @scheme[define-package] body are visible only to @scheme[form]s that appear later in the body, and they can shadow any binding from preceding @scheme[form]s (even if the preceding binding diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index cc60d0af62..14c990dc76 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -513,6 +513,12 @@ Like @scheme[assoc], but finds an element using the predicate @defproc[(last-pair [p pair?]) pair?]{ Returns the last pair of a (possibly improper) list.} +@defproc[(make-list [k exact-nonnegative-integer?] [v any?]) list?]{ +Returns a newly constructed list of length @scheme[k], holding +@scheme[v] in all positions. + +@mz-examples[(make-list 7 'foo)]} + @defproc[(take [lst any/c] [pos exact-nonnegative-integer?]) list?]{ Returns a fresh list whose elements are the first @scheme[pos] elements of @scheme[lst]. If @scheme[lst] has fewer than diff --git a/collects/scribblings/reference/printer.scrbl b/collects/scribblings/reference/printer.scrbl index 7604be6ab6..5998ed15b4 100644 --- a/collects/scribblings/reference/printer.scrbl +++ b/collects/scribblings/reference/printer.scrbl @@ -208,12 +208,12 @@ unreadable values. @section[#:tag "print-hashtable"]{Printing Hash Tables} When the @scheme[print-hash-table] parameter is set to @scheme[#t], a -hash table prints starting with @litchar{#hash(} or @litchar{#hasheq(} -for a table using @scheme[equal?] or @scheme[eq?] key comparisons, +hash table prints starting with @litchar{#hash(}, @litchar{#hasheqv(}, or @litchar{#hasheq(} +for a table using @scheme[equal?], @scheme[eqv?], or @scheme[eq?] key comparisons, respectively. After this prefix, each key--value mapping is shown as @litchar{(}, the printed form of a key, a space, @litchar{.}, a space, the printed form the corresponding value, and @litchar{)}, with an -addition space if the key--value pairs is not the last to be printed. +additional space if the key--value pair is not the last to be printed. After all key-value pairs, the printed form completes with @litchar{)}. diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index e062acab2d..c3fa23d127 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -38,7 +38,8 @@ Returns a procedure that composes the given functions, applying the last @scheme[proc] first and the first @scheme[proc] last. The composed functions can consume and produce any number of values, as long as each function produces as many values as the preceding -function consumes. +function consumes. When no @scheme[proc] arguments are given, the +result is @scheme[values]. @mz-examples[ ((compose - sqrt) 10) @@ -422,6 +423,15 @@ applied.} @(define fun-eval (make-base-eval)) @(interaction-eval #:eval fun-eval (require scheme/function)) +@defproc[(const [v any]) procedure?]{ + +Returns a procedure that accepts any arguments and returns @scheme[v]. + +@mz-examples[#:eval fun-eval +((const 'foo) 1 2 3) +((const 'foo)) +]} + @defproc[(negate [proc procedure?]) procedure?]{ Returns a procedure that is just like @scheme[proc], except that it diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index d469fb5f94..38b111385e 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -566,7 +566,7 @@ is charged back to the sandbox, you should remove references to such values when the code is done inspecting it. This policy has an impact on how the sandbox memory limit interacts -with the the per-expression limit specified by +with the per-expression limit specified by @scheme[sandbox-eval-limits]: values that are reachable from the sandbox, as well as from the interaction will count against the sandbox limit. For example, in the last interaction of this code, diff --git a/collects/scribblings/reference/stx-certs.scrbl b/collects/scribblings/reference/stx-certs.scrbl index 2b551a6dbe..245c6a15a0 100644 --- a/collects/scribblings/reference/stx-certs.scrbl +++ b/collects/scribblings/reference/stx-certs.scrbl @@ -77,7 +77,7 @@ shape and properties of the result: ] -The the expander attaches a new active certificate to a syntax object, +The expander attaches a new active certificate to a syntax object, it also removes any @tech{inactive certificates} attached to any @tech{syntax object} within the one where the certificate is attached, and it re-attaches the formerly @tech{inactive certificates} as diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 7d5c629922..35285cca25 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -2046,13 +2046,13 @@ classifications: @itemize[ @item{@scheme[define] or @scheme[define-values] form: converted to - a @scheme[define-for-syntax] form.} + a @scheme[define-values-for-syntax] form.} @item{@scheme[require] form: content is wrapped with @scheme[for-syntax].} @item{expression form @scheme[_expr]: converted to - @scheme[(define-values () (begin _expr (values)))], which + @scheme[(define-values-for-syntax () (begin _expr (values)))], which effectively evaluates the expression at expansion time and, in the case of a @tech{module context}, preserves the expression for future @tech{visit}s of the module.} diff --git a/collects/scribblings/reference/vectors.scrbl b/collects/scribblings/reference/vectors.scrbl index 34fe5a94f2..a107186c8a 100644 --- a/collects/scribblings/reference/vectors.scrbl +++ b/collects/scribblings/reference/vectors.scrbl @@ -10,7 +10,7 @@ and update of the vector slots, which are numbered from @scheme[0] to one less than the number of slots in the vector. Two vectors are @scheme[equal?] if they have the same length, and if -the values in corresponding slots of the the vectors are +the values in corresponding slots of the vectors are @scheme[equal?]. A vector can be @defterm{mutable} or @defterm{immutable}. When an diff --git a/collects/scribblings/reference/windows-paths.scrbl b/collects/scribblings/reference/windows-paths.scrbl index f6225d7bb9..8619433a05 100644 --- a/collects/scribblings/reference/windows-paths.scrbl +++ b/collects/scribblings/reference/windows-paths.scrbl @@ -276,7 +276,7 @@ part of the result or on any @litchar{\\?\REL\} or @litchar{\\?\RED\} or @scheme[_sub-path]. If a @litchar{\\?\REL\} or @litchar{\\?\RED\} @scheme[_sub-path] is added to a non-@litchar{\\?\} -@scheme[_base-path], the the @scheme[_base-path] (with any additions up +@scheme[_base-path], the @scheme[_base-path] (with any additions up to the @litchar{\\?\REL\} or @litchar{\\?\RED\} @scheme[_sub-path]) is simplified and converted to a @litchar{\\?\} path. In other cases, a @litchar{\} may be diff --git a/collects/scribblings/scribble/eval.scrbl b/collects/scribblings/scribble/eval.scrbl index 31231965a5..c0a55a42af 100644 --- a/collects/scribblings/scribble/eval.scrbl +++ b/collects/scribblings/scribble/eval.scrbl @@ -61,7 +61,7 @@ Combines @scheme[schememod] and @scheme[interaction-eval].} @defform*[[(def+int defn-datum expr-datum ...) (def+int #:eval eval-expr defn-datum expr-datum ...)]]{ -Like @scheme[interaction], except the the @scheme[defn-datum] is +Like @scheme[interaction], except the @scheme[defn-datum] is typeset as for @scheme[schemeblock] (i.e., no prompt) and a line of space is inserted before the @scheme[expr-datum]s.} diff --git a/collects/srfi/1/cons.ss b/collects/srfi/1/cons.ss index 21ff7097ea..45230fb774 100644 --- a/collects/srfi/1/cons.ss +++ b/collects/srfi/1/cons.ss @@ -34,12 +34,12 @@ #lang scheme/base -(require srfi/optional "selector.ss") +(require srfi/optional "selector.ss" (only-in scheme/list make-list)) (provide xcons make-list list-tabulate - cons* + (rename-out [list* cons*]) list-copy circular-list iota) @@ -50,9 +50,10 @@ ;; Make a list of length LEN. -(define (make-list len [elt #f]) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list) - (for/list ([i (in-range len)]) elt)) +;; reprovided from mzscheme +;; (define (make-list len [elt #f]) +;; (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list) +;; (for/list ([i (in-range len)]) elt)) ;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. @@ -66,7 +67,7 @@ ;; ;; (cons first (unfold not-pair? car cdr rest values)) -(define cons* list*) ; same in mzscheme +;; reprovided as mzscheme's list* ;; (define (cons* first . rest) ;; (let recur ((x first) (rest rest)) ;; (if (pair? rest) diff --git a/collects/srfi/26/cut.ss b/collects/srfi/26/cut.ss index d208ede0e0..762f367d06 100644 --- a/collects/srfi/26/cut.ss +++ b/collects/srfi/26/cut.ss @@ -71,7 +71,7 @@ #`(lambda (x #,@slot-names) (x #,@(datum->syntax stx names-or-exprs)))))] [(cut proc slot-or-expr ... <...>) - ;; Applying a wrong number of arguments to the the lamba generated by cut, will provoke an + ;; Applying a wrong number of arguments to the lamba generated by cut, will provoke an ;; error caused by the application (proc ...). The quasisyntax/loc makes sure DrScheme ;; shows the cut-expression as the source of the error in stead of the showing an error in ;; the code implementing the macro i.e. in this code. diff --git a/collects/srfi/42/extra-generators.scm b/collects/srfi/42/extra-generators.scm index 888fe66947..dc20e41abb 100644 --- a/collects/srfi/42/extra-generators.scm +++ b/collects/srfi/42/extra-generators.scm @@ -191,7 +191,7 @@ ; (list-ec (:do ((x 0)) (<= x 5) ((+ x 1))) x) ; => '(0 1 2 3 4 5) - ; If only the the termination test were done *after* and + ; If only the termination test were done *after* and ; not before the loop payload ... This leads to the ; idea of an :do-until. diff --git a/collects/stxclass/scribblings/syntax-classes.scrbl b/collects/stxclass/scribblings/syntax-classes.scrbl index b304379bc9..de9339887b 100644 --- a/collects/stxclass/scribblings/syntax-classes.scrbl +++ b/collects/stxclass/scribblings/syntax-classes.scrbl @@ -172,7 +172,7 @@ name, an ellipsis depth, and a set of nested attributes. When an instance of the syntax class is parsed and bound to a pattern variable, additional pattern variables are bound for each of the syntax class's attributes. The name of these additional pattern -variables is the dotted concatenation of the the primary pattern +variables is the dotted concatenation of the primary pattern variable with the name of the attribute. For example, if pattern variable @scheme[p] is bound to an instance of diff --git a/collects/tests/mred/canvas-steps.txt b/collects/tests/mred/canvas-steps.txt index 3b5a5a3e0a..c77366424b 100644 --- a/collects/tests/mred/canvas-steps.txt +++ b/collects/tests/mred/canvas-steps.txt @@ -128,7 +128,7 @@ Move all scrolls to 1 step beyond the smallest setting. Check "swap". Now, the top canvas is managed and the bottom canvas is unmanaged. But the top canvas's area is so small that its scrollbars are always disabled. (It may also be clipped to the tiny 10x10 box.) - The bottom canvas's scrollbars should now act the the top ones used + The bottom canvas's scrollbars should now act the top ones used to: there are 20 steps in each direction and the `V:' and `H:' values change as the scrolls are moved. diff --git a/collects/tests/mred/draw-info.txt b/collects/tests/mred/draw-info.txt index 382d223fb8..59297dc814 100644 --- a/collects/tests/mred/draw-info.txt +++ b/collects/tests/mred/draw-info.txt @@ -38,7 +38,7 @@ The drawing area should have the following features: pattern; the third shape should be a semi-circle with no outline on the bottom edge. - Further right (to the the right of the columns) should appear an + Further right (to the right of the columns) should appear an X, a cross, and an narrow X tilted NW. Each should be drawn in green (5 pixels wide) with a thin black line centered along each green line. Scaling the picture should make the green line thicker, @@ -208,7 +208,7 @@ Clipping should slip the drawing to a particular shape: wedge - pi/4 to 3pi/4 of circle - round rectangle - a rounded rect inscribed in the the blue box for + round rectangle - a rounded rect inscribed in the blue box for testing stipples unions, intersects, subtracts - hopefully obvious diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss index 8f60fd65c7..07e3f65b9a 100644 --- a/collects/tests/mzscheme/function.ss +++ b/collects/tests/mzscheme/function.ss @@ -14,6 +14,7 @@ (test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2)))) (test 'ok (compose (lambda () 'ok) (lambda () (values)))) (test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5) +(test 0 (compose) 0) (test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1))) (err/rt-test (compose 5)) @@ -24,7 +25,7 @@ (err/rt-test ((compose add1 sub1)) exn:application:arity?) (err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?) -(arity-test compose 1 -1) +(arity-test compose 0 -1) ;; ---------- rec (from mzlib/etc) ---------- (let () @@ -42,6 +43,12 @@ (test 'f object-name (rec f (lambda (x) x))) (test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3)) +;; ---------- const ---------- +(let () + (test 'foo (const 'foo)) + (test 'foo (const 'foo) 1) + (test 'foo (const 'foo) 1 2 3 4 5)) + ;; ---------- negate ---------- (let () (define *not (negate not)) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index ca1d8877db..891bdf4348 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -21,6 +21,23 @@ (arity-test foldl 3 -1) (arity-test foldr 3 -1) +(err/rt-test (foldl 'list 0 10)) +(err/rt-test (foldl list 0 10)) +(err/rt-test (foldl add1 0 '())) +(err/rt-test (foldl cons 0 '() '())) +(err/rt-test (foldl list 0 '() 10)) +(err/rt-test (foldl list 0 '() '() 10)) +(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2 3)))) +(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2) '(1 2 3)))) +(err/rt-test (foldr 'list 0 10)) +(err/rt-test (foldr list 0 10)) +(err/rt-test (foldr add1 0 '())) +(err/rt-test (foldr cons 0 '() '())) +(err/rt-test (foldr list 0 '() 10)) +(err/rt-test (foldr list 0 '() '() 10)) +(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2 3)))) +(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2) '(1 2 3)))) + (test '(0 1 2) memf add1 '(0 1 2)) (test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17))) (test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c)) @@ -145,6 +162,13 @@ (test '(1 2 3 4) sort '(4 2 3 1) < #:key getkey #:cache-keys? #t) (test #t = c 10))) +;; ---------- make-list ---------- +(let () + (test '() make-list 0 'x) + (test '(x) make-list 1 'x) + (test '(x x) make-list 2 'x) + (err/rt-test (make-list -3 'x))) + ;; ---------- take/drop[-right] ---------- (let () (define-syntax-rule (vals-list expr) diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index 246784e200..b907652e5e 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -150,6 +150,27 @@ (open-package p) x) +(test-pack-seq + 14 + (define-package p (z) + (define* x (lambda () y)) + (define z x) + (define* x 2) + (define y 14)) + (open-package p) + (z)) + +(test-pack-seq + 21 + (define-package p (x) + (define* x (lambda () y)) + (define* x2 0) + (define* x3 1) + (define* x4 1) + (define y 21)) + (open-package p) + (x)) + (test-pack-seq '(2 1) (define-package p (x y) diff --git a/collects/tests/mzscheme/subprocess.ss b/collects/tests/mzscheme/subprocess.ss index 432becf5f0..247b0e18e3 100644 --- a/collects/tests/mzscheme/subprocess.ss +++ b/collects/tests/mzscheme/subprocess.ss @@ -48,7 +48,7 @@ ;; Supply file for stdout -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([p (process*/ports f #f #f cat)]) (test #f car p) @@ -67,7 +67,7 @@ ;; Supply file for stdout & stderr, only stdout writes -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([p (process*/ports f #f f cat)]) (test #f car p) (test #f cadddr p) @@ -84,7 +84,7 @@ ;; Supply file for stderr -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([p (process*/ports #f #f f cat "nosuchfile")]) (test #f cadddr p) @@ -104,7 +104,7 @@ ;; Supply file for stdout & stderr, only stderr writes -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([p (process*/ports f #f f cat "nosuchfile")]) (test #f car p) (test #f cadddr p) @@ -121,7 +121,7 @@ ;; Supply file for stdout & stderr, both write -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([p (process*/ports f #f f cat "-" "nosuchfile")]) (test #f car p) (test #f cadddr p) @@ -141,8 +141,8 @@ ;; Supply separate files for stdout & stderr -(let ([f (open-output-file tmpfile 'truncate/replace)] - [f2 (open-output-file tmpfile2 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)] + [f2 (open-output-file tmpfile2 #:exists 'truncate/replace)]) (let ([p (process*/ports f #f f2 cat "-" "nosuchfile")]) (test #f car p) (test #f cadddr p) @@ -168,7 +168,7 @@ ;; Supply file for stdin -(let ([f (open-output-file tmpfile 'truncate/replace)]) +(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (fprintf f "Howdy~n") (close-output-port f)) (let ([f (open-input-file tmpfile)]) @@ -187,7 +187,7 @@ ;; Files for everyone (let ([f (open-input-file tmpfile)] - [f2 (open-output-file tmpfile2 'truncate/replace)]) + [f2 (open-output-file tmpfile2 #:exists 'truncate/replace)]) (let ([p (process*/ports f2 f f2 cat "-" "nosuchfile")]) (test #f car p) (test #f cadr p) @@ -227,7 +227,7 @@ ;; Check error cases (let ([f (open-input-file tmpfile)] - [f2 (open-output-file tmpfile2 'truncate/replace)]) + [f2 (open-output-file tmpfile2 #:exists 'truncate/replace)]) (let ([test (lambda (o i e) @@ -245,16 +245,17 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-values (r w id e f) - (apply values (process* self "-mvq" + (apply values (process* self "-e" "(let loop () (unless (eof-object? (eval (read))) (loop)))"))) (define (test-line out in) (fprintf w "~a~n" in) + (flush-output w) (when out (test out (lambda (ignored) (read-line r)) in))) -(test-line "17" "(display 17) (newline)") +(test-line "17" "(display 17) (newline) (flush-output)") (close-input-port r) (close-input-port e) diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt index 2c3f38f7c8..a30438baab 100644 --- a/collects/texpict/doc.txt +++ b/collects/texpict/doc.txt @@ -1004,7 +1004,7 @@ Creates a balloon, much like `wrap-balloon' except that the balloon's width is `w' and its height is `h'. The `corner-radius' argument specifies the radius for the balloon's rounded corners; if the radius is positive, the value is used as the radius of the rounded corner, -but if radius is negative, the absolute value is used as the the +but if radius is negative, the absolute value is used as the proportion of the smallest dimension of the balloon. > (make-balloon pict num num) -> balloon diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 3449b25978..116f09476a 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -467,7 +467,7 @@ Other improvements: ("robby" "redex.plt" 1 3) - - Fixed a bug in the the compatible closure function; otherwise the + - Fixed a bug in the compatible closure function; otherwise the same as 1.1 ("robby" "redex.plt" 1 2) diff --git a/doc/srfi-std/srfi-14.html b/doc/srfi-std/srfi-14.html index 6a046de52f..4167ab3d65 100644 --- a/doc/srfi-std/srfi-14.html +++ b/doc/srfi-std/srfi-14.html @@ -1274,7 +1274,7 @@ ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.html

for further description of the file's format. Note in particular the -two-letter category specified in the the third field, which is referenced +two-letter category specified in the third field, which is referenced frequently in the descriptions below. diff --git a/doc/srfi-std/srfi-35.html b/doc/srfi-std/srfi-35.html index 7e2964690e..de261a8b17 100644 --- a/doc/srfi-std/srfi-35.html +++ b/doc/srfi-std/srfi-35.html @@ -145,7 +145,7 @@ returns a condition of condition type condition-type is a compound condition, extract-condition extracts the field values from the subcondition belonging to condition-type that appeared first in the call to make-compound-condition - that created the the condition. The returned condition may be newly created; it is possible for

(let* ((&c (make-condition-type 'c &condition '()))
+ that created the condition. The returned condition may be newly created; it is possible for
(let* ((&c (make-condition-type 'c &condition '()))
        (c0 (make-condition &c))
        (c1 (make-compound-condition c0)))
   (eq? c0 (extract-condition c1 &c)))
diff --git a/doc/srfi-std/srfi-43.html b/doc/srfi-std/srfi-43.html
index af42c0c436..55e02c1876 100644
--- a/doc/srfi-std/srfi-43.html
+++ b/doc/srfi-std/srfi-43.html
@@ -389,7 +389,7 @@ You can access the discussion via vector->list,
         but the resulting list contains the elements in reverse between
-        the the specified range.
+        the specified range.
         

         

       
diff --git a/doc/srfi-std/srfi-69.html b/doc/srfi-std/srfi-69.html
index b93e00c9cd..91ad15374c 100644
--- a/doc/srfi-std/srfi-69.html
+++ b/doc/srfi-std/srfi-69.html
@@ -107,7 +107,7 @@ tables so that portable programs can be written that make efficient use
 of common hash table functionality.  The SRFI resolves discrepancies
 that exist between the various hash table API's with respect to naming
 and semantics of hash table operations.  A lot of effort has been put
-into making the the API consistent, simple and generic.  The SRFI also
+into making the API consistent, simple and generic.  The SRFI also
 defines some of the most common utility routines that would otherwise
 need to be written and rewritten for various applications.
 
diff --git a/src/README b/src/README
index ce46ce9bb6..dc9b3bb970 100644
--- a/src/README
+++ b/src/README
@@ -61,6 +61,13 @@ the Unix instructions below, but note the following:
  Compiling for supported Unix variants (including Linux) or Cygwin
 ========================================================================
 
+Quick instructions:
+
+ The usual `./configure', `make', and `make install' sequence
+ typically works fine.
+
+Detailed instructions:
+
  0. If you have an old PLT installation in the target directory,
     remove it (unless you are using Subversion with an "in-place"
     build as described below).
@@ -80,7 +87,7 @@ the Unix instructions below, but note the following:
     try using GNU `make'.
 
  1. Run the script `configure' (which is in the same directory as this
-    README), usually with a --prefix=TARGETDIR command-line argument
+    README), possibly with a --prefix=TARGETDIR command-line argument
     and optionally with --enable-shared.
 
     For example, if you want to install into /usr/local/plt using
@@ -92,6 +99,23 @@ the Unix instructions below, but note the following:
     script (possibly unnecessary, or possibly just "./", depending on
     your shell and PATH setting).
 
+    It's better to run the build in a directory other than the one
+    contianing `configure', especially if you're getting sources via
+    Subversion.  Also, `svn update' ignores a subdirectory next to
+    `configure' called "build", so a better and more common way to
+    configure a Subversion-based build is as follows:
+
+        cd [here]
+        mkdir build
+        cd build
+        ../configure
+
+    A separate build directory is better in case the Makefile
+    organization changes, or in case the Makefiles lack some
+    dependencies. In those cases, when using a "build" subdirectory,
+    you can just delete and re-create "build" without mangling your
+    source tree.
+
     If the --prefix flag is omitted, the binaries are built for an
     in-place installation (i.e., the parent of the directory
     containing this README will be used directly). Unless
@@ -106,8 +130,8 @@ the Unix instructions below, but note the following:
     executables (independent of --prefix). This build directory does
     not have to be in the source tree, even for an "in-place"
     build. It's ok to run `configure' from its own directory (as in
-    the example above), but it's often better to pick a separate build
-    directory that is otherwise empty.
+    the first example above), but it's better to pick a separate build
+    directory that is otherwise empty (as in the second example).
 
     The `configure' script accepts many other flags that adjust the
     build process. Run `configure --help' for more information. In
@@ -219,8 +243,8 @@ but it will not work properly unless --enable-pthread is specified.
 
 MzScheme and MrEd have two variants: CGC and 3m. The CGC variant is
 older, and it cooperates more easily with extensions written in C.
-The 3m variant is now the default, and it usually provides better
-overall performance.
+The 3m variant is the default, and it usually provides better overall
+performance.
 
 The default build mode creates 3m binaries only. To create CGC
 binaries in addition, run `make cgc' in addition to `make', or run
@@ -245,10 +269,10 @@ case the first path is the main "collects" path, and additional paths
 are placed before the main path (but after a user-specific "collects"
 path) in the default collection path list.
 
-The paths are embedded in the binary immediately after a "coLLECTs
-dIRECTORy:" tag. Each path must be NUL terminated, the entire list of
-paths must end with an additional NUL terminator, and the overall list
-must be less than 1024 bytes long.
+The paths are embedded in the binary immediately after a special
+"coLLECTs dIRECTORy:" tag. Each path must be NUL terminated, the
+entire list of paths must end with an additional NUL terminator, and
+the overall list must be less than 1024 bytes long.
 
 As an alternative to editing an exeuctable directly, the
 `create-embedding-executable' procedure from `compiler/embed' can be
diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx
index b975326b7b..8c50f739fa 100644
--- a/src/mred/mred.cxx
+++ b/src/mred/mred.cxx
@@ -2276,32 +2276,35 @@ static void MrEdSchemeMessages(char *msg, ...)
   if (!console_out) {
     AllocConsole();
     console_out = GetStdHandle(STD_OUTPUT_HANDLE);
-    console_in = GetStdHandle(STD_INPUT_HANDLE);
-    has_stdio = 1;
-    waiting_sema = CreateSemaphore(NULL, 0, 1, NULL);
-    SetConsoleCtrlHandler(ConsoleHandler, TRUE);
+
+    if (!wx_in_terminal) {
+      console_in = GetStdHandle(STD_INPUT_HANDLE);
+      has_stdio = 1;
+      waiting_sema = CreateSemaphore(NULL, 0, 1, NULL);
+      SetConsoleCtrlHandler(ConsoleHandler, TRUE);
+
+      wxREGGLOB(console_inport);
+      console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0);
+
+      {
+	HMODULE hm;
+	gcw_proc gcw;
+
+	hm = LoadLibrary("kernel32.dll");
+	if (hm)
+	  gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow");
+	else
+	  gcw = NULL;
     
-    wxREGGLOB(console_inport);
-    console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0);
+	if (gcw)
+	  console_hwnd = gcw();
+      }
 
-    {
-      HMODULE hm;
-      gcw_proc gcw;
-
-      hm = LoadLibrary("kernel32.dll");
-      if (hm)
-	gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow");
-      else
-	gcw = NULL;
-    
-      if (gcw)
-	console_hwnd = gcw();
-    }
-
-    if (console_hwnd) {
-      EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE,
-		     MF_BYCOMMAND | MF_GRAYED);
-      RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND);
+      if (console_hwnd) {
+	EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE,
+		       MF_BYCOMMAND | MF_GRAYED);
+	RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND);
+      }
     }
   }
 #endif
diff --git a/src/mred/mredmsw.cxx b/src/mred/mredmsw.cxx
index a6e3ccb121..ced6628ef2 100644
--- a/src/mred/mredmsw.cxx
+++ b/src/mred/mredmsw.cxx
@@ -44,9 +44,6 @@ extern "C" {
   void scheme_forget_thread(struct Scheme_Thread_Memory *);
 };
 
-static int found_nothing;
-static DWORD max_sleep_time;
-
 static volatile int need_quit;
 
 extern void wxDoPreGM(void);
@@ -183,7 +180,6 @@ static BOOL CALLBACK CheckWindow(HWND wnd, LPARAM param)
                     info->remove ? PM_REMOVE : PM_NOREMOVE)) {
       info->wnd = wnd;
       info->c_return = c;
-      found_nothing = 0;
       return FALSE;
     }
   }
@@ -219,7 +215,6 @@ int FindReady(MrEdContext *c, MSG *msg, int remove, MrEdContext **c_return)
   {
     MSG pmsg;
     while (PeekMessage(&pmsg, NULL, 0x4000, 0xFFFF, PM_REMOVE)) {
-      found_nothing = 0;
       wxTranslateMessage(&pmsg);
       DispatchMessage(&pmsg);
     }
@@ -847,75 +842,14 @@ int MrEdCheckForBreak(void)
 
 void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep)
 {
-  DWORD msecs;
-
   if (fds && ((win_extended_fd_set *)fds)->no_sleep)
     return;
 
   if (wxCheckMousePosition())
     return;
 
-  /* If the event queue is empty (as reported by GetQueueStatus),
-     everything's ok.
-
-     Otherwise, we have trouble sleeping until an event is ready. We
-     sometimes leave events on th queue because, say, an eventspace is
-     not ready. The problem is that MsgWait... only unbocks when a new
-     event appears. Since we check the queue using a seuqence of
-     PeekMessages, it's possible that an event is added during the
-     middle of our sequence, but doesn't get handled.
-
-     We try to avoid this problem by going through the sequence
-     twice. But that still doesn't always work. For the general case,
-     then, we don't actually sleep indefinitely. Instead, we slep 10
-     ms, then 20 ms, etc. This exponential backoff ensures that we
-     eventually handle a pending event, but we don't spin and eat CPU
-     cycles. */
-
-  if (GetQueueStatus(QS_ALLINPUT)) {
-    /* Maybe the events are new since we last checked, or maybe
-       they're not going to be dispatched until something else
-       unblocks. Go into exponential-back-off mode. */
-    if (found_nothing) {
-      /* Ok, we gone around at least once. */
-      if (max_sleep_time < 0x20000000)
-	max_sleep_time *= 2;
-    } else {
-      /* Starting back-off mode */
-      found_nothing = 1;
-      max_sleep_time = 10;
-      return;
-    }
-  } else {
-    /* Disable back-off mode */
-    found_nothing = 0;
-    max_sleep_time = 0;
-  }
-
-  if (secs > 0) {
-    if (secs > 100000)
-      msecs = 100000000;
-    else
-      msecs = (DWORD)(secs * 1000);
-    if (max_sleep_time && (msecs > max_sleep_time))
-      msecs = max_sleep_time;
-  } else {
-    if (max_sleep_time) {
-      msecs = max_sleep_time;
-      /* Avoid infinite sleep: */
-      secs = 1.0;
-    } else
-      msecs = 0;
-  }
-
-  if (fds) {
-    scheme_add_fd_eventmask(fds, QS_ALLINPUT);
-    mzsleep(secs, fds);
-  } else if (wxTheApp->keep_going) {
-    MsgWaitForMultipleObjects(0, NULL, FALSE,
-			      secs ? msecs : INFINITE,
-			      QS_ALLINPUT);
-  }
+  scheme_add_fd_eventmask(fds, QS_ALLINPUT);
+  mzsleep(secs, fds);
 }
 
 void wxQueueLeaveEvent(void *ctx, wxWindow *wnd, int x, int y, int flags)
diff --git a/src/mzscheme/gc/configure.host b/src/mzscheme/gc/configure.host
index a98a0a7cb3..04526cfdf8 100644
--- a/src/mzscheme/gc/configure.host
+++ b/src/mzscheme/gc/configure.host
@@ -2,7 +2,7 @@
 
 # This shell script handles all host based configuration for the garbage
 # collector.
-# It sets various shell variables based on the the host and the
+# It sets various shell variables based on the host and the
 # configuration options.  You can modify this shell script without
 # needing to rerun autoconf.
 
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index e48ae4f104..1bca08a509 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -4381,6 +4381,9 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env, *senv;
   Scheme_Object *c, *rib;
+  void **d;
+
+  d = MALLOC_N(void*, 3);
 
   env = scheme_current_thread->current_local_env;
   if (!env)
@@ -4389,19 +4392,21 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
   if (argc && SCHEME_TRUEP(argv[0])) {
     if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[0])))
       scheme_wrong_type("syntax-local-bind-syntaxes", "internal-definition context or #f", 0, argc, argv);
-    senv = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[0]);
+    senv = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[0]))[0];
     if (!scheme_is_sub_env(senv, env)) {
       scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-make-definition-context: transforming context does "
                        "not match given internal-definition context");
     }
     env = senv;
+    d[1] = argv[0];
   }
+  d[0] = env;
 
   rib = scheme_make_rename_rib();
 
   c = scheme_alloc_object();
   c->type = scheme_intdef_context_type;
-  SCHEME_PTR1_VAL(c) = env;
+  SCHEME_PTR1_VAL(c) = d;
   SCHEME_PTR2_VAL(c) = rib;
 
   return c;
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 1115e4c34b..65811c5675 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -6339,6 +6339,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
    before deciding what we have. */
 {
   Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms;
+  void **d;
   Scheme_Comp_Env *xenv = NULL;
   Scheme_Compile_Info recs[2];
   DupCheckRecord r;
@@ -6364,7 +6365,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
   rib = scheme_make_rename_rib();
   ctx = scheme_alloc_object();
   ctx->type = scheme_intdef_context_type;
-  SCHEME_PTR1_VAL(ctx) = env;
+  d = MALLOC_N(void*, 3);
+  d[0] = env;
+  SCHEME_PTR1_VAL(ctx) = d;
   SCHEME_PTR2_VAL(ctx) = rib;
   ectx = scheme_make_pair(ctx, scheme_null);
   scheme_begin_dup_symbol_check(&r, env);
@@ -6561,7 +6564,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  }
 
 	  /* Remember extended environment */
-	  SCHEME_PTR1_VAL(ctx) = new_env;
+	  ((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env;
 	  env = new_env;
 	  xenv = NULL;
 	}
@@ -9292,6 +9295,31 @@ static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *rena
   return l;
 }
 
+static void update_intdef_chain(Scheme_Object *intdef)
+{
+  Scheme_Comp_Env *orig, *current_next;
+  Scheme_Object *base;
+
+  /* If this intdef chains to another, and if the other has been
+     extended, then fix up the chain. */
+
+  while (1) {
+    base = (Scheme_Object *)((void **)SCHEME_PTR1_VAL(intdef))[1];
+    if (base) {
+      current_next = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(base))[0];
+      orig = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[2];
+      if (orig) {
+        orig->next = current_next;
+      } else {
+        ((void **)SCHEME_PTR1_VAL(base))[0] = current_next;
+      }
+      intdef = base;
+    } else {
+      break;
+    }
+  }
+}
+
 static Scheme_Object *
 do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
 {
@@ -9337,7 +9365,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     if (SCHEME_TRUEP(argv[3])) {
       if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) {
 	Scheme_Comp_Env *stx_env;
-	stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[3]);
+        update_intdef_chain(argv[3]);
+	stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0];
 	renaming = SCHEME_PTR2_VAL(argv[3]);
 	if (!scheme_is_sub_env(stx_env, env))
 	  bad_sub_env = 1;
@@ -9347,7 +9376,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
         while (SCHEME_PAIRP(rl)) {
           if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) {
             Scheme_Comp_Env *stx_env;
-            stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
+            stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
             if (!scheme_is_sub_env(stx_env, env))
               bad_sub_env = 1;
           } else
@@ -9358,7 +9387,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
           bad_intdef = 1;
         else {
           rl = argv[3];
-          env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
+          update_intdef_chain(SCHEME_CAR(rl));
+          env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
           if (SCHEME_NULLP(SCHEME_CDR(rl)))
             renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
           else {
@@ -9837,7 +9867,7 @@ local_eval(int argc, Scheme_Object **argv)
     cnt++;
   }
   if (!SCHEME_NULLP(l))
-    scheme_wrong_type("syntax-local-bind-syntaxes", "list of syntax identifieres", 0, argc, argv);
+    scheme_wrong_type("syntax-local-bind-syntaxes", "list of syntax identifiers", 0, argc, argv);
 
   expr = argv[1];
   if (!SCHEME_FALSEP(expr) && !SCHEME_STXP(expr))
@@ -9849,7 +9879,8 @@ local_eval(int argc, Scheme_Object **argv)
   if (!env)
     scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: not currently transforming");
 
-  stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
+  update_intdef_chain(argv[2]);
+  stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0];
   rib = SCHEME_PTR2_VAL(argv[2]);
 
   if (*scheme_stx_get_rib_sealed(rib)) {
@@ -9909,7 +9940,9 @@ local_eval(int argc, Scheme_Object **argv)
   scheme_add_env_renames(rib, stx_env, old_stx_env);
 
   /* Remember extended environment */
-  SCHEME_PTR1_VAL(argv[2]) = stx_env;
+  ((void **)SCHEME_PTR1_VAL(argv[2]))[0] = stx_env;
+  if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2])
+    ((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env;
 
   return scheme_void;
 }
diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c
index eb89a167fd..8366023788 100644
--- a/src/mzscheme/src/port.c
+++ b/src/mzscheme/src/port.c
@@ -925,6 +925,35 @@ void scheme_add_fd_eventmask(void *fds, int mask)
 #endif
 }
 
+#if defined(WIN32_FD_HANDLES)
+void WSAEventSelect_plus_check(SOCKET s, WSAEVENT e, long mask)
+{
+  fd_set rd[1], wr[1], ex[1];
+  struct timeval t = {0, 0};
+
+  WSAEventSelect(s, e, mask);
+  
+  /* double-check with select(), because WSAEventSelect only
+     handles new activity (I think) */
+  FD_ZERO(rd);
+  FD_ZERO(wr);
+  FD_ZERO(ex);
+
+  if (mask & FD_READ)
+    FD_SET(s, rd);
+  if (mask & FD_WRITE)
+    FD_SET(s, wr);
+  if (mask & FD_OOB)
+    FD_SET(s, ex);
+
+  if (select(1, rd, wr, ex, &t)) {
+    /* already ready */
+    WSAEventSelect(s, NULL, 0);
+    SetEvent(e);
+  }
+}
+#endif
+
 void scheme_collapse_win_fd(void *fds)
 {
 #if defined(WIN32_FD_HANDLES)
@@ -980,7 +1009,7 @@ void scheme_collapse_win_fd(void *fds)
     for (i = SCHEME_INT_VAL(rfd->added); i--; ) {
       s = rfd->sockets[i];
       if (s != INVALID_SOCKET) {
-	mask = FD_READ | FD_ACCEPT | FD_CONNECT | FD_CLOSE;
+	mask = FD_READ | FD_ACCEPT | FD_CLOSE;
 	
 	for (j = SCHEME_INT_VAL(wfd->added); j--; ) {
 	  if (wfd->sockets[j] == s) {
@@ -998,7 +1027,7 @@ void scheme_collapse_win_fd(void *fds)
 
 	e = WSACreateEvent();
 	wa[p++] = e;
-	WSAEventSelect(s, e, mask);
+	WSAEventSelect_plus_check(s, e, mask);
       }
     }
 
@@ -1024,7 +1053,7 @@ void scheme_collapse_win_fd(void *fds)
 	  
 	  e = WSACreateEvent();
 	  wa[p++] = e;
-	  WSAEventSelect(s, e, mask);
+	  WSAEventSelect_plus_check(s, e, mask);
 	}
       }
     }
@@ -1052,7 +1081,7 @@ void scheme_collapse_win_fd(void *fds)
 	  if (mask) {
 	    e = WSACreateEvent();
 	    wa[p++] = e;
-	    WSAEventSelect(s, e, mask);
+	    WSAEventSelect_plus_check(s, e, mask);
 	  }
 	}
       }
@@ -8015,6 +8044,7 @@ void scheme_release_file_descriptor(void)
 /****************** Windows cleanup  *****************/
 
 #if defined(WIN32_FD_HANDLES)
+
 static void clean_up_wait(long result, OS_SEMAPHORE_TYPE *array,
 			  int *rps, int count)
 {
@@ -8027,6 +8057,21 @@ static void clean_up_wait(long result, OS_SEMAPHORE_TYPE *array,
   /* Clear out break semaphore */
   WaitForSingleObject(scheme_break_semaphore, 0);
 }
+
+static int made_progress;
+static DWORD max_sleep_time;
+
+void scheme_notify_sleep_progres()
+{
+  made_progress = 1;
+}
+
+#else
+
+void scheme_notify_sleep_progres()
+{
+}
+
 #endif
 
 /******************** Main sleep function  *****************/
@@ -8177,21 +8222,58 @@ static void default_sleep(float v, void *fds)
       break_sema = scheme_break_semaphore;
       array[count++] = break_sema;
 
-      /* Wait for HANDLE-based input: */
-      /* Extensions may handle events */
+      /* Extensions may handle events.
+	 If the event queue is empty (as reported by GetQueueStatus),
+	 everything's ok.
+
+	 Otherwise, we have trouble sleeping until an event is ready. We
+	 sometimes leave events on th queue because, say, an eventspace is
+	 not ready. The problem is that MsgWait... only unblocks when a new
+	 event appears. Since extensions may check the queue using a sequence of
+	 PeekMessages, it's possible that an event is added during the
+	 middle of the sequence, but doesn't get handled.
+
+	 To avoid this problem, we don't actually sleep indefinitely if an event
+	 is pending. Instead, we slep 10 ms, then 20 ms, etc. This exponential 
+	 backoff ensures that we eventually handle a pending event, but we don't 
+	 spin and eat CPU cycles. The back-off is reset whenever a thread makes
+	 progress. */
+
+
       if (SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask)
-	  && GetQueueStatus(SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask)))
-	result = WAIT_TIMEOUT; /* doesn't matter... */
-      else {
+	  && GetQueueStatus(SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask))) {
+	if (!made_progress) {
+	  /* Ok, we've gone around at least once. */
+	  if (max_sleep_time < 0x20000000)
+	    max_sleep_time *= 2;
+	} else {
+	  /* Starting back-off mode */
+	  made_progress = 0;
+	  max_sleep_time = 5;
+	}
+      } else {
+	/* Disable back-off mode */
+	made_progress = 1;
+	max_sleep_time = 0;
+      }
+
+      /* Wait for HANDLE-based input: */
+      {
 	DWORD msec;
 	if (v) {
 	  if (v > 100000)
 	    msec = 100000000;
 	  else
 	    msec = (DWORD)(v * 1000);
+	  if (max_sleep_time && (msec > max_sleep_time))
+	    msec = max_sleep_time;
 	} else {
-	  msec = INFINITE;
+	  if (max_sleep_time)
+	    msec = max_sleep_time;
+	  else
+	    msec = INFINITE;
 	}
+
 	result = MsgWaitForMultipleObjects(count, array, FALSE, msec,
 					   SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask));
       }
diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c
index 6ea1585bbf..a0e2b0d549 100644
--- a/src/mzscheme/src/read.c
+++ b/src/mzscheme/src/read.c
@@ -5289,7 +5289,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
 			 top->prefix->num_stxes,
 			 top->prefix->num_lifts,
                          0);
-    /* If no exception, the the resulting code is ok. */
+    /* If no exception, the resulting code is ok. */
   } else
     scheme_ill_formed_code(rp);
 
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index 12a075b35b..9829897c7a 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -118,6 +118,7 @@ extern void *scheme_gmp_tls_load(long *s);
 extern void scheme_gmp_tls_unload(long *s, void *p);
 extern void scheme_gmp_tls_snapshot(long *s, long *save);
 extern void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free);
+extern void scheme_notify_sleep_progres();
 
 static void check_ready_break();
 
@@ -3491,17 +3492,21 @@ static int check_sleep(int need_activity, int sleep_now)
   
   p2 = scheme_first_thread;
   while (p2) {
-    p2->ran_some = 0;
+    if (p2->ran_some) {
+      scheme_notify_sleep_progres();
+      p2->ran_some = 0;
+    }
     p2 = p2->next;
   }
   
   end_with_act = thread_ended_with_activity;
   thread_ended_with_activity = 0;
   
-  if (need_activity && !end_with_act && 
-      (do_atomic 
-       || (!p && ((!sleep_now && scheme_wakeup_on_input)
-		  || (sleep_now && scheme_sleep))))) {
+  if (need_activity 
+      && !end_with_act 
+      && (do_atomic 
+	  || (!p && ((!sleep_now && scheme_wakeup_on_input)
+		     || (sleep_now && scheme_sleep))))) {
     double max_sleep_time = 0;
 
     /* Poll from top-level process, and all subprocesses are blocked. */
diff --git a/src/wxxt/src/Utilities/Home.cc b/src/wxxt/src/Utilities/Home.cc
index 5004f213f6..8ba766afd4 100644
--- a/src/wxxt/src/Utilities/Home.cc
+++ b/src/wxxt/src/Utilities/Home.cc
@@ -44,7 +44,7 @@ char *wxGetUserHome(const char *user)
 	|| (ptr = getenv("LOGNAME")) != NULL) {
 	    who = getpwnam(ptr);
 	}
-	// We now make sure the the user exists!
+	// We now make sure the user exists!
 	if (who == NULL)
 	    who = getpwuid(getuid());
     } else
diff --git a/src/wxxt/src/Windows/RadioBox.cc b/src/wxxt/src/Windows/RadioBox.cc
index 6525ef942c..6daea4bb15 100644
--- a/src/wxxt/src/Windows/RadioBox.cc
+++ b/src/wxxt/src/Windows/RadioBox.cc
@@ -132,7 +132,7 @@ Bool wxRadioBox::Create(wxPanel *panel, wxFunction func, char *label,
     else
       XtRealizeWidget(wgt);
     X->frame = wgt;
-    // create group widget, which holds the the toggles
+    // create group widget, which holds the toggles
     wgt = XtVaCreateManagedWidget("radiobox", xfwfGroupWidgetClass, X->frame,
 				  XtNselectionStyle, (style & wxAT_MOST_ONE) ?
 				  XfwfSingleSelection : XfwfOneSelection,
@@ -263,7 +263,7 @@ Bool wxRadioBox::Create(wxPanel *panel, wxFunction func, char *label,
       XtRealizeWidget(wgt);
     X->frame = wgt;
 
-    // create group widget, which holds the the toggles
+    // create group widget, which holds the toggles
     wgt = XtVaCreateManagedWidget("radiobox", xfwfGroupWidgetClass, X->frame,
 				  XtNselectionStyle, (style & wxAT_MOST_ONE) ?
 				  XfwfSingleSelection : XfwfOneSelection,
diff --git a/src/wxxt/src/Windows/Window.cc b/src/wxxt/src/Windows/Window.cc
index 259a9ce0dd..ecfef4f77d 100644
--- a/src/wxxt/src/Windows/Window.cc
+++ b/src/wxxt/src/Windows/Window.cc
@@ -1019,7 +1019,7 @@ _XFUNCPROTOEND
 // I've used the following way to intercept the incomming events:
 // - first Xt calls the expose method of the widget
 // - second it calls all event handlers installed by XtAddEventHandler
-// - third it evaluates the the widget's translation table
+// - third it evaluates the widget's translation table
 // --> I forbid the evaluation of the translation table and call
 // 	_XtTranslateEvent by myself. 
 //
diff --git a/src/wxxt/src/XWidgets/xwScrollWin.w b/src/wxxt/src/XWidgets/xwScrollWin.w
index 076f53f974..6abf9d069a 100644
--- a/src/wxxt/src/XWidgets/xwScrollWin.w
+++ b/src/wxxt/src/XWidgets/xwScrollWin.w
@@ -28,7 +28,7 @@ is invoked {\em after} the CW is moved.
 
 	@var highlightThickness = 0
 
-@ Decide, if the the scrolled window should be included in the
+@ Decide, if the scrolled window should be included in the
 keyboard traversal.
 
 	@var Boolean traverseToChild = TRUE