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

.

Browse Source 
original commit: b810960833dcb3421107d8b69f38c93c3819bf9f
This commit is contained in:
Matthew Flatt 1999-08-02 16:46:16 +00:00
parent db06ad192f
commit d1e695c9cf
1 changed files with 33 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/mred/wrap/mred.ss
View File

@ -5101,3 +5101,36 @@
(error 'get-window-text-extent "couldn't allocate sizing bitmap")) (error 'get-window-text-extent "couldn't allocate sizing bitmap"))
(let-values ([(w h d a) (send dc get-text-extent string font)]) (let-values ([(w h d a) (send dc get-text-extent string font)])
(values (inexact->exact w) (inexact->exact h)))]))) (values (inexact->exact w) (inexact->exact h)))])))
(define (get-family-builtin-face family)
(unless (memq family '(default decorative roman script swiss modern system))
(raise-type-error 'get-default-face "family symbol" family))
(case (system-type)
[(unix)
(case family
[(system) "-b&h-lucida"]
[(default) "-b&h-lucida"]
[(roman) "-adobe-times"]
[(decorative) "-adobe-helvetica"]
[(modern) "-adobe-courier"]
[(swiss) "-b&h-lucida"]
[(script) "-itc-zapfchancery"])]
[(windows)
(case family
[(system) "MS Sans Serif"]
[(default) "MS Sans Serif"]
[(roman) "Times New Roman"]
[(decorative) "Arial"]
[(modern) "Courier New"]
[(swiss) "Arial"]
[(script) "Arial"])]
[(macos)
(case family
[(system) "systemfont"]
[(default) "applicationfont"]
[(roman) "times"]
[(decorative) "geneva"]
[(modern) "monaco"]
[(swiss) "helvetica"]
[(script) "geneva"])]))