suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix `font%' amnipulation to work in atomic mode

Browse Source
This commit is contained in:
Matthew Flatt 2012-08-28 17:27:14 -06:00
parent dba3c14746
commit 003613395d
3 changed files with 38 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/racket/draw/private/color.rkt
View File

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

32
collects/racket/draw/private/font-dir.rkt
View File

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

16
src/racket/src/sema.c
View File

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