From 003613395d8efd59c1d51efe3f46dd3601842680 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 28 Aug 2012 17:27:14 -0600
Subject: [PATCH] fix `font%' amnipulation to work in atomic mode

---
 collects/racket/draw/private/color.rkt    |  7 ++---
 collects/racket/draw/private/font-dir.rkt | 32 +++++++++++++----------
 src/racket/src/sema.c                     | 16 ++++++++++++
 3 files changed, 38 insertions(+), 17 deletions(-)

diff --git a/collects/racket/draw/private/color.rkt b/collects/racket/draw/private/color.rkt
index 59b31ff3d9..b8e229d27f 100644
--- a/collects/racket/draw/private/color.rkt
+++ b/collects/racket/draw/private/color.rkt
@@ -1,7 +1,8 @@
 #lang racket/base
 (require racket/class
          racket/contract/base
-         (except-in "syntax.rkt" real-in integer-in))
+         (except-in "syntax.rkt" real-in integer-in)
+         "lock.rkt")
 
 (provide color%
          make-color
@@ -110,13 +111,13 @@
     (super-new)
     (define/public (find-color name)
       (let ([name (string-downcase name)])
-        (or (hash-ref color-objects name #f)
+        (or (atomically (hash-ref color-objects name #f))
             (let ([v (hash-ref colors (string-foldcase name) #f)])
               (if v
                   (let ([c (new color%)])
                     (send c set (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))
                     (send c set-immutable)
-                    (hash-set! color-objects name c)
+                    (atomically (hash-set! color-objects name c))
                     c)
                   #f)))))
     (define/public (get-names)
diff --git a/collects/racket/draw/private/font-dir.rkt b/collects/racket/draw/private/font-dir.rkt
index 958e0df3f3..de26f57173 100644
--- a/collects/racket/draw/private/font-dir.rkt
+++ b/collects/racket/draw/private/font-dir.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/contract/base
+         "lock.rkt"
          "font-syms.rkt")
 
 (provide font-name-directory<%>
@@ -16,11 +17,12 @@
     (define screen-table (make-hash))
 
     (define/private (intern val)
-      (hash-ref table val (lambda ()
-                            (let ([n (add1 (hash-count table))])
-                              (hash-set! table val n)
-                              (hash-set! reverse-table n val)
-                              n))))
+      (atomically
+       (hash-ref table val (lambda ()
+                             (let ([n (add1 (hash-count table))])
+                               (hash-set! table val n)
+                               (hash-set! reverse-table n val)
+                               n)))))
 
     (for-each (lambda  (s) (intern s))
               '(default decorative roman script
@@ -33,17 +35,17 @@
       (intern (cons name family)))
 
     (define/public (get-face-name id)
-      (let ([v (hash-ref reverse-table id #f)])
+      (let ([v (atomically (hash-ref reverse-table id #f))])
         (and v (pair? v) (car v))))
     
     (define/public (get-family id)
-      (let ([v (hash-ref reverse-table id #f)])
+      (let ([v (atomically (hash-ref reverse-table id #f))])
         (or (and (pair? v) (cdr v))
             (and (symbol? v) v)
             'default)))
 
     (define/public (get-font-id name family)
-      (hash-ref table (cons string family) 0))
+      (atomically (hash-ref table (cons string family) 0)))
 
     (define/private (default-font s)
       (case s
@@ -68,26 +70,28 @@
                 [else "Sans"])]))
 
     (define/public (get-post-script-name id w s)
-      (let ([s (or (hash-ref ps-table (list id w s) #f)
-                   (hash-ref reverse-table id #f))])
+      (let ([s (atomically
+                (or (hash-ref ps-table (list id w s) #f)
+                    (hash-ref reverse-table id #f)))])
         (cond
          [(pair? s) (car s)]
          [(symbol? s) (default-font s)]
          [else "Serif"])))
 
     (define/public (get-screen-name id w s)
-      (let ([s (or (hash-ref screen-table (list id w s) #f)
-                   (hash-ref reverse-table id #f))])
+      (let ([s (atomically
+                (or (hash-ref screen-table (list id w s) #f)
+                    (hash-ref reverse-table id #f)))])
         (cond
          [(pair? s) (car s)]
          [(symbol? s) (default-font s)]
          [else "Serif"])))
 
     (define/public (set-post-script-name id w s name)
-      (hash-set! ps-table (list id w s) name))
+      (atomically (hash-set! ps-table (list id w s) name)))
 
     (define/public (set-screen-name id w s name)
-      (hash-set! screen-table (list id w s) name))
+      (atomically (hash-set! screen-table (list id w s) name)))
 
     (super-new)))
 
diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c
index e4f4cf9cf1..98219a3dff 100644
--- a/src/racket/src/sema.c
+++ b/src/racket/src/sema.c
@@ -649,6 +649,22 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci
   } else {
     int start_pos;
 
+#if 0
+    /* Use the "immutable" flag bit on a semaphore to check for
+       inconsistent use in atomic and non-atomic modes, which
+       can lead to an attempt to suspend in atomic mode. */
+    if ((n == 1) && SCHEME_SEMAP(o[0])) {
+      if (!do_atomic) {
+        SCHEME_SET_IMMUTABLE(o[0]);
+      } else if (SCHEME_IMMUTABLEP(o[0])) {
+        if (!on_atomic_timeout
+            || (do_atomic > atomic_timeout_atomic_level)) {
+          scheme_signal_error("using a seaphore in both atomic and non-atomic mode");
+        }
+      }
+    }
+#endif
+
     if (n > 1) {
       if (syncing)
 	start_pos = syncing->start_pos;