sync to trunk

svn: r14711

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
+                                  zo-name (format-time zo-sec)
-                                  (format-time (seconds->date zo-sec))
+                                  ss-name (format-time ss-sec)
-                                  ss-name
-                                  (format-time (seconds->date ss-sec))
                                   (if (> ss-sec (current-seconds))
                                     ", which appears to be in the future"
                                     ""))]))

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

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
 

collects/drscheme/private/rep.ss

@@ -1254,8 +1254,8 @@ TODO
                  
                  (thread
                   (λ ()
-                    ;; forward system events the the user's logger,
+                    ;; forward system events the user's logger, and record any
-                    ;; and record any events that happen on the user's logger to show in the GUI
+                    ;; 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 ()

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)

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)

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?)

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)]

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?]{
 

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.

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)
 

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.})

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].}))

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))

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

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

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

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

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))

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{<active-assignment>/checker.ss} (optional): a module

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

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 
+

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.

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.
 
 }

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 <name-of-DLL>') when Setup PLT runs the the MysterX
+ (using `REGSVR32 <name-of-DLL>') 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

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

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))
 

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

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.}
 

collects/profile/sampler.ss

@@ -23,7 +23,7 @@
 ;;     start at 0, since threads are likely to run before a sample is
 ;;     collected.
 ;;   - Finally, the <stack> 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

collects/profj/libs/java/lang/Boolean.java

@@ -145,7 +145,7 @@ public final class Boolean implements Serializable
 
   /**
    * Returns the Boolean <code>TRUE</code> 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 <code>FALSE</code>.
    *
    * @param s the string to convert

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 ()

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)
+  (syntax-case* stx (r6rs:set!) (lambda (a b)
-                             (free-template-identifier=? a b))
+                                  (free-template-identifier=? a b))
     [(identifier-syntax template)
      #'(...
         (make-set!-transformer
          (lambda (stx)
            (syntax-case stx (set!)
              [(set! . _) (raise-syntax-error
-                          #f
+                               #f
-                          "cannot assign to identifier macro"
+                               "cannot assign to identifier macro"
-                          stx)]
+                               stx)]
              [(_ arg ...) #'(template arg ...)]
              [_ #'template]))))]
     [(identifier-syntax
       [id1 template1]
-      [(set! id2 pat) template2])
+      [(r6rs:set! id2 pat) template2])
      (and (identifier? #'id1)
           (identifier? #'id2))
      #'(...

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))]))

collects/r6rs/private/reconstruct.ss

@@ -0,0 +1,4 @@
+#lang scheme/base
+
+(provide reconstruction-memory)
+(define reconstruction-memory (make-weak-hasheq))

collects/redex/doc.txt

@@ -540,7 +540,7 @@ c.
 
 This form extends the reduction relation in its first
 argument with the rules specified in <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 reduction-relation.
 
 If the original reduction-relation has a rule with the same

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)

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)

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* left-column-align ctl-superimpose ltl-superimpose)
-           (list* rtl-superimpose 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))))
 

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?)]
+                                                    name-table lang-id allow-zero-rules?)]
-                      [(rule-names ...) (hash-map name-ht (λ (k v) k))]
+                      [(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 
+(define (reduction-relation->rule-names x) 
-;; 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)
   (reverse (reduction-relation-rule-names x)))
 
 

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)]
+        [(hide-hole a ...) (expected-exact 'hide-hole 1 term)]
-        [in-named-hole (expected-arguments 'hide-hole 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)

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)
+                                  (append rule-names
-                                          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

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))))

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

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
+the rhs-expressions is implicitly wrapped in @|tttterm|. 
-addition, recursive calls in the right-hand side of the
-metafunction clauses should appear inside @|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
+right-hand sides of the reduction rule are beside each other or
-or @scheme['vertical], where the left and right-hand sides of the
+@scheme['vertical], where the left and right-hand sides of the
-reduction rule are above each other. 
+reduction rule are above each other.  The @scheme['compact-vertical]
-The @scheme['compact-vertical] style moves the reduction arrow
+style moves the reduction arrow to the second line and uses less space
-to the second line and uses less space between lines.
+between lines.  The @scheme['vertical-overlapping-side-conditions]
-Finally, in the @scheme['vertical-overlapping-side-conditions] variant, the side-conditions don't contribute to
+variant, the side-conditions don't contribute to the width of the
-the width of the pict, but are just overlaid on the second
+pict, but are just overlaid on the second line of each rule.  The
-line of each rule.
+@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?]{

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!)
+         (syntax-case stx (r6rs:set!)
-           [(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
+   [(mpair? r) 
-                stx
+    (let ([istx (or (hash-ref reconstruction-memory r #f)
-                (cons (wrap (mcar r) stx)
+                    stx)])
-                      (wrap (mcdr r) stx))
+      (datum->syntax
-                stx)]
+       istx
+       (cons (wrap (mcar r) stx)
+             (wrap (mcdr r) stx))
+       istx))]
    [(vector? r) (datum->syntax
                  stx
                  (list->vector

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)))]

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))

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)))))

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)])

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)])

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

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
+    ;; a column marker is either a non-negative integer N (saying the following
-    ;; following code came from at column N), or a negative integer -N (saying
+    ;; code came from at column N), or a negative integer -N (saying that the
-    ;; that the following code came from column N but no need to add
+    ;; following code came from column N but no need to add indentation at this
-    ;; indentation at this point because it is at the openning of a {...});
+    ;; point because it is at the openning of a {...}); `get-lines*' is careful
-    ;; `get-lines*' is careful not to include column markers before a newline
+    ;; not to include column markers before a newline or the end of the text,
-    ;; or the end of the text, and a -N marker can only come from the beginning
+    ;; and a -N marker can only come from the beginning of the text (and it's
-    ;; of the text (and it's never there if the text began with a newline)
+    ;; never there if the text began with a newline)
     (if (andmap eol-syntax? xs)
       ;; nothing to do
       (reverse xs)

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.
 }

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

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.
 

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

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

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{\&}.
 

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.
 

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
+Prepares a new primitive module whose name is the symbol @var{name} (or an
- prefix that is active via @scheme[current-module-name-prefix]). The
+ 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

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:
 

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

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

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.}
 

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

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.
 

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?]{

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

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

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(}
+hash table prints starting with @litchar{#hash(}, @litchar{#hasheqv(}, or @litchar{#hasheq(}
-for a table using @scheme[equal?] or @scheme[eq?] key comparisons,
+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{)}.
 

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

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,

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

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.}

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

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

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.}
 

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])
+;; reprovided from mzscheme
-  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
+;; (define (make-list len [elt #f])
-  (for/list ([i (in-range len)]) elt))
+;;   (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)

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.

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.
   

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

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.
 

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

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))

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)

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)

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)]
+(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]
-      [f2 (open-output-file tmpfile2 '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)

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

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)

doc/srfi-std/srfi-14.html

@@ -1274,7 +1274,7 @@ ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.html</a>
 </div>
 <p class=continue>
 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.
 
 <!--========================================================================-->

doc/srfi-std/srfi-35.html

@@ -145,7 +145,7 @@ returns a condition of condition type <var>condition-type</var>
  is a compound condition, <code>extract-condition</code>
  extracts the field values from  the subcondition belonging to <var>condition-type</var>
  that appeared first in the call to <code>make-compound-condition</code>
- that created the the condition. The returned condition may be newly created; it is possible for</p><pre>(let* ((&amp;c (make-condition-type 'c &amp;condition '()))
+ that created the condition. The returned condition may be newly created; it is possible for</p><pre>(let* ((&amp;c (make-condition-type 'c &amp;condition '()))
        (c0 (make-condition &amp;c))
        (c1 (make-compound-condition c0)))
   (eq? c0 (extract-condition c1 &amp;c)))

doc/srfi-std/srfi-43.html

@@ -389,7 +389,7 @@ You can access the discussion via <A HREF="http://srfi.schemers.org/srfi-43/mail
         must satisfy the predicates <tt>integer?</tt> and
         <tt>positive?</tt>.  This indicates the index directly before
         which traversal will stop &mdash; processing will occur until
-        the the index of the vector is <tt><i>end</i></tt>.  It is the
+        the index of the vector is <tt><i>end</i></tt>.  It is the
         closed right side of a range.
         <br>
         <br>
@@ -1815,7 +1815,7 @@ zot</pre>
       <dd>
         Like <tt><a href="#vector-to-list">vector-&gt;list</a></tt>,
         but the resulting list contains the elements in reverse between
-        the the specified range.
+        the specified range.
         <br>
         <br>
       </dd>

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.
 

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
+    the first example above), but it's better to pick a separate build
-    directory that is otherwise empty.
+    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
+The 3m variant is the default, and it usually provides better overall
-overall performance.
+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
+The paths are embedded in the binary immediately after a special
-dIRECTORy:" tag. Each path must be NUL terminated, the entire list of
+"coLLECTs dIRECTORy:" tag. Each path must be NUL terminated, the
-paths must end with an additional NUL terminator, and the overall list
+entire list of paths must end with an additional NUL terminator, and
-must be less than 1024 bytes long.
+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

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;
+    if (!wx_in_terminal) {
-    waiting_sema = CreateSemaphore(NULL, 0, 1, NULL);
+      console_in = GetStdHandle(STD_INPUT_HANDLE);
-    SetConsoleCtrlHandler(ConsoleHandler, TRUE);
+      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);
+	if (gcw)
-    console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0);
+	  console_hwnd = gcw();
+      }
 
-    {
+      if (console_hwnd) {
-      HMODULE hm;
+	EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE,
-      gcw_proc gcw;
+		       MF_BYCOMMAND | MF_GRAYED);
-
+	RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND);
-      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);
     }
   }
 #endif

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),
+  scheme_add_fd_eventmask(fds, QS_ALLINPUT);
-     everything's ok.
+  mzsleep(secs, fds);
-
-     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);
-  }
 }
 
 void wxQueueLeaveEvent(void *ctx, wxWindow *wnd, int x, int y, int flags)

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.
 

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;

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;
 }