suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of pltgit:plt

Browse Source
This commit is contained in:
James Swaine 2011-02-14 14:02:47 -06:00
commit f9c12f9e58
30 changed files with 451 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/2htdp/tests/test-image.rkt
View File

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

53
collects/drracket/drracket.rkt
View File

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

37
collects/games/gcalc/gcalc.rkt
View File

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

3
collects/lang/htdp-langs.rkt
View File

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

11
collects/meta/dist-specs.rkt
View File

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

4
collects/mred/private/wx/cocoa/queue.rkt
View File

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

9
collects/racket/contract/private/base.rkt
View File

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

9
collects/racket/contract/private/blame.rkt
View File

@ -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)
" "
",")

6
collects/racket/contract/private/legacy.rkt
View File

@ -21,8 +21,7 @@
name
(unpack-blame pos)
"<<unknown party>>"
#t
"<<unknown party>>")
#t)
x
fmt
args))
@ -59,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 ]

28
collects/racket/contract/private/provide.rkt
View File

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

2
collects/racket/draw/private/ps-setup.rkt
View File

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

6
collects/racket/private/misc.rkt
View File

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

2
collects/scribble/eval.rkt
View File

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

19
collects/scribblings/draw/dc-intf.scrbl
View File

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

7
collects/scribblings/draw/dc-path-class.scrbl
View File

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

7
collects/scribblings/draw/ps-setup-class.scrbl
View File

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

8
collects/scribblings/draw/region-class.scrbl
View File

@ -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<%>].

4
collects/scribblings/raco/setup.scrbl
View File

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

4
collects/scribblings/reference/stx-patterns.scrbl
View File

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

4
collects/slideshow/initial-ones.rkt
View File

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

6
collects/slideshow/tutorial-show.rkt
View File

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

209
collects/tests/racket/contract-test.rktl
View File

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

21
collects/tests/racket/stx.rktl
View File

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

4
collects/tests/run-automated-tests.rkt
View File

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

35
collects/tests/scribble/docs.rkt Normal file
View File

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

21
collects/tests/scribble/docs/print-lines.scrbl Normal file
View File

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

18
collects/tests/scribble/docs/print-lines.txt Normal file
View File

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

10
doc/release-notes/racket/Draw_and_GUI_5_1.txt
View File

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

12
src/configure vendored
View File

@ -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"

12
src/racket/configure.ac
View File

@ -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"