Merge branch 'master' of pltgit:plt

collects/2htdp/tests/test-image.rkt

@@ -2229,6 +2229,9 @@
   #:attempts 1000))
 
 
+;; random testing finds differences here but they
+;; seem to be due to imprecision in inexact arithmetic.
+#;
 (let ()
   (define w 200)
   (define h 200)
@@ -2240,12 +2243,12 @@
   (define bdc2 (make-object bitmap-dc% bm2))
   
   (define (render-and-compare img)
-    (send bdc1 clear)
+    (send bdc1 erase)
-    (send bdc2 clear)
+    (send bdc2 erase)
     (parameterize ([render-normalized #f])
-      (render-image img bdc1 0 0))
+      (render-image img bdc1 10 10))
     (parameterize ([render-normalized #t])
-      (render-image img bdc2 0 0))
+      (render-image img bdc2 10 10))
     (send bdc1 get-argb-pixels 0 0 w h bytes1)
     (send bdc2 get-argb-pixels 0 0 w h bytes2)
     (equal? bytes1 bytes2))

collects/drracket/drracket.rkt

@@ -63,12 +63,43 @@
        (run-trace-thread)))]
   [first-parallel?
    (flprintf "PLTDRPAR: loading compilation manager\n")
+   (define tools? (not (getenv "PLTNOTOOLS")))
    (define (files-in-coll coll)
      (define dir (collection-path coll))
      (map (λ (x) (build-path dir x)) 
           (filter
            (λ (x) (regexp-match #rx"rkt$" (path->string x)))
            (directory-list dir))))
+   (define (randomize lst)
+     (define vec (make-vector (length lst) #f))
+     (let loop ([i 0]
+                [lst lst])
+       (cond
+         [(= i (vector-length vec)) (void)]
+         [else
+          (define index (random (- (vector-length vec) i)))
+          (define ele (list-ref lst index))
+          (vector-set! vec i ele)
+          (loop (+ i 1) (remq ele lst))]))
+     (vector->list vec))
+   
+   (define (tool-files id)
+     (apply 
+      append
+      (map
+       (λ (x)
+         (define-values (base name dir) (split-path x))
+         (define proc (get-info/full x))
+         (if proc
+             (map (λ (dirs)
+                    (apply build-path base
+                           (if (list? dirs)
+                               dirs
+                               (list dirs))))
+                  (proc id (λ () '())))
+             '()))
+       (find-relevant-directories (list id)))))
+   
    (define make-compilation-manager-load/use-compiled-handler
      (parameterize ([current-namespace (make-base-empty-namespace)])
        (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)))
@@ -76,15 +107,27 @@
      (flprintf "PLTDRPAR: enabling CM tracing\n")
      (run-trace-thread))
    (flprintf "PLTDRPAR: loading setup/parallel-build\n")
-   (define parallel-compile-files
+   (define-values (parallel-compile-files get-info/full find-relevant-directories)
      (parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)])
-       (dynamic-require 'setup/parallel-build 'parallel-compile-files)))
+       (values (dynamic-require 'setup/parallel-build 'parallel-compile-files)
-   (flprintf "PLTDRPAR: parallel compile of framework & drracket\n")
+               (and tools? (dynamic-require 'setup/getinfo 'get-info/full))
-   (parallel-compile-files (append (files-in-coll "drracket") (files-in-coll "framework"))
+               (and tools? (dynamic-require 'setup/getinfo 'find-relevant-directories)))))
+   (if tools?
+       (flprintf "PLTDRPAR: parallel compile of framework, drracket, and tools\n")
+       (flprintf "PLTDRPAR: parallel compile of framework and drracket\n"))
+   
+   (parallel-compile-files (randomize (append (files-in-coll "drracket") 
+                                              (files-in-coll "framework")
+                                              (if tools?
+                                                  (append (tool-files 'drracket-tools)
+                                                          (tool-files 'tools))
+                                                  '())))
                            #:handler
                            (λ (handler-type path msg out err)
                              (case handler-type
-                               [(done) (void)]
+                               [(done) 
+                                (when cm-trace?
+                                  (printf "PLTDRPAR: made ~a\n" path))]
                                [else
                                 (printf "~a\n" msg)
                                 (printf "stdout from compiling ~a:\n~a\n" path out)

collects/games/gcalc/gcalc.rkt

@@ -1,7 +1,7 @@
 ;;;============================================================================
 ;;; GCalc
 ;;;   based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
-;;;   implemented by Eli Barzilay: Maze is Life! (eli@barzilay.org)
+;;;   implemented by Eli Barzilay.
 
 #lang mzscheme
 
@@ -25,7 +25,7 @@
 
 (defcustom EVAL-NOW    #t 'bool      "Evaluate immediately on application")
 (defcustom EVAL-DEPTH  18 '(int 100) "Evaluation depth limit")
-(defcustom DRAW-CUTOFF 8 '(int 50)  "Cutoff evaluation when smaller")
+(defcustom DRAW-CUTOFF  8 '(int 50)  "Cutoff evaluation when smaller")
 (defcustom SPLIT-ARGS  #f 'bool      "Split arg by function body structure")
 (defcustom COLOR-OPS   #f 'bool      "Use colors as functions")
 (defcustom NOBMP-PRINT #f 'bool      "Never use bitmaps to print")
@@ -76,10 +76,12 @@
 
 (define SHOW-CELL-SIZE 600)
 
-(define BG-PEN/BRUSH  (list (instantiate pen%   ["BLACK" 1 'solid])
+(define BG-PEN/BRUSH (list (instantiate pen%   ["BLACK" 1 'solid])
-                            (instantiate brush% ["GRAY" 'solid])))
+                           (instantiate brush% ["GRAY" 'solid])))
-(define XOR-PEN/BRUSH (list (instantiate pen%   ["BLACK" 0 'xor])
+(define HIGHLIGHT-WIDTH 4)
-                            (instantiate brush% ["BLACK" 'xor])))
+(define HIGHLIGHT-PEN/BRUSH
+  (list (instantiate pen% ["BLACK" HIGHLIGHT-WIDTH 'solid])
+        (instantiate brush% ("BLACK" 'transparent))))
 
 (define DOUBLE-MILISECS 250)
 
@@ -755,19 +757,11 @@
     (define/public (eval-next-expr) (set! evaluate-next #t))
     (define/public (get-dropper) dropper)
     ;; highlighting
-    (define/private (frame-xor-bitmap)
-      (set-pen/brush dc XOR-PEN/BRUSH)
-      (send* dc
-        (draw-rectangle 1 1 size size)
-        (draw-rectangle CELL-BORDER CELL-BORDER
-                        (- size CELL-BORDER CELL-BORDER -1)
-                        (- size CELL-BORDER CELL-BORDER -1)))
-      (on-paint))
     (define highlighted? #f)
     (define/public (highlight!)
-      (unless highlighted? (frame-xor-bitmap) (set! highlighted? #t)))
+      (unless highlighted? (set! highlighted? #t) (on-paint)))
     (define/public (unhighlight!)
-      (when highlighted? (frame-xor-bitmap) (set! highlighted? #f)))
+      (when highlighted? (set! highlighted? #f) (on-paint)))
     ;; cell operations
     (define (make-cell-op: op . enabled?)
       (let ([enabled?
@@ -823,7 +817,13 @@
         [(show:) show:] [(print:) print:] [(eval:) eval:] [(rename:) rename:]))
     ;; events
     (define/override (on-paint)
-      (send (get-dc) draw-bitmap bitmap 0 0))
+      (let ([dc (get-dc)])
+        (send dc draw-bitmap bitmap 0 0)
+        (when highlighted?
+          (set-pen/brush dc HIGHLIGHT-PEN/BRUSH)
+          (let ([w1 (round (/ HIGHLIGHT-WIDTH 2))]
+                [w2 (- size HIGHLIGHT-WIDTH -1)])
+            (send dc draw-rectangle w1 w1 w2 w2)))))
     (define right-menu-thread #f)
     (define dragging? #f)
     (define drag-to   #f)
@@ -836,8 +836,7 @@
         [(enter)
          (set! current-cell this)
          (send this focus)
-         (when (and draggable? (not (null-expr? expr)))
+         (when (and draggable? (not (null-expr? expr))) (highlight!))]
-           (highlight!))]
         [(leave)
          (unless dragging? (set! current-cell #f) (unhighlight!))]
         [(left-down)

collects/lang/htdp-langs.rkt

@@ -439,7 +439,8 @@
           
           (define/override (first-opened settings)
             (for ([tp (in-list (htdp-lang-settings-teachpacks settings))])
-              (namespace-require/constant tp)))
+              (with-handlers ((exn:fail? void))
+                (namespace-require/constant tp))))
           
           (inherit get-module get-transformer-module get-init-code
                    use-namespace-require/copy?)

collects/meta/dist-specs.rkt

@@ -394,17 +394,12 @@ mz-src := (+ (- (src: "README" "configure" "Makefile.in" "lt/" "racket/"
                 (cond (not mr) => (src: "worksp/starters/mrstart.ico")))
              foreign-src)
 
-mr-src := (src: "gracket/" "mred/" "wxcommon/"
+mr-src := (src: "gracket/" (cond mac => "mac/"
-                (cond unix => "wxxt/"
+                                 win => "worksp/{gracket|mrstart}/"))
-                      mac  => "mac/" "a-list/" "wxmac/"
-                      win  => "wxwindow/"
-                              "worksp/{jpeg|libgracket|gracket|mrstart}/"
-                              "worksp/{png|wxme|wxs|wxutils|wxwin|zlib}/"))
 
 foreign-src := (src: "foreign/{Makefile.in|README}"
                      "foreign/{foreign.*|rktc-utils.rkt}"
-                     (cond win  => "foreign/libffi_msvc"
+                     "foreign/libffi")
-                           else => "foreign/libffi"))
 
 ;; ============================================================================
 ;; Binary definitions (`in-binary-tree' is used with binary trees, these

collects/mred/private/wx/cocoa/queue.rkt

@@ -49,7 +49,7 @@
 
 (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
   []
-  [-a _int (applicationShouldTerminate: [_id app])
+  [-a _NSUInteger (applicationShouldTerminate: [_id app])
       (queue-quit-event)
       0]
   [-a _BOOL (openPreferences: [_id app])
@@ -120,7 +120,7 @@
 (import-class NSEvent)
 (define wake-evt
   (tell NSEvent 
-        otherEventWithType: #:type _int NSApplicationDefined
+        otherEventWithType: #:type _NSUInteger NSApplicationDefined
         location: #:type _NSPoint (make-NSPoint 0.0 0.0)
         modifierFlags: #:type _NSUInteger 0 
         timestamp: #:type _double 0.0

collects/racket/contract/private/base.rkt

@@ -28,25 +28,24 @@ improve method arity mismatch contract violation error messages?
   (syntax-case stx ()
     [(_ c v pos neg name loc)
      (syntax/loc stx
-       (apply-contract c v pos neg name loc (current-contract-region)))]
+       (apply-contract c v pos neg name loc))]
     [(_ c v pos neg)
      (with-syntax ([name (syntax-local-infer-name stx)])
       (syntax/loc stx
         (apply-contract c v pos neg 'name
-                        (build-source-location #f)
+                        (build-source-location #f))))]
-                        (current-contract-region))))]
     [(_ c v pos neg src)
      (raise-syntax-error 'contract
        (string-append
         "please update contract application to new protocol "
         "(either 4 or 6 arguments)"))]))
 
-(define (apply-contract c v pos neg name loc usr)
+(define (apply-contract c v pos neg name loc)
   (let ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
     (let ([new-val
            (((contract-projection c)
-             (make-blame loc name (contract-name c) pos neg usr #t))
+             (make-blame loc name (contract-name c) pos neg #t))
             v)])
       (if (and (not (parameter? new-val))  ;; when PR 11221 is fixed, remove this line
                (procedure? new-val)

collects/racket/contract/private/blame.rkt

@@ -35,7 +35,7 @@
                (hash/recur (blame-original? b))))
 
 (define-struct blame
-  [source value contract positive negative user original?]
+  [source value contract positive negative original?]
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
@@ -100,16 +100,11 @@
         contract-message+at)]
       [else
        (define negative-message (show/display (blame-negative b)))
-       (define user-message
-         (if (equal? (blame-positive b) (blame-user b))
-             ""
-             (format " via ~a" (show/display (blame-user b)))))
        (string-append
         (format "contract violation: ~a\n" custom-message)
-        (format "  contract~a from ~a~a~a blaming ~a~a" 
+        (format "  contract~a from ~a~a blaming ~a~a" 
                 value-message
                 negative-message 
-                user-message
                 (if (regexp-match #rx"\n" negative-message)
                     " "
                     ",")

collects/racket/contract/private/legacy.rkt

@@ -21,8 +21,7 @@
                      name
                      (unpack-blame pos)
                      "<<unknown party>>"
-                     #t
+                     #t)
-                     "<<unknown party>>")
          x
          fmt
          args))
@@ -59,8 +58,7 @@
                         name
                         (unpack-blame (if original? pos neg))
                         (unpack-blame (if original? neg pos))
-                        original? 
+                        original?)))))
-                        (unpack-blame (if original? neg pos)))))))
 
 (define (legacy-property name)
   (define-values [ prop pred get ]

collects/racket/contract/private/provide.rkt

@@ -39,32 +39,6 @@
                                      (current-inspector) #f '(0))])
     make-))
 
-(define (first-requiring-module id self)
-  (define (resolved-module-path->module-path rmp)
-    (cond
-      [(not rmp) 'top-level]
-      [(path? (resolved-module-path-name rmp))
-       `(file ,(path->string (resolved-module-path-name rmp)))]
-      [(symbol? (resolved-module-path-name rmp))
-       `(module ,(resolved-module-path-name rmp))]))  
-  ;; Here we get the module-path-index corresponding to the identifier.
-  ;; We know we can split it at least once, because the contracted identifier
-  ;; we've provided must have been required.  If the second returned value is #f,
-  ;; we just fall back on the old behavior.  If we split again without getting
-  ;; either "self", that is, the first value returned is not #f, then we should
-  ;; use the second mpi result as the module that required the value.
-  (let ([mpi (syntax-source-module id)])
-    (let*-values ([(first-mp second-mpi)
-                   (module-path-index-split mpi)]
-                  [(second-mp third-mpi)
-                   (if second-mpi
-                       (module-path-index-split second-mpi)
-                       (values #f #f))])
-      (if second-mp
-          (resolved-module-path->module-path
-           (module-path-index-resolve second-mpi))
-          self))))
-
 (define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
   (make-set!-transformer
    (let ([saved-id-table (make-hasheq)])
@@ -100,7 +74,7 @@
                               #`(contract contract-id
                                           id
                                           pos-module-source
-                                          (first-requiring-module (quote-syntax loc-id) (quote-module-path))
+                                          (quote-module-path)
                                           'external-id
                                           #,srcloc-code))))))])
                (when key

collects/racket/draw/private/ps-setup.rkt

@@ -17,7 +17,7 @@
   get-all-numerics)
 
 (define paper-sizes
-  '(("A4 210 x 297\n mm" 595 842)
+  '(("A4 210 x 297 mm" 595 842)
     ("A3 297 x 420 mm" 842 1191)
     ("Letter 8 1/2 x 11 in" 612 791)
     ("Legal 8 1/2 x 14 in" 612 1009)))

collects/racket/private/misc.rkt

@@ -26,10 +26,10 @@
                           ([(sexpr) (syntax->datum user-stx)]
                            [(msg)
                             (if (pair? sexpr)
-                              (format "~.s did not match pattern ~.s"
+                              (format "use does not match pattern: ~.s"
-                                      sexpr (cons (car sexpr) 'pattern))
+                                      (cons (car sexpr) 'pattern))
                               (if (symbol? sexpr)
-                                (format "must be used in a pattern ~.s"
+                                (format "use does not match pattern: ~.s"
                                         (cons sexpr 'pattern))
                                 (error 'internal-error
                                        "something bad happened")))])

collects/scribble/eval.rkt

@@ -113,7 +113,7 @@
                        #f
                        (map (lambda (l)
                               (list (make-flow (list l))))
-                            flow-accum))))))))]
+                            (reverse flow-accum)))))))))]
            [(equal? #\newline v)
             (loop #f #f (add-line (add-string string-accum line-accum)
                                   flow-accum))]

collects/scribblings/draw/dc-intf.scrbl

@@ -214,13 +214,16 @@ See also @method[dc<%> set-smoothing] for information on the
 
 }
 
-@defmethod[(draw-lines [points (listof (is-a?/c point%))]
+@defmethod[(draw-lines [points (or/c (listof (is-a?/c point%))
+                                     (listof (cons/c real? real?)))]
                        [xoffset real? 0]
                        [yoffset real? 0])
            void?]{
 
-Draws lines using a list of @scheme[points], adding @scheme[xoffset]
+Draws lines using a list @scheme[points] of points, adding @scheme[xoffset]
- and @scheme[yoffset] to each point. The current pen is used for
+ and @scheme[yoffset] to each point. A pair is treated as a point where the
+ @racket[car] of the pair is the x-value and the @racket[cdr] is the y-value.
+ The current pen is used for
  drawing the lines.
 
 See also @method[dc<%> set-smoothing] for information on the
@@ -274,14 +277,18 @@ Plots a single point using the current pen.
 
 }
 
-@defmethod[(draw-polygon [points (listof (is-a?/c point%))]
+@defmethod[(draw-polygon [points (or/c (listof (is-a?/c point%))
+                                       (listof (cons/c real? real?)))]
                          [xoffset real? 0]
                          [yoffset real? 0]
                          [fill-style (one-of/c 'odd-even 'winding) 'odd-even])
            void?]{
 
-Draw a filled polygon using a list of @scheme[points], adding
+Draw a filled polygon using a list @scheme[points] of points, adding
- @scheme[xoffset] and @scheme[yoffset] to each point. The polygon is
+ @scheme[xoffset] and @scheme[yoffset] to each point. 
+ A pair is treated as a point where the
+ @racket[car] of the pair is the x-value and the @racket[cdr] is the y-value.
+ The polygon is
  automatically closed, so the first and last point can be
  different. The current pen is used for drawing the outline, and the
  current brush for filling the shape.

collects/scribblings/draw/dc-path-class.scrbl

@@ -142,13 +142,16 @@ Extends the path's @tech{open sub-path} with a line to the given
 
 }
 
-@defmethod[(lines [points (listof (is-a?/c point%))]
+@defmethod[(lines [points (or/c (listof (is-a?/c point%))
+                                (listof (cons/c real? real?)))]
                   [xoffset real? 0]
                   [yoffset real? 0])
            void?]{
 
 Extends the path's @tech{open sub-path} with a sequences of lines to
- the given points. If the path has no @tech{open sub-path},
+ the given points. A pair is treated as a point where the @racket[car]
+ of the pair is the x-value and the @racket[cdr] is the y-value.
+ If the path has no @tech{open sub-path},
  @|MismatchExn|.  (This convenience method is implemented in terms of
  @method[dc-path% line-to].)
 

collects/scribblings/draw/ps-setup-class.scrbl

@@ -108,10 +108,9 @@ Landscaped orientation affects the size of the drawing area as
 @defmethod[(get-paper-name)
            string?]{
 
-Returns the name of the current paper type: @scheme["A4 210 x 297
+Returns the name of the current paper type: @scheme["A4 210 x 297 mm"], 
- mm"], @scheme["A3 297 x 420 mm"], @scheme["Letter 8 1/2 x 11 in"], or
+ @scheme["A3 297 x 420 mm"], @scheme["Letter 8 1/2 x 11 in"], or
- @scheme["Legal 8 1/2 x 14 in"]. The default is @scheme["Letter 8 1/2
+ @scheme["Legal 8 1/2 x 14 in"]. The default is @scheme["Letter 8 1/2 x 11 in"].
- x 11 in"].
 
 The paper name determines the size of the drawing area as reported by
  @method[dc<%> get-size] (along with landscape transformations from

collects/scribblings/draw/region-class.scrbl

@@ -150,12 +150,16 @@ The fill style affects how well the region reliably combines with
 
 }
 
-@defmethod[(set-polygon [points (listof (is-a?/c point%))]
+@defmethod[(set-polygon [points (or/c (listof (is-a?/c point%))
+                                      (listof (cons/c real? real?)))]
                         [xoffset real? 0]
                         [yoffset real? 0]
                         [fill-style (one-of/c 'odd-even 'winding) 'odd-even])
            void?]{
-Sets the region to the interior of the specified polygon.
+
+Sets the region to the interior of the polygon specified by
+ @racket[points]. A pair is treated as a point where the @racket[car]
+ of the pair is the x-value and the @racket[cdr] is the y-value.
 
 See also @xmethod[dc<%> draw-polygon], since the region content is
  determined the same way as brush-based filling in a @scheme[dc<%>].

collects/scribblings/raco/setup.scrbl

@@ -1004,7 +1004,7 @@ An @deftech{unpackable} is one of the following:
 
 @defproc[(find-include-dir) (or/c path? false/c)]{
   Returns a path to the installation's @filepath{include} directory, which
-  contains @filepath{.h} files for building MzRacket extensions and embedding
+  contains @filepath{.h} files for building Racket extensions and embedding
   programs. The result is @racket[#f] if no such directory is available.}
 
 @defproc[(find-user-include-dir) path?]{
@@ -1020,7 +1020,7 @@ An @deftech{unpackable} is one of the following:
 
 @defproc[(find-console-bin-dir) (or/c path? false/c)]{
   Returns a path to the installation's executable directory, where the
-  stand-alone MzRacket executable resides. The result is @racket[#f] if no
+  stand-alone Racket executable resides. The result is @racket[#f] if no
   such directory is available.}
 
 @defproc[(find-gui-bin-dir) (or/c path? false/c)]{

collects/scribblings/reference/stx-patterns.scrbl

@@ -469,7 +469,9 @@ Equivalent to
   (syntax-rules ()
    [(id . pattern) template]))
 ]
-}
+
+but with syntax errors potentially phrased in terms of 
+@racket[pattern].}
 
 
 @defidform[...]{

collects/slideshow/initial-ones.rkt

@@ -32,9 +32,9 @@
    #:title "About Slideshow"
    (para (bt "Slideshow")
          "is a library for creating slide presentations")
-   (item "A Slideshow presentation is a PLT Scheme program")
+   (item "A Slideshow presentation is a Racket program")
    (item "Instead of a WYSIWYG interface,"
-         "you get the power of Scheme"))
+         "you get the power of Racket"))
 
   (define (symbol n)
     (text (string (integer->char n)) 'symbol (current-font-size)))

collects/slideshow/tutorial-show.rkt

@@ -209,8 +209,8 @@
 
 (require slideshow/code)
 (slide
- #:title "Scheme Code"
+ #:title "Racket Code"
- (para "For Scheme code, the" (code slideshow/code)
+ (para "For Racket code, the" (code slideshow/code)
             "library provides a handy" (code code) "macro for"
             "typesetting literal code")
  (para "The" (code code) "macro uses source-location information"
@@ -870,7 +870,7 @@
 
 (slide
  #:title "Your Own Slides"
- (para "A Slideshow presentation is a Scheme program in a module,"
+ (para "A Slideshow presentation is a Racket program in a module,"
             "so to make your own:")
  (scale/improve-new-text ; a macro that improves font selection
   (code #,(tt "#lang") slideshow

collects/tests/racket/contract-test.rktl

@@ -11263,15 +11263,206 @@ so that propagation occurs.
      (compose blame-positive exn:fail:contract:blame-object)
      (with-handlers ((void values)) (contract not #t 'pos 'neg))))
 
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
-  ;;;;
+;                                                            
-  ;;;;
+;                                                            
-  ;;;;  Legacy Contract Constructor tests
+;                                                            
-  ;;;;
+;                                                            
-  ;;;;
+;                      ;;;   ;  ;;;      ;;;;;;; ;;;         
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;                      ;;; ;;;          ;;;      ;;;         
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;  ;;; ;; ;;;  ;;; ;;; ;;; ;;;; ;;;     ;;;; ;;; ;;;   ;;;;  
+;  ;;;;;;;;;;; ;;; ;;; ;;; ;;;; ;;;     ;;;; ;;; ;;;  ;; ;;; 
+;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;  ;;;     ;;;  ;;; ;;; ;;; ;;; 
+;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;  ;;; ;;;;;;;  ;;; ;;; ;;;;;;; 
+;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;  ;;; ;;;;;;;  ;;; ;;; ;;;     
+;  ;;; ;;; ;;; ;;;;;;; ;;; ;;;; ;;;     ;;;  ;;; ;;;  ;;;;;; 
+;  ;;; ;;; ;;;  ;; ;;; ;;;  ;;; ;;;     ;;;  ;;; ;;;   ;;;;  
+;                                                            
+;                                                            
+;                                                            
+;                                                            
+
+  (let ()
+    ;; build-and-run : (listof (cons/c string[filename] (cons/c string[lang-line] (listof sexp[body-of-module]))) -> any
+    ;; sets up the files named by 'test-case', dynamically requires the first one, deletes the files
+    ;; and returns/raises-the-exception from the require'd file
+    (define (build-and-run test-case)
+      (define dir (make-temporary-file "contract-test~a" 'directory))
+      (for ([f (in-list test-case)])
+        (call-with-output-file (build-path dir (car f))
+          (lambda (port)
+            (display (cadr f) port)
+            (newline port)
+            (for ([sexp (in-list (cddr f))])
+              (fprintf port "~s\n" sexp)))))
+      (dynamic-wind
+       void
+       (lambda () (contract-eval `(dynamic-require ,(build-path dir (car (car test-case))) #f)))
+       (lambda ()
+         (for ([f (in-list test-case)])
+           (delete-file (build-path dir (car f))))
+         (delete-directory dir))))
+
+    (define exn:fail:contract:blame-object (contract-eval 'exn:fail:contract:blame-object))
+    (define (get-last-part-of-path sexp)
+      (define str (format "orig-blame: ~s" sexp))
+      (define m (regexp-match #rx"[/\\]([-a-z0-9.]*)[^/\\]*$" str))
+      (if m (cadr m) str))
+    
+    ;; basic negative blame case
+    (let ([blame
+           (exn:fail:contract:blame-object 
+            (with-handlers ((exn? values))
+              (build-and-run 
+               (list (list "a.rkt"
+                           "#lang racket/base"
+                           '(require "b.rkt")
+                           '(f #f))
+                     (list "b.rkt"
+                           "#lang racket/base"
+                           '(require racket/contract)
+                           '(provide/contract [f (-> integer? integer?)])
+                           '(define (f x) 1))))))])
+      (ctest "a.rkt"
+             'multi-file-blame1-positive
+             (,get-last-part-of-path (blame-positive ,blame)))
+      (ctest "b.rkt"
+             'multi-file-blame1-negative
+             (,get-last-part-of-path (blame-negative ,blame))))
+    
+    ;; basic positive blame case
+    (let ([blame
+           (exn:fail:contract:blame-object 
+            (with-handlers ((exn? values))
+              (build-and-run 
+               (list (list "a.rkt"
+                           "#lang racket/base"
+                           '(require "b.rkt")
+                           '(f 1))
+                     (list "b.rkt"
+                           "#lang racket/base"
+                           '(require racket/contract)
+                           '(provide/contract [f (-> integer? integer?)])
+                           '(define (f x) #f))))))])
+      (ctest "b.rkt"
+             'multi-file-blame2-positive
+             (,get-last-part-of-path (blame-positive ,blame)))
+      (ctest "a.rkt"
+             'multi-file-blame2-negative
+             (,get-last-part-of-path (blame-negative ,blame))))
+    
+    ;; positive blame via a re-provide
+    (let ([blame
+           (exn:fail:contract:blame-object 
+            (with-handlers ((exn? values))
+              (build-and-run 
+               (list (list "a.rkt"
+                           "#lang racket/base"
+                           '(require "b.rkt")
+                           '(f 1))
+                     (list "b.rkt"
+                           "#lang racket/base"
+                           '(require "c.rkt")
+                           '(provide f))
+                     (list "c.rkt"
+                           "#lang racket/base"
+                           '(require racket/contract)
+                           '(provide/contract [f (-> integer? integer?)])
+                           '(define (f x) #f))))))])
+      (ctest "c.rkt"
+             'multi-file-blame3-positive
+             (,get-last-part-of-path (blame-positive ,blame)))
+      (ctest "a.rkt"
+             'multi-file-blame3-negative
+             (,get-last-part-of-path (blame-negative ,blame))))
+    
+    ;; negative blame via a re-provide
+    (let ([blame
+           (exn:fail:contract:blame-object 
+            (with-handlers ((exn? values))
+              (build-and-run 
+               (list (list "a.rkt"
+                           "#lang racket/base"
+                           '(require "b.rkt")
+                           '(f #f))
+                     (list "b.rkt"
+                           "#lang racket/base"
+                           '(require "c.rkt")
+                           '(provide f))
+                     (list "c.rkt"
+                           "#lang racket/base"
+                           '(require racket/contract)
+                           '(provide/contract [f (-> integer? integer?)])
+                           '(define (f x) 1))))))])
+      (ctest "a.rkt"
+             'multi-file-blame4-positive
+             (,get-last-part-of-path (blame-positive ,blame)))
+      (ctest "c.rkt"
+             'multi-file-blame4-negative
+             (,get-last-part-of-path (blame-negative ,blame))))
+    
+    ;; have some sharing in the require graph
+    (let ([blame
+           (exn:fail:contract:blame-object 
+            (with-handlers ((exn? values))
+              (build-and-run 
+               (list (list "client.rkt"
+                           "#lang racket/base"
+                           '(require "server.rkt" "other.rkt")
+                           '(turn-init #f))
+                     (list "server.rkt"
+                           "#lang racket/base"
+                           '(require racket/contract)
+                           '(provide/contract [turn-init (-> number? any)])
+                           '(define turn-init void))
+                     (list "other.rkt"
+                           "#lang racket/base"
+                           '(require "server.rkt"))))))])
+      (ctest "client.rkt"
+             'multi-file-blame5-positive
+             (,get-last-part-of-path (blame-positive ,blame)))
+      (ctest "server.rkt"
+             'multi-file-blame5-negative
+             (,get-last-part-of-path (blame-negative ,blame)))))
+  
+  
+  
+;                                             
+;                                             
+;                                             
+;                                             
+;  ;;;                                        
+;  ;;;                                        
+;  ;;;   ;;;;   ;; ;;;  ;;;;;    ;;;   ;;; ;;;
+;  ;;;  ;; ;;; ;;;;;;; ;;;;;;;  ;;;;;  ;;; ;;;
+;  ;;; ;;; ;;; ;;; ;;; ;;  ;;; ;;;  ;;  ;; ;; 
+;  ;;; ;;;;;;; ;;; ;;;   ;;;;; ;;;      ;; ;; 
+;  ;;; ;;;     ;;; ;;; ;;; ;;; ;;;  ;;  ;; ;; 
+;  ;;;  ;;;;;; ;;;;;;; ;;; ;;;  ;;;;;    ;;;  
+;  ;;;   ;;;;   ;; ;;;  ;;;;;;   ;;;     ;;;  
+;                  ;;;                 ;;;;;  
+;              ;;;;;;                  ;;;;   
+;                                             
+;                                             
+
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                   ;                         ;                      
+;                                 ;;;                       ;;;                      
+;    ;;;     ;;;   ;;; ;;   ;;;;  ;;;; ;;; ;;;; ;;;   ;;;   ;;;;   ;;;   ;;; ;;;;;;  
+;   ;;;;;   ;;;;;  ;;;;;;; ;;; ;; ;;;; ;;;;;;;; ;;;  ;;;;;  ;;;;  ;;;;;  ;;;;;;;; ;; 
+;  ;;;  ;; ;;; ;;; ;;; ;;; ;;;    ;;;  ;;;  ;;; ;;; ;;;  ;; ;;;  ;;; ;;; ;;;  ;;;    
+;  ;;;     ;;; ;;; ;;; ;;;  ;;;;  ;;;  ;;;  ;;; ;;; ;;;     ;;;  ;;; ;;; ;;;   ;;;;  
+;  ;;;  ;; ;;; ;;; ;;; ;;;    ;;; ;;;  ;;;  ;;; ;;; ;;;  ;; ;;;  ;;; ;;; ;;;     ;;; 
+;   ;;;;;   ;;;;;  ;;; ;;; ;; ;;; ;;;; ;;;  ;;;;;;;  ;;;;;  ;;;;  ;;;;;  ;;;  ;; ;;; 
+;    ;;;     ;;;   ;;; ;;;  ;;;;   ;;; ;;;   ;; ;;;   ;;;    ;;;   ;;;   ;;;   ;;;;  
+;                                                                                    
+;                                                                                    
+;                                                                                    
+;                                                                                    
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;

collects/tests/racket/stx.rktl

@@ -1456,6 +1456,27 @@
                (get-output-bytes s))
              exn:fail?)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; define-syntax-rule
+
+(define-syntax-rule (a-rule-pattern x [y z])
+  (list 'x 'y 'z))
+
+(test '(1 2 3) 'a-rule (a-rule-pattern 1 [2 3]))
+(test '(1 2 3) 'a-rule (a-rule-pattern 1 . ([2 3])))
+(test '(1 2 3) 'a-rule (a-rule-pattern 1 [2 . (3)]))
+(syntax-test #'a-rule-pattern)
+(syntax-test #'(a-rule-pattern 1 2 3))
+(syntax-test #'(a-rule-pattern 1 . 2))
+(syntax-test #'(a-rule-pattern . 1))
+(syntax-test #'(a-rule-pattern 1 [2 3] 4))
+
+(let ([no-match? (lambda (exn) 
+                   (regexp-match? #"does not match pattern" (exn-message exn)))])
+  (error-test #'a-rule-pattern no-match?)
+  (error-test #'(a-rule-pattern) no-match?)
+  (error-test #'(a-rule-pattern 1) no-match?))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

collects/tests/run-automated-tests.rkt

@@ -75,10 +75,10 @@
                   (echo "Timeout!")
                   (break-thread th)
                   (sleep 60)
-                  (echo "  A minute has passed, killing the test thread!")
+                  (echo "BOOM! A minute has passed, killing the test thread!")
                   (kill-thread th)
                   (sleep 60)
-                  (echo "  Another minute passed, aborting!")
+                  (echo "Another minute passed, aborting!")
                   (abort 1 "Goodbye.")))))
     (parameterize* ([exit-handler
                      (lambda (n) (abort n "exit with error code ~a" n))]

collects/tests/scribble/docs.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+
+;; Use text renderer to check some Scribble functionality
+
+;; ----------------------------------------
+
+(require scribble/base-render
+         racket/file
+         racket/class
+         (prefix-in text:  scribble/text-render))
+
+(define (build-text-doc src-file dest-file)
+  (define dir (find-system-path 'temp-dir))
+  (let ([renderer (new (text:render-mixin render%)
+                    [dest-dir dir])])
+    (let* ([docs (list (dynamic-require `(file ,src-file) 'doc))]
+           [fns (list (build-path dir dest-file))]
+           [fp (send renderer traverse docs fns)]
+           [info (send renderer collect docs fns fp)])
+      (let ([r-info (send renderer resolve docs fns info)])
+        (send renderer render docs fns r-info)))))
+
+(define (check-text-build name)
+  (define src-file (string-append "docs/" name ".scrbl"))
+  (define expect-file (string-append "docs/" name ".txt"))
+  (build-text-doc src-file "gen.txt")
+  (unless (string=? (file->string expect-file)
+                    (file->string (build-path (find-system-path 'temp-dir)
+                                              "gen.txt")))
+    (error 'check-text-build "mismatch from: ~e expected: ~e"
+           src-file expect-file)))
+
+;; ----------------------------------------
+
+(check-text-build "print-lines")

collects/tests/scribble/docs/print-lines.scrbl

@@ -0,0 +1,21 @@
+#lang scribble/manual
+
+@(require scribble/eval)
+
+@title{Pretty-Print-Handler Bug Example}
+
+@(define the-eval (make-base-eval))
+@(interaction-eval
+  #:eval the-eval
+  (begin
+    (require racket/pretty)
+    (current-print pretty-print-handler)))
+
+@examples[#:eval the-eval
+'((x "positional 1") 
+    (rest ("positional 2" "positional 3"))
+    (a ())
+    (b ("b-arg"))
+    (c (("first c1" "second c1") ("first c2" "second c2")))
+    (d #f)
+    (e ()))]

collects/tests/scribble/docs/print-lines.txt

@@ -0,0 +1,18 @@
+
+Pretty-Print-Handler Bug Example
+
+Example:
+  > '((x "positional 1")
+        (rest ("positional 2" "positional 3"))
+        (a ())
+        (b ("b-arg"))
+        (c (("first c1" "second c1") ("first c2" "second c2")))
+        (d #f)
+        (e ()))
+  '((x "positional 1")
+    (rest ("positional 2" "positional 3"))
+    (a ())
+    (b ("b-arg"))
+    (c (("first c1" "second c1") ("first c2" "second c2")))
+    (d #f)
+    (e ()))

doc/release-notes/racket/Draw_and_GUI_5_1.txt

@@ -17,7 +17,7 @@ API:
    Racket.
 
    The GRacket executable still offers some additional GUI-specific
-   functiontality however. Most notably, GRacket is a GUI application
+   functionality however. Most notably, GRacket is a GUI application
    under Windows (as opposed to a console application, which is
    launched slightly differently by the OS), GRacket is a bundle under
    Mac OS X (so the dock icon is the Racket logo, for example), and
@@ -91,8 +91,8 @@ The old translation and scaling transformations apply after the
 initial matrix. The new rotation transformation applies after the
 other transformations. This layering is redundant, since all
 transformations can be expressed in a single matrix, but it is
-backward-compatibile. Methods like `get-translation',
+backward-compatible. Methods like `get-translation',
-`set-translation', `scale', etc. help hide the reundancy.
+`set-translation', `scale', etc. help hide the redundancy.
 
 
 PostScript, PDF, and SVG Drawing Contexts
@@ -150,13 +150,13 @@ into the control.
 
 Event callbacks are delimited by a continuation prompt using the
 default continuation prompt tag. As a result, continuations can be
-usufully captured during one event callback and applied during other
+usefully captured during one event callback and applied during other
 callbacks or outside of an even callback. The continuation barrier and
 jump-defeating `dynamic-wind' that formerly guarded callbacks has been
 removed.
 
 The `on-subwindow-char' and `on-subwindow-event' methods for controls
-are somewhat more restructed in the actions they can take without
+are somewhat more restricted in the actions they can take without
 disabling the control's handling of key and mouse events. See the
 documentation for more information.
 

src/configure

@@ -5294,10 +5294,11 @@ case $OS in
         LD=gcc-4.0
       fi
       SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS} ${PREFLAGS}"'"'
+      need_cc_in_extras=yes
     fi
 
-    case `$UNAME -m` in
+    case "`$UNAME -m`" in
-      i386)
+      i386|x86_64)
        enable_futures_by_default=yes
        ;;
       *)
@@ -5337,7 +5338,7 @@ case $OS in
 
     # Force 32-bit build unless mac64 is enabled:
     if test "${enable_mac64}" != "yes" ; then
-      if test `${UNAME} -m` = "i386" ; then
+      if test "`${UNAME} -m`" != "Power Macintosh" ; then
         if test "${ORIG_CC}" = "" ; then
            PREFLAGS="${PREFLAGS} -m32"
            CPPFLAGS="${CPPFLAGS} -m32"
@@ -5345,10 +5346,15 @@ case $OS in
            # To make the libffi build work, we have to fold -m32 into CC
            # instead of CFLAGS:
            SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"' -m32"'
+           need_cc_in_extras=no
         fi
       fi
     fi
 
+    if test "${need_cc_in_extras}" = "yes" ; then
+      SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"'"'
+    fi
+
     if test "${enable_quartz}" = "yes" ; then
       WXVARIANT="wx_mac"
       MROPTIONS="$MROPTIONS -fpascal-strings"

src/racket/configure.ac

@@ -609,10 +609,11 @@ case $OS in
         LD=gcc-4.0
       fi
       SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS} ${PREFLAGS}"'"'
+      need_cc_in_extras=yes
     fi
     
-    case `$UNAME -m` in
+    case "`$UNAME -m`" in
-      i386)
+      i386|x86_64)
        enable_futures_by_default=yes
        ;;
       *)
@@ -652,7 +653,7 @@ case $OS in
 
     # Force 32-bit build unless mac64 is enabled:
     if test "${enable_mac64}" != "yes" ; then
-      if test `${UNAME} -m` = "i386" ; then
+      if test "`${UNAME} -m`" != "Power Macintosh" ; then
         if test "${ORIG_CC}" = "" ; then
            PREFLAGS="${PREFLAGS} -m32"
            CPPFLAGS="${CPPFLAGS} -m32"
@@ -660,10 +661,15 @@ case $OS in
            # To make the libffi build work, we have to fold -m32 into CC
            # instead of CFLAGS:
            SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"' -m32"'
+           need_cc_in_extras=no
         fi
       fi
     fi
 
+    if test "${need_cc_in_extras}" = "yes" ; then
+      SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"'"'
+    fi
+
     if test "${enable_quartz}" = "yes" ; then
       WXVARIANT="wx_mac"
       MROPTIONS="$MROPTIONS -fpascal-strings"