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-15 22:58:08 -06:00
commit a98553f99b
20 changed files with 397 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/drracket/private/rep.rkt
View File

@ -1312,7 +1312,7 @@ TODO
(let ([run-on-user-thread (lambda (t)
(queue-user/wait
(λ ()
(with-handlers ((exn? (λ (x) (printf "~s\n" (exn-message x)))))
(with-handlers ((exn? (λ (x) (oprintf "~s\n" (exn-message x)))))
(t)))))])
run-on-user-thread))
@ -1653,10 +1653,39 @@ TODO
(let ([lang (drracket:language-configuration:language-settings-language user-language-settings)]
[drr-evtspace (current-eventspace)]
[s (make-semaphore 0)])
(define-values (sp-err-other-end sp-err) (make-pipe))
(define-values (sp-out-other-end sp-out) (make-pipe))
(define io-chan (make-channel))
;; collect the IO to replay later
(thread
(λ ()
(let loop ([ports (list sp-err-other-end sp-out-other-end)]
[io '()])
(cond
[(null? ports) (channel-put io-chan io)]
[else
(apply sync
(map (λ (port) (handle-evt
port
(λ (_)
(define byte (read-byte port))
(if (eof-object? byte)
(loop (remq port ports) io)
(loop ports (cons (cons port byte)
io))))))
ports))]))))
(run-in-evaluation-thread
(λ ()
(let/ec k
(parameterize ([error-escape-handler (λ () (k (void)))])
;; we set the io ports here to ones that just collect the data
;; since we're blocking the eventspace handler thread (and thus IO to
;; the user's ports can deadlock)
(parameterize ([error-escape-handler (λ () (k (void)))]
[current-output-port sp-out]
[current-error-port sp-err])
(cond
;; this is for backwards compatibility; drracket used to
;; expect this method to be a thunk (but that was a bad decision)
@ -1667,7 +1696,21 @@ TODO
;; this is the backwards compatible case.
(send lang first-opened)])))
(semaphore-post s)))
(semaphore-wait s))
;; wait for the first-opened method to finish up
(semaphore-wait s)
;; close the output ports to get the above thread to terminate
(close-output-port sp-err)
(close-output-port sp-out)
;; duplicate it over to the user's ports, now that there is
;; no danger of deadlock
(for ([i (in-list (reverse (channel-get io-chan)))])
(write-byte (cdr i)
(if (eq? (car i) sp-err-other-end)
(get-err-port)
(get-out-port)))))
(send context enable-evaluation)
(end-edit-sequence)

65
collects/framework/private/text.rkt
View File

@ -1825,6 +1825,9 @@
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500)
;; this value (4096) is also mentioned in the test suite (collects/tests/framework/test.rkt)
;; so if you change it, be sure to change things over there too
(define output-buffer-full 4096)
(define-local-member-name
@ -1873,6 +1876,17 @@
(send value-sd set-delta-foreground (make-object color% 0 0 175))
(create-style-name value-style-name value-sd)))
;; data : any
;; to-insert-chan : (or/c #f channel)
;; if to-insert-chan is a channel, this means
;; the eventspace handler thread is the one that
;; is initiating the communication, so instead of
;; queueing a callback to do the update of the editor,
;; just send the work back directly and it will be done
;; syncronously there. If it is #f, then we queue a callback
;; to do the work
(define-struct data/chan (data to-insert-chan))
(define ports-mixin
(mixin (wide-snip<%>) (ports<%>)
(inherit begin-edit-sequence
@ -2241,7 +2255,7 @@
(after-io-insertion))))
(define/public (after-io-insertion) (void))
(define output-buffer-thread
(let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(thread
@ -2257,13 +2271,16 @@
(alarm-evt (+ last-flush msec-timeout))
(λ (_)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
;; we always queue the work here since the always event means no one waits for the callback
(queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt
flush-chan
(λ (return-evt)
(λ (return-evt/to-insert-chan)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes return-evt)
(if (channel? return-evt/to-insert-chan)
(channel-put return-evt/to-insert-chan viable-bytes)
(queue-insertion viable-bytes return-evt/to-insert-chan))
(loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt
clear-output-chan
@ -2271,16 +2288,22 @@
(loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt
write-chan
(λ (pr)
(λ (pr-pr)
(define return-chan (car pr-pr))
(define pr (cdr pr-pr))
(let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond
[((queue-size text-to-insert) . < . output-buffer-full)
(when return-chan
(channel-put return-chan '()))
(loop new-text-to-insert last-flush)]
[else
(let ([chan (make-channel)])
(let-values ([(viable-bytes remaining-queue)
(split-queue converter new-text-to-insert)])
(queue-insertion viable-bytes (channel-put-evt chan (void)))
(if return-chan
(channel-put return-chan viable-bytes)
(queue-insertion viable-bytes (channel-put-evt chan (void))))
(channel-get chan)
(loop remaining-queue (current-inexact-milliseconds))))]))))))))))
@ -2300,16 +2323,23 @@
(λ (to-write start end block/buffer? enable-breaks?)
(cond
[(= start end) (flush-proc)]
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
[else
(channel-put write-chan (cons (subbytes to-write start end) style))])
(define pair (cons (subbytes to-write start end) style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-channel (make-channel))
(thread (λ () (channel-put write-chan (cons return-channel pair))))
(do-insertion (channel-get return-channel) #f)]
[else
(channel-put write-chan (cons #f pair))])])
(- end start)))
(define (flush-proc)
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'flush-proc "cannot flush port on eventspace main thread")]
(define to-insert-channel (make-channel))
(thread (λ () (channel-put flush-chan to-insert-channel)))
(do-insertion (channel-get to-insert-channel) #f)]
[else
(sync
(nack-guard-evt
@ -2327,17 +2357,18 @@
(define (make-write-special-proc style)
(λ (special can-buffer? enable-breaks?)
(define str/snp (cond
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)]))
(define to-send (cons str/snp style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
(define return-chan (make-channel))
(thread (λ () (channel-put write-chan (cons return-chan to-send))))
(do-insertion (channel-get return-chan) #f)]
[else
(let ([str/snp (cond
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)])])
(channel-put
write-chan
(cons str/snp style)))])
(channel-put write-chan (cons #f to-send))])
#t))
(let* ([add-standard

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

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

3
collects/meta/web/download/data.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(define -versions+dates-
'(["5.0.2" "November 2010"]
'(["5.1" "February 2011"]
["5.0.2" "November 2010"]
["5.0.1" "August 2010"]
["5.0" "June 2010"]
["4.2.5" "April 2010"]

20
collects/meta/web/download/installers.txt
View File

@ -64,3 +64,23 @@
16M 5.0/racket/racket-5.0-src-mac.dmg
16M 5.0/racket/racket-5.0-src-unix.tgz
20M 5.0/racket/racket-5.0-src-win.zip
11M 5.1/racket-textual/racket-textual-5.1-bin-i386-linux-f12.sh
11M 5.1/racket-textual/racket-textual-5.1-bin-i386-linux-ubuntu-jaunty.sh
11M 5.1/racket-textual/racket-textual-5.1-bin-i386-osx-mac.dmg
7.6M 5.1/racket-textual/racket-textual-5.1-bin-i386-win32.exe
11M 5.1/racket-textual/racket-textual-5.1-bin-ppc-darwin.sh
11M 5.1/racket-textual/racket-textual-5.1-bin-ppc-osx-mac.dmg
11M 5.1/racket-textual/racket-textual-5.1-bin-x86_64-linux-f14.sh
5.8M 5.1/racket-textual/racket-textual-5.1-src-mac.dmg
5.7M 5.1/racket-textual/racket-textual-5.1-src-unix.tgz
5.8M 5.1/racket-textual/racket-textual-5.1-src-win.zip
50M 5.1/racket/racket-5.1-bin-i386-linux-f12.sh
50M 5.1/racket/racket-5.1-bin-i386-linux-ubuntu-jaunty.sh
51M 5.1/racket/racket-5.1-bin-i386-osx-mac.dmg
32M 5.1/racket/racket-5.1-bin-i386-win32.exe
49M 5.1/racket/racket-5.1-bin-ppc-darwin.sh
52M 5.1/racket/racket-5.1-bin-ppc-osx-mac.dmg
50M 5.1/racket/racket-5.1-bin-x86_64-linux-f14.sh
16M 5.1/racket/racket-5.1-src-mac.dmg
16M 5.1/racket/racket-5.1-src-unix.tgz
18M 5.1/racket/racket-5.1-src-win.zip

8
collects/meta/web/www/index.rkt
View File

@ -89,11 +89,11 @@
(graphical-example ; ---------------------------------------------
@code{#lang racket ; A picture
(require 2htdp/image)
(let sierpinski ([n 6])
(let sierpinski ([n 8])
(if (zero? n)
(triangle 2 'solid 'red)
(let ([next (sierpinski (- n 1))])
(above next (beside next next)))))}
(triangle 2 'solid 'red)
(let ([t (sierpinski (- n 1))])
(freeze (above t (beside t t))))))}
@desc{The @elemcode{2htdp/image} library provides easy-to-use functions
for constructing images, and DrRacket can display an image result as
easily as it can display a number result. In this case, a

11
collects/planet/planet.scrbl
View File

@ -400,10 +400,13 @@ package specifier and the specified directory name.
@subsection[#:tag "unlink"]{@exec{unlink}}
Usage:
@commandline{raco planet unlink <owner> <pkg> <maj> <min>}
@commandline{raco planet unlink [ <option> ] <owner> <pkg> <maj> <min>}
Remove any development link (see @secref{devlinks}) associated with
the given package.
@exec{<option>} can only be:
@itemize[@item{@exec{-q, --quiet}: don't signal an error on nonexistent links}]
@subsection[#:tag "fetch"]{@exec{fetch}}
Usage:
@ -696,11 +699,15 @@ The @racket[pkg] argument must end with the string @racket[".plt"].
@defproc[(remove-hard-link [owner string?]
[pkg (and/c string? #rx"[.]plt")]
[maj natural-number/c]
[min natural-number/c])
[min natural-number/c]
[#:quiet? quiet? boolean? #false])
any]{
Removes any hard link that may be associated with the given package.
The @racket[pkg] argument must end with the string @racket[".plt"].
The @racket[maj] and @racket[min] arguments must be integers. This
procedure signals an error if no such link exists, unless
@racket[#:quiet?] is @racket[#true].
}
@defproc[(resolve-planet-path [spec quoted-planet-require-spec?])

11
collects/planet/private/cmdline-tool.rkt
View File

@ -21,6 +21,7 @@ PLANNED FEATURES:
(define erase? (make-parameter #f))
(define displayer (make-parameter (λ () (show-installed-packages))))
(define quiet-unlink? (make-parameter #f))
(define (start raco?)
@ -85,10 +86,12 @@ Install local file <plt-file> into the planet cache as though it had been downlo
(add-hard-link-cmd owner pkg maj min path))]
["unlink" "remove a package development link"
"\nRemove development link associated with the given package"
#:once-each
[("-q" "--quiet") "don't signal an error on nonexistent links" (quiet-unlink? #t)]
#:args (owner pkg maj min)
(begin
(verify-package-name pkg)
(remove-hard-link-cmd owner pkg maj min))]
(remove-hard-link-cmd owner pkg maj min (quiet-unlink?)))]
["fetch" "download a package file without installing it"
"\nDownload the given package file without installing it"
#:args (owner pkg maj min)
@ -264,10 +267,12 @@ This command does not unpack or install the named .plt file."
(fail "Invalid major/minor version"))
(add-hard-link ownerstr pkgstr maj min path)))
(define (remove-hard-link-cmd ownerstr pkgstr majstr minstr)
(define (remove-hard-link-cmd ownerstr pkgstr majstr minstr quiet?)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)])
(remove-hard-link ownerstr pkgstr maj min)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(remove-hard-link ownerstr pkgstr maj min #:quiet? quiet?)))
(define (get-download-url ownerstr pkgstr majstr minstr)
(let ([fps (params->full-pkg-spec ownerstr pkgstr majstr minstr)])

2
collects/planet/private/planet-shared.rkt
View File

@ -197,7 +197,7 @@ Various common pieces of code that both the client and server need to access
original-table))])
(save-hard-link-table new-table))))
;; filter-link-table! : (row -> boolean) -> void
;; filter-link-table! : (row -> boolean) (row -> any/c) -> void
;; removes all rows from the hard link table that don't match the given predicate.
;; also updates auxiliary datastructures that might have dangling pointers to
;; the removed links

16
collects/planet/util.rkt
View File

@ -68,7 +68,9 @@
[add-hard-link
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c path? void?)]
[remove-hard-link
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)]
(->* (string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c)
(#:quiet? boolean?)
void?)]
[remove-pkg
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)]
[erase-pkg
@ -766,12 +768,16 @@
(path->string path))))
(add-hard-link! pkg-name (list owner) maj min path))
;; remove-hard-link : string string num num -> void
;; remove-hard-link : string string num num (#:quiet boolean) -> void
;; removes any development association from the given package spec
(define (remove-hard-link owner pkg-name maj min)
(define (remove-hard-link owner pkg-name maj min #:quiet? [quiet? #false])
(define (matching-link? row)
(points-to? row pkg-name (list owner) maj min))
(when (and (empty? (filter matching-link? (get-hard-link-table)))
(not quiet?))
(error "no existing links match the given specification"))
(filter-link-table!
(lambda (row)
(not (points-to? row pkg-name (list owner) maj min)))
(lambda (row) (not (matching-link? row)))
(lambda (row)
(let ([p (row->package row)])
(when p

7
collects/scribblings/framework/text.scrbl
View File

@ -818,7 +818,7 @@
}
@definterface[text:ports<%> ()]{
Classes implementing this interface (via the associated
mixin) support input and output ports that read from the
mixin) support input and output ports that read from and to the
editor.
There are two input ports: the normal input port just reads
@ -826,6 +826,11 @@
inserts an editor snip into this text and uses input typed
into the box as input into the port.
There are three output ports, designed to match stdout, stderr,
and a special port for printing values. The only difference
between them is the output is rendered in different colors
when it comes in via the different ports.
They create three threads to mediate access to the input and
output ports (one for each input port and one for all of the
output ports).

30
collects/scribblings/tools/language.scrbl
View File

@ -440,7 +440,7 @@ This method is the same as
}
@defmethod[(on-execute [settings settings]
[run-in-user-thread ((-> void) -> void)])
[run-on-user-thread ((-> void) -> void)])
vod]{
This method is the same as
@method[drracket:language:language<%> on-execute].
@ -628,7 +628,7 @@ default settings obtained via
}
@defmethod*[([(first-opened [settings settings]) void?])]{
@defmethod[(first-opened [settings settings]) void?]{
This method is called after the language is initialized, but
no program has yet been run. It is called from the user's
@ -637,8 +637,8 @@ eventspace's main thread.
See also
@method[drracket:rep:text% initialize-console].
Calling this method should not raise an exception (or otherwise
try to escape). DrRacket calls this method in a @racket[parameterize]
Calling this method should not escape.
DrRacket calls this method in a @racket[parameterize]
where the @racket[error-escape-handler] is set to an escaping
continuation that continues initializing the interactions window.
Thus, raising an exception will report the error in the user's
@ -646,7 +646,14 @@ interactions window as if this were a bug in the user's program.
Escaping in any other way, however, can cause DrRacket to fail
to start up.
Contrary to the method contract space, DrRacket will also invoke this
Also, IO system will deadlock if the @racket[first-opened] method
does IO on the user's IO ports, so the calling context of
@racket[first-opened] sets the @racket[current-output-port] and
@racket[current-error-port] to ports that just collect all of the
IO that happened and then replay it later in the initialization of the
user's program.
Contrary to the method contract spec, DrRacket will also invoke this
method if it has zero arguments, passing nothing; the zero argument
version is for backwards compatibility and is not recommended.
@ -932,7 +939,7 @@ the settings for this language.
}
@defmethod[(on-execute [settings settings]
[run-in-user-thread ((-> any) -> any)])
[run-on-user-thread ((-> any) -> any)])
any]{
The @scheme[on-execute] method is called on DrRacket's
eventspace's main thread before any evaluation happens
@ -1015,13 +1022,16 @@ that error message into the definitions window.}
]
The @scheme[run-in-user-thread] arguments accepts thunks and
runs them on the user's eventspace's main thread. These
thunks must not raise an exceptions (or DrRacket itself will
get stuck). In addition, the output ports are not yet
The @scheme[run-on-user-thread] arguments accepts thunks and
runs them on the user's eventspace's main thread.
The output ports are not yet
functioning, so print outs should be directed to the
original DrRacket output port, if necessary.
This thunk is wrapped in a @racket[with-handlers] that
catches all exceptions matching @racket[exn:fail?] and
then prints out the exception message to the original
output port of the DrRacket process.
}
@defmethod[(order-manuals [manuals (listof bytes?)])

12
collects/scribblings/tools/rep.scrbl
View File

@ -111,7 +111,9 @@ The @scheme[complete-program?] argument determines if the
how it finishes).
}
@defmethod[#:mode augment (on-execute [run-on-user-thread (-> any)]) any]{
@defmethod[(on-execute [run-on-user-thread (-> any)]) any]{
Use @scheme[run-on-user-thread] to initialize the user's parameters, etc.
Called from the DrRacket thread after the language's
@method[drracket:language:language<%> on-execute]
@ -119,8 +121,12 @@ The @scheme[complete-program?] argument determines if the
special values have been setup (the ones registered
via @scheme[drracket:language:add-snip-value]).
Use @scheme[run-on-user-thread] to initialize the user's parameters, etc.
Do not print to @racket[current-output-port] or @racket[current-error-port]
during the dynamic extent of the thunk passed to @racket[run-on-user-thread] becuase
this can deadlock. IO is still, in general, fine, but the @racket[current-error-port]
and @racket[current-output-port] are set to the user's ports that print
into the interactions window and are not in a good state during those calls.
}
@defmethod[(get-error-range)

14
collects/tests/framework/main.rkt
View File

@ -58,12 +58,12 @@
`("Names of the tests; defaults to all non-interactive tests"))
(when (file-exists? preferences-file)
(debug-printf admin " saving preferences file ~s\n" preferences-file)
(debug-printf admin " to ~s\n" old-preferences-file)
(debug-printf admin " saving prefs file ~a\n" preferences-file)
(debug-printf admin " to ~a\n" old-preferences-file)
(if (file-exists? old-preferences-file)
(debug-printf admin " backup preferences file exists, using that one\n")
(debug-printf admin " backup prefs file exists, using that one\n")
(begin (copy-file preferences-file old-preferences-file)
(debug-printf admin " saved preferences file\n"))))
(debug-printf admin " saved prefs file\n"))))
(define jumped-out-tests '())
@ -96,12 +96,12 @@
(debug-printf schedule "ran ~a test~a\n" number-of-tests (if (= 1 number-of-tests) "" "s"))
(when (file-exists? old-preferences-file)
(debug-printf admin " restoring preferences file ~s\n" old-preferences-file)
(debug-printf admin " to ~s\n" preferences-file)
(debug-printf admin " restoring prefs file ~a\n" old-preferences-file)
(debug-printf admin " to ~a\n" preferences-file)
(delete-file preferences-file)
(copy-file old-preferences-file preferences-file)
(delete-file old-preferences-file)
(debug-printf admin " restored preferences file\n"))
(debug-printf admin " restored prefs file\n"))
(shutdown-listener)

7
collects/tests/framework/test-suite-utils.rkt
View File

@ -144,8 +144,11 @@
(send-sexp-to-mred
`(let ([thunk (lambda () ,sexp)] ;; low tech hygiene
[c (make-channel)])
(queue-callback (lambda () (channel-put c (thunk))))
(channel-get c)))))
(queue-callback (lambda () (channel-put c (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) (list 'normal (thunk))))))
(let ([res (channel-get c)])
(if (eq? (list-ref res 0) 'normal)
(list-ref res 1)
(raise (list-ref res 1))))))))
(define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:"))

142
collects/tests/framework/text.rkt
View File

@ -196,3 +196,145 @@
(send dc clear)
(send t print-to-dc dc 1)
'no-error))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; text:ports
;;
;; there is an internal buffer of this size, so writes that are larger and smaller are interesting
(define buffer-size 4096)
(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))]
[non-ascii-str "λαβ一二三四五"])
(define (do/separate-thread str mtd)
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t ,mtd)]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(display ,str op)
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position)))))
(test
'text:ports%.1
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-out-port)))
(test
'text:ports%.2
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-out-port)))
(test
'text:ports%.3
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-out-port)))
(test
'text:ports%.4
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-err-port)))
(test
'text:ports%.5
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-err-port)))
(test
'text:ports%.6
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-err-port)))
(test
'text:ports%.7
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-value-port)))
(test
'text:ports%.8
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-value-port)))
(test
'text:ports%.9
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-value-port)))
;; display the big string, one char at a time
(test
'text:ports%.10
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[big-str ,big-str]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(let loop ([i 0])
(when (< i (string-length big-str))
(display (string-ref big-str i) op)
(loop (+ i 1))))
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position))))))
;; the next tests test the interaction when the current
;; thread is the same as the handler thread of the eventspace
;; where the text was created
(test
'text:ports%.thd1
(λ (x) (equal? x "abc"))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[exn #f])
(display "abc" op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd2
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,big-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd3
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd4
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position)))))))

