Merge branch 'master' of pltgit:plt

collects/drracket/private/rep.rkt

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

collects/framework/private/text.rkt

@@ -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
@@ -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?)
-          (cond
+          (define str/snp (cond
-            [(eq? (current-thread) (eventspace-handler-thread eventspace))
-             (error 'write-bytes-proc "cannot write to port on eventspace main thread")]
-            [else
-             (let ([str/snp (cond
                             [(string? special) special]
                             [(is-a? special snip%) special]
-                              [else (format "~s" special)])])
+                            [else (format "~s" special)]))
-               (channel-put 
+          (define to-send (cons str/snp style))
-                write-chan 
+          (cond
-                (cons str/snp style)))])
+            [(eq? (current-thread) (eventspace-handler-thread eventspace))
+             (define return-chan (make-channel))
+             (thread (λ () (channel-put write-chan (cons return-chan to-send))))
+             (do-insertion (channel-get return-chan) #f)]
+            [else
+             (channel-put write-chan (cons #f to-send))])
           #t))
       
       (let* ([add-standard

collects/lang/htdp-langs.rkt

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

collects/meta/web/download/data.rkt

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

collects/meta/web/download/installers.txt

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

collects/meta/web/www/index.rkt

@@ -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))])
+               (let ([t (sierpinski (- n 1))])
-                   (above next (beside next next)))))}
+                 (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

collects/planet/planet.scrbl

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

collects/planet/private/cmdline-tool.rkt

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

collects/planet/private/planet-shared.rkt

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

collects/planet/util.rkt

@@ -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) 
+   (lambda (row) (not (matching-link? row)))
-     (not (points-to? row pkg-name (list owner) maj min)))
    (lambda (row) 
      (let ([p (row->package row)])
        (when p

collects/scribblings/framework/text.scrbl

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

collects/scribblings/tools/language.scrbl

@@ -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
+Calling this method should not escape. 
-try to escape). DrRacket calls this method in a @racket[parameterize]
+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
+The @scheme[run-on-user-thread] arguments accepts thunks and
-runs them on the user's eventspace's main thread. These
+runs them on the user's eventspace's main thread. 
-thunks must not raise an exceptions (or DrRacket itself will
+The output ports are not yet
-get stuck). In addition, 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?)])

collects/scribblings/tools/rep.scrbl

@@ -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,7 +121,11 @@ 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.
   
 }
 

collects/tests/framework/main.rkt

@@ -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 "   saving prefs file ~a\n" preferences-file)
-  (debug-printf admin "                        to ~s\n" old-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 "   restoring prefs file ~a\n" old-preferences-file)
-  (debug-printf admin "                           to ~s\n" 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)
 

collects/tests/framework/test-suite-utils.rkt

@@ -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))))
+        (queue-callback (lambda () (channel-put c (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) (list 'normal (thunk))))))
-        (channel-get c)))))
+        (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:"))

collects/tests/framework/text.rkt

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

collects/tests/racket/place-channel.rktl

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

collects/tests/stepper/manual-tests.txt

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

collects/texpict/private/mrpict-extra.rkt

@@ -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)]
+                            [width (* (pict-width p) (unbox xs))]
-                            [height (pict-height p)]
+                            [height (* (pict-height p) (unbox ys))]
                             [output s])])
                (send dc start-doc "pict")
                (send dc start-page)

src/racket/src/places.c

@@ -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);
     }
-    {
+    scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, args[1]);
-      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);
-    }
   }
   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);
     }
-    {
+    return scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch);
-      void *msg_memory = NULL;
-      mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory);
-      return scheme_places_deserialize(mso, msg_memory);
-    }
   }
   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,8 +1519,9 @@ 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;
   }
@@ -1504,26 +1529,18 @@ static int scheme_place_channel_ready(Scheme_Object *so) {
     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);
+    msg = scheme_place_async_try_recv(ch);
-    {
-      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) break;
     else {
       void *signaldescr;