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

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