2
collects/tests/racket/place-channel.rktl
View File

@ -101,7 +101,7 @@ END
(define-values (pc5 pc6) (place-channel))
(place-channel-send pl pc5)
(test "Ready5" sync (handle-evt pc6 (lambda (p) (place-channel-recv p))))
(test "Ready5" sync pc6)
(place-wait pl)
)

2
collects/tests/stepper/manual-tests.txt
View File

@ -17,5 +17,3 @@ Try programs which print snips (print-convert-test.ss)
try programs that contain test cases; make sure that the popups behave sensibly.
Try jumping to the end on a program with an error.
** jumping to end when already at end doesn't behave properly ("no step
matching that criterion")

9
collects/texpict/private/mrpict-extra.rkt
View File

@ -457,12 +457,15 @@
(send bm save-file s 'png)
(get-output-bytes s)))]
[(eps-bytes pdf-bytes)
(let ([s (open-output-bytes)])
(let ([s (open-output-bytes)]
[xs (box 1)]
[ys (box 1)])
(send (current-ps-setup) get-scaling xs ys)
(let ([dc (new (if (eq? format 'eps-bytes) post-script-dc% pdf-dc%)
[interactive #f]
[as-eps #t]
[width (pict-width p)]
[height (pict-height p)]
[width (* (pict-width p) (unbox xs))]
[height (* (pict-height p) (unbox ys))]
[output s])])
(send dc start-doc "pict")
(send dc start-page)

85
src/racket/src/places.c
View File

@ -26,11 +26,12 @@ static Scheme_Object *scheme_place_channel(int argc, Scheme_Object *args[]);
static Scheme_Place_Async_Channel *scheme_place_async_channel_create();
static Scheme_Place_Bi_Channel *scheme_place_bi_channel_create();
static Scheme_Place_Bi_Channel *scheme_place_bi_peer_channel_create(Scheme_Place_Bi_Channel *orig);
static int scheme_place_channel_ready(Scheme_Object *so);
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo);
static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o, void *msg_memory);
static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch, void **msg_memory);
static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch);
static Scheme_Object *scheme_places_deep_copy_to_master(Scheme_Object *so);
/* Scheme_Object *scheme_places_deep_copy(Scheme_Object *so); */
@ -1186,7 +1187,6 @@ Scheme_Object *scheme_places_deserialize(Scheme_Object *so, void *msg_memory) {
Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
if (argc == 2) {
Scheme_Object *mso;
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
@ -1198,11 +1198,7 @@ Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
ch = NULL;
scheme_wrong_type("place-channel-send", "place-channel", 0, argc, args);
}
{
void *msg_memory = NULL;
mso = scheme_places_serialize(args[1], &msg_memory);
scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, mso, msg_memory);
}
scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, args[1]);
}
else {
scheme_wrong_count_m("place-channel-send", 2, 2, argc, args, 0);
@ -1212,7 +1208,6 @@ Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
if (argc == 1) {
Scheme_Object *mso;
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
@ -1224,11 +1219,7 @@ Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
ch = NULL;
scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
}
{
void *msg_memory = NULL;
mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory);
return scheme_places_deserialize(mso, msg_memory);
}
return scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch);
}
else {
scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
@ -1437,8 +1428,13 @@ static Scheme_Object *scheme_place_channel_p(int argc, Scheme_Object *args[])
return SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type) ? scheme_true : scheme_false;
}
static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o, void *msg_memory) {
static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *uo) {
void *msg_memory = NULL;
Scheme_Object *o;
int cnt;
o = scheme_places_serialize(uo, &msg_memory);
mzrt_mutex_lock(ch->lock);
{
cnt = ch->count;
@ -1482,6 +1478,34 @@ static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Objec
}
}
static Scheme_Object *scheme_place_async_try_recv(Scheme_Place_Async_Channel *ch) {
Scheme_Object *msg = NULL;
void *msg_memory = NULL;
mzrt_mutex_lock(ch->lock);
{
void *signaldescr;
signaldescr = scheme_get_signal_handle();
ch->wakeup_signal = signaldescr;
if (ch->count > 0) { /* GET MSG */
msg = ch->msgs[ch->out];
msg_memory = ch->msg_memory[ch->out];
ch->msgs[ch->out] = NULL;
ch->msg_memory[ch->out] = NULL;
--ch->count;
ch->out = (++ch->out % ch->size);
}
}
mzrt_mutex_unlock(ch->lock);
if (msg) {
return scheme_places_deserialize(msg, msg_memory);
}
return msg;
}
static int scheme_place_async_ch_ready(Scheme_Place_Async_Channel *ch) {
int ready = 0;
mzrt_mutex_lock(ch->lock);
@ -1495,35 +1519,28 @@ static int scheme_place_async_ch_ready(Scheme_Place_Async_Channel *ch) {
return ready;
}
static int scheme_place_channel_ready(Scheme_Object *so) {
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo) {
Scheme_Place_Bi_Channel *ch;
Scheme_Object *msg = NULL;
if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel;
}
else {
ch = (Scheme_Place_Bi_Channel *)so;
}
return scheme_place_async_ch_ready((Scheme_Place_Async_Channel *) ch->recvch);
msg = scheme_place_async_try_recv((Scheme_Place_Async_Channel *) ch->recvch);
if (msg != NULL) {
scheme_set_sync_target(sinfo, msg, NULL, NULL, 0, 0, NULL);
return 1;
}
return 0;
}
static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch, void **msg_memory) {
static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch) {
Scheme_Object *msg = NULL;
while(1) {
mzrt_mutex_lock(ch->lock);
{
if (ch->count > 0) { /* GET MSG */
msg = ch->msgs[ch->out];
*msg_memory = ch->msg_memory[ch->out];
ch->msgs[ch->out] = NULL;
ch->msg_memory[ch->out] = NULL;
--ch->count;
ch->out = (++ch->out % ch->size);
}
}
mzrt_mutex_unlock(ch->lock);
msg = scheme_place_async_try_recv(ch);
if(msg) break;
else {
void *signaldescr;