From 2d7dfab9b90dd5bb6f5f9655600cea1c1092dee0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 14:21:04 -0700 Subject: [PATCH 01/23] fix docs for methods that accept a list of pairs as points --- collects/scribblings/draw/dc-intf.scrbl | 19 +++++++++++++------ collects/scribblings/draw/dc-path-class.scrbl | 7 +++++-- collects/scribblings/draw/region-class.scrbl | 8 ++++++-- 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index ed2f035f62..7d7a58527f 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/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] - and @scheme[yoffset] to each point. The current pen is used for +Draws lines using a list @scheme[points] of points, adding @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 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 - @scheme[xoffset] and @scheme[yoffset] to each point. The polygon is +Draw a filled polygon using a list @scheme[points] of points, adding + @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. diff --git a/collects/scribblings/draw/dc-path-class.scrbl b/collects/scribblings/draw/dc-path-class.scrbl index 653f99e1b3..936c1cfc4d 100644 --- a/collects/scribblings/draw/dc-path-class.scrbl +++ b/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].) diff --git a/collects/scribblings/draw/region-class.scrbl b/collects/scribblings/draw/region-class.scrbl index fe84ee0099..f0be83c7fa 100644 --- a/collects/scribblings/draw/region-class.scrbl +++ b/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<%>]. From 379feaeac2ebd07b17ebc6f54d04c084171410e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 14:21:33 -0700 Subject: [PATCH 02/23] fix typos Merge to 5.1 --- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 128f037bd4..75d625c27b 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/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', -`set-translation', `scale', etc. help hide the reundancy. +backward-compatible. Methods like `get-translation', +`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. From 9070a4c96196ad2b8cabe41e10fb0fb7d5f8db51 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 14:21:49 -0700 Subject: [PATCH 03/23] fix doc typos --- collects/scribblings/raco/setup.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/raco/setup.scrbl b/collects/scribblings/raco/setup.scrbl index 978aa28819..32a78a5d4d 100644 --- a/collects/scribblings/raco/setup.scrbl +++ b/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)]{ From 8c0d19fb12afcabc0c58ee68bcf9e99faf7b8c43 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Feb 2011 14:38:08 -0700 Subject: [PATCH 04/23] fix `configure' for 64-bit Mac OS X kernel --- src/configure | 12 +++++++++--- src/racket/configure.ac | 12 +++++++++--- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/src/configure b/src/configure index 32c4d54373..a2a521c2b2 100755 --- a/src/configure +++ b/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 - i386) + case "`$UNAME -m`" in + 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" diff --git a/src/racket/configure.ac b/src/racket/configure.ac index cf2256881c..7f5ebb4595 100644 --- a/src/racket/configure.ac +++ b/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 - i386) + case "`$UNAME -m`" in + 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" From 0840430b21eb70cc4e9ac7b97e8fea9f9838404a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Feb 2011 09:51:24 -0700 Subject: [PATCH 05/23] clean up `define-syntax-rules' by removing a redundant expression in an error message, adding tests, and documenting the fact that a syntax-error message can expose the pattern source to users --- collects/racket/private/misc.rkt | 6 +++--- .../scribblings/reference/stx-patterns.scrbl | 4 +++- collects/tests/racket/stx.rktl | 21 +++++++++++++++++++ 3 files changed, 27 insertions(+), 4 deletions(-) diff --git a/collects/racket/private/misc.rkt b/collects/racket/private/misc.rkt index 26aba931c1..938da11c82 100644 --- a/collects/racket/private/misc.rkt +++ b/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" - sexpr (cons (car sexpr) 'pattern)) + (format "use does not match pattern: ~.s" + (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")))]) diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index e3641fe452..62b29fdb90 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/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[...]{ diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index ebb92f87cc..deb76e0020 100644 --- a/collects/tests/racket/stx.rktl +++ b/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) From 9d2e025e51e427580e71e930e05404e50beff0dd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Feb 2011 09:59:48 -0700 Subject: [PATCH 06/23] Rackety Slideshow tutorial --- collects/slideshow/initial-ones.rkt | 4 ++-- collects/slideshow/tutorial-show.rkt | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/slideshow/initial-ones.rkt b/collects/slideshow/initial-ones.rkt index c7cda9a425..8f68694bf5 100644 --- a/collects/slideshow/initial-ones.rkt +++ b/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))) diff --git a/collects/slideshow/tutorial-show.rkt b/collects/slideshow/tutorial-show.rkt index a380c2a65e..af8ac23332 100644 --- a/collects/slideshow/tutorial-show.rkt +++ b/collects/slideshow/tutorial-show.rkt @@ -209,8 +209,8 @@ (require slideshow/code) (slide - #:title "Scheme Code" - (para "For Scheme code, the" (code slideshow/code) + #:title "Racket 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 From 731a754e2b3cc6ac4eed277efdac2105803dc005 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 11 Feb 2011 09:06:43 -0600 Subject: [PATCH 07/23] added tests that check on provide/contract when there are multiple files containing modules related to PR 11724 related to PR 11084 --- collects/racket/contract/private/blame.rkt | 1 + collects/tests/racket/contract-test.rktl | 224 ++++++++++++++++++++- 2 files changed, 216 insertions(+), 9 deletions(-) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 5cdb913fd3..2bfe1b8ada 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -7,6 +7,7 @@ blame-source blame-positive blame-negative + blame-user blame-contract blame-value blame-original? diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 8e66ca0861..51f9745630 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -11263,15 +11263,221 @@ 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 m (regexp-match #rx"/([-a-z0-9.]*)[^/]*$" (format "~s" sexp))) + (printf "sexp: ~s => ~s\n" (format "~s" sexp) m) + (and m (cadr m))) + + ;; 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))) + (ctest "a.rkt" + 'multi-file-blame1-user + (,get-last-part-of-path (blame-user ,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))) + (ctest "a.rkt" + 'multi-file-blame2-user + (,get-last-part-of-path (blame-user ,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 "b.rkt" + 'multi-file-blame3-negative + (,get-last-part-of-path (blame-negative ,blame))) + (ctest "?.rkt" + 'multi-file-blame3-user + (,get-last-part-of-path (blame-user ,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 "b.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))) + (ctest "?.rkt" + 'multi-file-blame4-user + (,get-last-part-of-path (blame-user ,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))) + (ctest "server.rkt" + 'multi-file-blame5-user + (,get-last-part-of-path (blame-user ,blame))))) + + + +; +; +; +; +; ;;; +; ;;; +; ;;; ;;;; ;; ;;; ;;;;; ;;; ;;; ;;; +; ;;; ;; ;;; ;;;;;;; ;;;;;;; ;;;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;; ;; +; ;;; ;;;;;;; ;;; ;;; ;;;;; ;;; ;; ;; +; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;; +; ;;; ;;;;;; ;;;;;;; ;;; ;;; ;;;;; ;;; +; ;;; ;;;; ;; ;;; ;;;;;; ;;; ;;; +; ;;; ;;;;; +; ;;;;;; ;;;; +; +; + +; +; +; +; +; ; ; +; ;;; ;;; +; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ;;; ;;; ;;;;;; +; ;;;;; ;;;;; ;;;;;;; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ;;;;; ;;;;;;;; ;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; +; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; +; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;;;; ;;; ;; ;;; +; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;;; +; +; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; From 4d9c150b7b4d65d4a8b58fe4c0a03eaa5e2627c4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 10 Feb 2011 15:46:33 -0600 Subject: [PATCH 08/23] 2htdp/image: adjust tests --- collects/2htdp/tests/test-image.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index d50bc28cdd..ab876a806e 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/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 bdc2 clear) + (send bdc1 erase) + (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)) From 00152d2482314a7e53dba3385a1f0600c4a19f74 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 9 Feb 2011 18:44:07 -0600 Subject: [PATCH 09/23] compile the tool files in addition to the framework and drracket when PLTDRPAR is set --- collects/drracket/drracket.rkt | 53 ++++++++++++++++++++++++++++++---- 1 file changed, 48 insertions(+), 5 deletions(-) diff --git a/collects/drracket/drracket.rkt b/collects/drracket/drracket.rkt index 80639a1d0e..df2b2fb46d 100644 --- a/collects/drracket/drracket.rkt +++ b/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))) - (flprintf "PLTDRPAR: parallel compile of framework & drracket\n") - (parallel-compile-files (append (files-in-coll "drracket") (files-in-coll "framework")) + (values (dynamic-require 'setup/parallel-build 'parallel-compile-files) + (and tools? (dynamic-require 'setup/getinfo 'get-info/full)) + (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) From 7eefe74e93e6ceda0c1baa370f4dc89e68863e70 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 1 Feb 2011 22:21:23 -0600 Subject: [PATCH 10/23] at attempt to use the dc's scale and rotation to instead of doing the rotation in racket --- collects/mrlib/image-core.rkt | 47 +++++++++++++++++++++++++++-------- 1 file changed, 37 insertions(+), 10 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 8df14e75b3..4064efc10d 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -863,16 +863,43 @@ has been moved out). (send dc set-brush (mode-color->brush mode color)) (send dc set-smoothing (mode-color->smoothing mode color)) (send dc draw-path path dx dy)))] - [(flip? np-atomic-shape) - (let ([bm (get-rendered-bitmap np-atomic-shape)]) - (send dc set-smoothing 'smoothed) - (send dc draw-bitmap - bm - (- dx (/ (send bm get-width) 2)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] + [(flip? np-atomic-shape) + (cond + [#t ; (flip-flipped? np-atomic-shape) + (let ([bm (get-rendered-bitmap np-atomic-shape)]) + (send dc set-smoothing 'smoothed) + (send dc draw-bitmap + bm + (- dx (/ (send bm get-width) 2)) + (- dy (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (get-rendered-mask np-atomic-shape)))] + + [else + ;; this only works when the scale is 1 and there is no flipping + (define bitmap (flip-shape np-atomic-shape)) + (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap))) + (define θ (degrees->radians (ibitmap-angle bitmap))) + (define w (send orig-bitmap-obj get-width)) + (define h (send orig-bitmap-obj get-height)) + (define c2 + (* (- (make-rectangular dx dy) + (* (make-polar 1 (- θ)) + (make-rectangular (/ w 2) (/ h 2)))) + (make-polar 1 θ))) + + (define orig-rotation (send dc get-rotation)) + (send dc set-rotation θ) + (send dc draw-bitmap + orig-bitmap-obj + (real-part c2) + (imag-part c2) + 'solid + (send the-color-database find-color "black") + orig-mask-obj) + (send dc set-rotation orig-rotation)])] [(text? np-atomic-shape) (let ([θ (degrees->radians (text-angle np-atomic-shape))] [font (send dc get-font)]) From ae674646702e86442c9ff43a2cc2effca27e0884 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 11:15:01 -0600 Subject: [PATCH 11/23] adjust test suite to work on windows and to the new agreement about reproviding --- collects/tests/racket/contract-test.rktl | 35 +++++++----------------- 1 file changed, 10 insertions(+), 25 deletions(-) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 51f9745630..bc330f1499 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -11306,9 +11306,9 @@ so that propagation occurs. (define exn:fail:contract:blame-object (contract-eval 'exn:fail:contract:blame-object)) (define (get-last-part-of-path sexp) - (define m (regexp-match #rx"/([-a-z0-9.]*)[^/]*$" (format "~s" sexp))) - (printf "sexp: ~s => ~s\n" (format "~s" sexp) m) - (and m (cadr m))) + (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 @@ -11329,10 +11329,7 @@ so that propagation occurs. (,get-last-part-of-path (blame-positive ,blame))) (ctest "b.rkt" 'multi-file-blame1-negative - (,get-last-part-of-path (blame-negative ,blame))) - (ctest "a.rkt" - 'multi-file-blame1-user - (,get-last-part-of-path (blame-user ,blame)))) + (,get-last-part-of-path (blame-negative ,blame)))) ;; basic positive blame case (let ([blame @@ -11353,10 +11350,7 @@ so that propagation occurs. (,get-last-part-of-path (blame-positive ,blame))) (ctest "a.rkt" 'multi-file-blame2-negative - (,get-last-part-of-path (blame-negative ,blame))) - (ctest "a.rkt" - 'multi-file-blame2-user - (,get-last-part-of-path (blame-user ,blame)))) + (,get-last-part-of-path (blame-negative ,blame)))) ;; positive blame via a re-provide (let ([blame @@ -11379,12 +11373,9 @@ so that propagation occurs. (ctest "c.rkt" 'multi-file-blame3-positive (,get-last-part-of-path (blame-positive ,blame))) - (ctest "b.rkt" + (ctest "a.rkt" 'multi-file-blame3-negative - (,get-last-part-of-path (blame-negative ,blame))) - (ctest "?.rkt" - 'multi-file-blame3-user - (,get-last-part-of-path (blame-user ,blame)))) + (,get-last-part-of-path (blame-negative ,blame)))) ;; negative blame via a re-provide (let ([blame @@ -11404,15 +11395,12 @@ so that propagation occurs. '(require racket/contract) '(provide/contract [f (-> integer? integer?)]) '(define (f x) 1))))))]) - (ctest "b.rkt" + (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))) - (ctest "?.rkt" - 'multi-file-blame4-user - (,get-last-part-of-path (blame-user ,blame)))) + (,get-last-part-of-path (blame-negative ,blame)))) ;; have some sharing in the require graph (let ([blame @@ -11436,10 +11424,7 @@ so that propagation occurs. (,get-last-part-of-path (blame-positive ,blame))) (ctest "server.rkt" 'multi-file-blame5-negative - (,get-last-part-of-path (blame-negative ,blame))) - (ctest "server.rkt" - 'multi-file-blame5-user - (,get-last-part-of-path (blame-user ,blame))))) + (,get-last-part-of-path (blame-negative ,blame))))) From a8e9eabf7d8d55e47a4cc8bd27a90f6d2529354d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 11:15:38 -0600 Subject: [PATCH 12/23] take the negative blame from the reference in all cases ie, avoid looking at the module path indicies to to trace back in the require chain. closes PR 11084 also closes duplicate PR 11724 please merge to the 5.1 release branch --- collects/racket/contract/private/provide.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index 513961d9e2..ea0e5648ba 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -100,7 +100,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 From 2308ad7b8a425ed3e64c93839b76e86c28bc54b5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 11:29:20 -0600 Subject: [PATCH 13/23] remove the user field from blame structs (code cleanup after last commit) --- collects/racket/contract/private/base.rkt | 9 +++---- collects/racket/contract/private/blame.rkt | 10 ++------ collects/racket/contract/private/legacy.rkt | 3 +-- collects/racket/contract/private/provide.rkt | 26 -------------------- 4 files changed, 7 insertions(+), 41 deletions(-) diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index 93a20aa6fe..6dbe71ba46 100644 --- a/collects/racket/contract/private/base.rkt +++ b/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) - (current-contract-region))))] + (build-source-location #f))))] [(_ 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) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 2bfe1b8ada..583fcede5b 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -7,7 +7,6 @@ blame-source blame-positive blame-negative - blame-user blame-contract blame-value blame-original? @@ -36,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)) @@ -101,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) " " ",") diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt index c8613aec43..a8b9310d12 100644 --- a/collects/racket/contract/private/legacy.rkt +++ b/collects/racket/contract/private/legacy.rkt @@ -21,8 +21,7 @@ name (unpack-blame pos) "<>" - #t - "<>") + #t) x fmt args)) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index ea0e5648ba..10f287b394 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/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)]) From 5e70dc863e7d965241a8d456e99d500d9f389fcc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 12:00:57 -0600 Subject: [PATCH 14/23] Revert "at attempt to use the dc's scale and rotation to instead of doing the rotation in racket" This reverts commit 7eefe74e93e6ceda0c1baa370f4dc89e68863e70. --- collects/mrlib/image-core.rkt | 47 ++++++++--------------------------- 1 file changed, 10 insertions(+), 37 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 4064efc10d..8df14e75b3 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -863,43 +863,16 @@ has been moved out). (send dc set-brush (mode-color->brush mode color)) (send dc set-smoothing (mode-color->smoothing mode color)) (send dc draw-path path dx dy)))] - [(flip? np-atomic-shape) - (cond - [#t ; (flip-flipped? np-atomic-shape) - (let ([bm (get-rendered-bitmap np-atomic-shape)]) - (send dc set-smoothing 'smoothed) - (send dc draw-bitmap - bm - (- dx (/ (send bm get-width) 2)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] - - [else - ;; this only works when the scale is 1 and there is no flipping - (define bitmap (flip-shape np-atomic-shape)) - (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap))) - (define θ (degrees->radians (ibitmap-angle bitmap))) - (define w (send orig-bitmap-obj get-width)) - (define h (send orig-bitmap-obj get-height)) - (define c2 - (* (- (make-rectangular dx dy) - (* (make-polar 1 (- θ)) - (make-rectangular (/ w 2) (/ h 2)))) - (make-polar 1 θ))) - - (define orig-rotation (send dc get-rotation)) - (send dc set-rotation θ) - (send dc draw-bitmap - orig-bitmap-obj - (real-part c2) - (imag-part c2) - 'solid - (send the-color-database find-color "black") - orig-mask-obj) - (send dc set-rotation orig-rotation)])] + [(flip? np-atomic-shape) + (let ([bm (get-rendered-bitmap np-atomic-shape)]) + (send dc set-smoothing 'smoothed) + (send dc draw-bitmap + bm + (- dx (/ (send bm get-width) 2)) + (- dy (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (get-rendered-mask np-atomic-shape)))] [(text? np-atomic-shape) (let ([θ (degrees->radians (text-angle np-atomic-shape))] [font (send dc get-font)]) From d2eb80be357155e4e071950b33249658b02ea957 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 12 Feb 2011 20:31:49 -0600 Subject: [PATCH 15/23] missed a place where I need one fewer argument to the 'blame' constructor --- collects/racket/contract/private/legacy.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt index a8b9310d12..e919c7e27a 100644 --- a/collects/racket/contract/private/legacy.rkt +++ b/collects/racket/contract/private/legacy.rkt @@ -58,8 +58,7 @@ name (unpack-blame (if original? pos neg)) (unpack-blame (if original? neg pos)) - original? - (unpack-blame (if original? neg pos))))))) + original?))))) (define (legacy-property name) (define-values [ prop pred get ] From aea79be7a4b6baf6add8281866773cd6d452dfb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Feb 2011 05:48:06 -0700 Subject: [PATCH 16/23] cocoa: FFI type corrections --- collects/mred/private/wx/cocoa/queue.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 0480478fbb..f74b25be84 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/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 From 6320d3207a2760f41a2e47a8feecffd6f78aa6b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Feb 2011 05:48:33 -0700 Subject: [PATCH 17/23] fix A4 paper description Closes PR 11734 --- collects/racket/draw/private/ps-setup.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/draw/private/ps-setup.rkt b/collects/racket/draw/private/ps-setup.rkt index d07ecd53da..6a1ba170b2 100644 --- a/collects/racket/draw/private/ps-setup.rkt +++ b/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))) From da3fd90256761bc9392ad4cf5a978100624a194f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Feb 2011 07:11:45 -0700 Subject: [PATCH 18/23] doc repair for PR 11734 follow-up --- collects/scribblings/draw/ps-setup-class.scrbl | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/draw/ps-setup-class.scrbl b/collects/scribblings/draw/ps-setup-class.scrbl index 6f98a77657..11691458ea 100644 --- a/collects/scribblings/draw/ps-setup-class.scrbl +++ b/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 - mm"], @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 - x 11 in"]. +Returns the name of the current paper type: @scheme["A4 210 x 297 mm"], + @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 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 From 1a5f41fd712384b409c760d15961af7b83e000ff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Feb 2011 07:12:14 -0700 Subject: [PATCH 19/23] Scribble: fix multi-line print output Closes PR 11735 --- collects/scribble/eval.rkt | 2 +- collects/tests/scribble/docs.rkt | 35 +++++++++++++++++++ .../tests/scribble/docs/print-lines.scrbl | 21 +++++++++++ collects/tests/scribble/docs/print-lines.txt | 18 ++++++++++ 4 files changed, 75 insertions(+), 1 deletion(-) create mode 100644 collects/tests/scribble/docs.rkt create mode 100644 collects/tests/scribble/docs/print-lines.scrbl create mode 100644 collects/tests/scribble/docs/print-lines.txt diff --git a/collects/scribble/eval.rkt b/collects/scribble/eval.rkt index 4d6da7a29d..de9e834db3 100644 --- a/collects/scribble/eval.rkt +++ b/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))] diff --git a/collects/tests/scribble/docs.rkt b/collects/tests/scribble/docs.rkt new file mode 100644 index 0000000000..86ca59b5ba --- /dev/null +++ b/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") diff --git a/collects/tests/scribble/docs/print-lines.scrbl b/collects/tests/scribble/docs/print-lines.scrbl new file mode 100644 index 0000000000..20f4fc997d --- /dev/null +++ b/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 ()))] diff --git a/collects/tests/scribble/docs/print-lines.txt b/collects/tests/scribble/docs/print-lines.txt new file mode 100644 index 0000000000..707a419e8d --- /dev/null +++ b/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 ())) \ No newline at end of file From 25adab8cbb90902480f1c1657829006803e6843e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 14 Feb 2011 10:22:21 -0600 Subject: [PATCH 20/23] This is a change to paper over a bug elsewhere in the system that threatens the release. Specifically, when there is an error in the namespace require (say if one of the teachpack files gets corrupted (because you use a script that monkeys around in the installation, say, and things go wrong)) then the first-opened method does not return normally, but raises an exception. This, so far, is not a problem, but it appears that there is a bug in the implementation of the drracket repl io ports that causes them to deadlock when flushing the error port under certain conditions (I'm not sure what is really going on with this bug, but I am observing a call to flush that fails to return) and the error-display-handler for the teaching languages flushes the output port. This change just avoids printing the error and so the error display handler is not called in the fragile state. This change goes back to exactly what was happening in 5.0.2, at least as far as the teaching language's first-opened method is concerned. So, if this seems okay, I'd like to suggest it be included in the release. --- collects/lang/htdp-langs.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 719712085f..5dfa39c10c 100644 --- a/collects/lang/htdp-langs.rkt +++ b/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?) From b090dde2fbb184d1b92721a0d153e6387ff98cfc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 11 Feb 2011 14:31:07 -0500 Subject: [PATCH 21/23] Add a "BOOM" string to the timeout message, otherwise the failure is hard to find. --- collects/tests/run-automated-tests.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/run-automated-tests.rkt b/collects/tests/run-automated-tests.rkt index 0f5eb93ee9..3b8abb9419 100755 --- a/collects/tests/run-automated-tests.rkt +++ b/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))] From 8d211cd0486eb7aa05306d5e2f7c5dfe371d6239 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 12 Feb 2011 21:37:37 -0500 Subject: [PATCH 22/23] Removed some source file specs that are no longer relevant --- collects/meta/dist-specs.rkt | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index fd3452b377..6104af41e6 100644 --- a/collects/meta/dist-specs.rkt +++ b/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/" - (cond unix => "wxxt/" - mac => "mac/" "a-list/" "wxmac/" - win => "wxwindow/" - "worksp/{jpeg|libgracket|gracket|mrstart}/" - "worksp/{png|wxme|wxs|wxutils|wxwin|zlib}/")) +mr-src := (src: "gracket/" (cond mac => "mac/" + win => "worksp/{gracket|mrstart}/")) foreign-src := (src: "foreign/{Makefile.in|README}" "foreign/{foreign.*|rktc-utils.rkt}" - (cond win => "foreign/libffi_msvc" - else => "foreign/libffi")) + "foreign/libffi") ;; ============================================================================ ;; Binary definitions (`in-binary-tree' is used with binary trees, these From 0a2d5fd4ac7ed4bff364c667cae44fbe3e9a59df Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 14 Feb 2011 13:34:01 -0500 Subject: [PATCH 23/23] Avoid using a xor brush for highlights. --- collects/games/gcalc/gcalc.rkt | 37 +++++++++++++++++----------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/collects/games/gcalc/gcalc.rkt b/collects/games/gcalc/gcalc.rkt index 2756e8c539..79d22d02a3 100644 --- a/collects/games/gcalc/gcalc.rkt +++ b/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]) - (instantiate brush% ["GRAY" 'solid]))) -(define XOR-PEN/BRUSH (list (instantiate pen% ["BLACK" 0 'xor]) - (instantiate brush% ["BLACK" 'xor]))) +(define BG-PEN/BRUSH (list (instantiate pen% ["BLACK" 1 'solid]) + (instantiate brush% ["GRAY" 'solid]))) +(define HIGHLIGHT-WIDTH 4) +(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))) - (highlight!))] + (when (and draggable? (not (null-expr? expr))) (highlight!))] [(leave) (unless dragging? (set! current-cell #f) (unhighlight!))] [(left-down)