gtk: use system preference for font

collects/mred/private/gdi.rkt

@@ -238,18 +238,23 @@
 			[(windows) 1]
 			[else 2]))
 
-  (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system
-                                           'normal 'normal #f 'default
-                                           (wx:get-control-font-size-in-pixels?)))
-  (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system
-                                           'normal 'normal #f 'default
-                                           (wx:get-control-font-size-in-pixels?)))
-  (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system
+  (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 
+					   (wx:get-control-font-face) 'system
                                            'normal 'normal #f 'default
                                            (wx:get-control-font-size-in-pixels?)))
+  (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 
+					  (wx:get-control-font-face) 'system
+					  'normal 'normal #f 'default
+					  (wx:get-control-font-size-in-pixels?)))
+  (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta)
+					 (wx:get-control-font-face) 'system
+					 'normal 'normal #f 'default
+					 (wx:get-control-font-size-in-pixels?)))
   (define view-control-font (if (eq? 'macosx (system-type))
-				(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
+				(make-object wx:font% (- (wx:get-control-font-size) 1) 
+					     (wx:get-control-font-face) 'system)
 				normal-control-font))
   (define menu-control-font (if (eq? 'macosx (system-type))
-				(make-object wx:font% (+ (wx:get-control-font-size) 1) 'system)
+				(make-object wx:font% (+ (wx:get-control-font-size) 1) 
+					     (wx:get-control-font-face) 'system)
 				normal-control-font)))

collects/mred/private/wx/cocoa/platform.rkt

@@ -65,6 +65,7 @@
    flush-display
    fill-private-color
    cancel-quit
+   get-control-font-face
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time

collects/mred/private/wx/cocoa/procs.rkt

@@ -44,6 +44,7 @@
  file-creator-and-type
  run-printout
  get-double-click-time
+ get-control-font-face
  get-control-font-size
  get-control-font-size-in-pixels?
  cancel-quit
@@ -89,6 +90,7 @@
 
 (define (get-double-click-time)
   500)
+(define (get-control-font-face) "Lucida Grande")
 (define (get-control-font-size) 13)
 (define (get-control-font-size-in-pixels?) #f)
 (define (cancel-quit) (void))

collects/mred/private/wx/gtk/platform.rkt

@@ -65,6 +65,7 @@
    flush-display
    fill-private-color
    cancel-quit
+   get-control-font-face
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time

collects/mred/private/wx/gtk/procs.rkt

@@ -37,6 +37,7 @@
  file-creator-and-type
  run-printout
  get-double-click-time
+ get-control-font-face
  get-control-font-size
  get-control-font-size-in-pixels?
  cancel-quit
@@ -81,9 +82,42 @@
 
 (define run-printout (make-run-printout printer-dc%))
 
-(define (get-double-click-time) 250)
-(define (get-control-font-size) 10) ;; FIXME
-(define (get-control-font-size-in-pixels?) #f) ;; FIXME
+(define _GtkSettings (_cpointer 'GtkSettings))
+(define-gtk gtk_settings_get_default (_fun -> _GtkSettings))
+(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) 
+				    -> _void
+				    -> r)
+  #:c-id g_object_get)
+(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f)
+				       -> _void
+				       -> r)
+  #:c-id g_object_get)
+
+(define (get-double-click-time)
+  (let ([s (gtk_settings_get_default)])
+    (if s
+	(g_object_get/int s "gtk-double-click-time")
+	250)))
+(define (get-control-font proc default)
+  (or
+   (let ([s (gtk_settings_get_default)])
+     (and s
+	  (let ([f (g_object_get/string s "gtk-font-name")])
+	    (and f
+		 (begin0
+		  (cond
+		   [(regexp-match #rx"^(.*) ([0-9]+)$" (cast f _pointer _string))
+		    => (lambda (m) (proc (cdr m)))]
+		   [else #f])
+		  (g_free f))))))
+   default))
+(define (get-control-font-size)
+  (get-control-font (lambda (m) (string->number (cadr m)))
+		    10))
+(define (get-control-font-face)
+  (get-control-font (lambda (m) (car m))
+		    "Sans"))
+(define (get-control-font-size-in-pixels?) #f)
 
 (define (get-display-depth) 32)
 

collects/mred/private/wx/platform.rkt

@@ -50,6 +50,7 @@
                 flush-display
                 fill-private-color
                 cancel-quit
+                get-control-font-face
                 get-control-font-size
                 get-control-font-size-in-pixels?
                 get-double-click-time

collects/mred/private/wx/win32/platform.rkt

@@ -66,6 +66,7 @@
    flush-display
    fill-private-color
    cancel-quit
+   get-control-font-face
    get-control-font-size
    get-control-font-size-in-pixels?
    get-double-click-time

collects/mred/private/wx/win32/procs.rkt

@@ -37,6 +37,7 @@
  file-creator-and-type
  run-printout
  get-double-click-time
+ get-control-font-face
  get-control-font-size
  get-control-font-size-in-pixels?
  cancel-quit
@@ -84,6 +85,7 @@
 (define run-printout (make-run-printout printer-dc%))
 
 (define (get-double-click-time) 500)
+(define (get-control-font-face) "Tahoma")
 (define (get-control-font-size) (get-theme-font-size))
 (define (get-control-font-size-in-pixels?) #t)
 (define (flush-display) (void))