Fixes #2966

[factor.git] / basis / windows / fonts / fonts.factor

diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
old mode 100755 (executable)
new mode 100644 (file)
index b8acf5d..8b09cd2
--- a/basis/windows/fonts/fonts.factor
+++ b/basis/windows/fonts/fonts.factor
@@ -1,19 +1,29 @@
 USING: assocs memoize locals kernel accessors init fonts math
-combinators windows.errors windows.types windows.gdi32 ;
+combinators system-info.windows windows.errors windows.types
+windows.gdi32 ;
 IN: windows.fonts
 
-: windows-font-name ( string -- string' )
+MEMO: windows-fonts ( -- fonts )
+    windows-major 6 >=
+    H{
+        { "sans-serif" "Segoe UI" }
+        { "serif" "Cambria" }
+        { "monospace" "Consolas" }
+    }
     H{
         { "sans-serif" "Tahoma" }
         { "serif" "Times New Roman" }
         { "monospace" "Courier New" }
-    } ?at drop ;
+    } ? ;
+
+: windows-font-name ( string -- string' )
+    windows-fonts ?at drop ;
 
-MEMO:: (cache-font) ( font -- HFONT )
-    font size>> neg ! nHeight
+MEMO:: (cache-font) ( name size bold? italic? -- HFONT )
+    size neg ! nHeight
     0 0 0 ! nWidth, nEscapement, nOrientation
-    font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
-    font italic?>> TRUE FALSE ? ! fdwItalic
+    bold? FW_BOLD FW_NORMAL ? ! fnWeight
+    italic? TRUE FALSE ? ! fdwItalic
     FALSE ! fdwUnderline
     FALSE ! fdWStrikeOut
     DEFAULT_CHARSET ! fdwCharSet
@@ -21,13 +31,18 @@ MEMO:: (cache-font) ( font -- HFONT )
     CLIP_DEFAULT_PRECIS ! fdwClipPrecision
     DEFAULT_QUALITY ! fdwQuality
     DEFAULT_PITCH ! fdwPitchAndFamily
-    font name>> windows-font-name
+    name windows-font-name
     CreateFont
     dup win32-error=0/f ;
 
-: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
+: cache-font ( font -- HFONT )
+    { [ name>> ] [ size>> ] [ bold?>> ] [ italic?>> ] } cleave
+    (cache-font) ;
 
-[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+STARTUP-HOOK: [
+    \ (cache-font) reset-memoized
+    \ windows-fonts reset-memoized
+]
 
 : TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
     [ metrics new 0 >>width ] dip {