From 968bf81990a63607ff4a0a52f972ba21deb85347 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 10 Mar 2011 07:34:24 -0700
Subject: [PATCH] win32: fix `play-sound'  by fixing path handling and
 preventing non-async  play from blocking all Racket threads

---
 collects/mred/private/wx/win32/sound.rkt | 25 +++++++++++++++++++-----
 1 file changed, 20 insertions(+), 5 deletions(-)

diff --git a/collects/mred/private/wx/win32/sound.rkt b/collects/mred/private/wx/win32/sound.rkt
index fb526058f9..6d291ec428 100644
--- a/collects/mred/private/wx/win32/sound.rkt
+++ b/collects/mred/private/wx/win32/sound.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require ffi/unsafe
          racket/class
+	 "../../lock.rkt"
          "utils.rkt"
          "types.rkt"
          "const.rkt")
@@ -12,10 +13,24 @@
 
 (define SND_SYNC   #x0000)
 (define SND_ASYNC  #x0001)
+(define SND_NOSTOP #x0010)
+
+(define previous-done-sema #f)
 
 (define (play-sound path async?)
-  (let ([path (simplify-path path #f)])
-    ;; FIXME: sync sound play blocks all Racket threads
-    (PlaySoundW (if (path? path) (path->string path) path)
-                #f
-                (if async? SND_ASYNC SND_SYNC))))
+  (let ([path (simplify-path path #f)]
+	[done (make-semaphore)])
+    (and (let ([p (path->string
+		   (cleanse-path (path->complete-path path)))])
+	   (atomically
+	    (when previous-done-sema (semaphore-post previous-done-sema))
+	    (set! previous-done-sema done)
+	    (PlaySoundW p #f SND_ASYNC)))
+	 (or async?
+	     ;; Implement synchronous playing by polling, where
+	     ;; PlaySound with no sound file and SND_NOSTOP polls.
+	     (let loop ()
+	       (sleep 0.1)
+	       (or (semaphore-try-wait? done)
+		   (PlaySoundW #f #f (bitwise-ior SND_ASYNC SND_NOSTOP))
+		   (loop)))))))