Merge branch 'master' of pltgit:plt
This commit is contained in:
commit
a98553f99b
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?)
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?])
|
||||
|
|
|
@ -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)])
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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).
|
||||
|
|
|
@ -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?)])
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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:"))
|
||||
|
|
|
@ -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)))))))
|
||||
|
|
|
@ -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)
|
||||
)
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue
Block a user