From 90ff90edb1f024cee7cc803ede57ef4924bc0238 Mon Sep 17 00:00:00 2001
From: layer <layer>
Date: Tue, 22 Jul 2008 16:29:54 +0000
Subject: [PATCH] join from trunk_afuchs3 to trunk

---
 ChangeLog.n                       | 41 ++++++++++++-
 aclpc/acl-widget.lisp             | 96 +++++++++++++++----------------
 misc/climgccursor.c               | 15 ++---
 postscript/postscript-medium.lisp | 77 +++++++++++++------------
 tk-silica/gc-cursor.lisp          | 49 +++++++++-------
 tk-silica/xm-silica.lisp          |  8 ++-
 tk-silica/xt-graphics.lisp        | 12 ++--
 tk-silica/xt-silica.lisp          | 24 ++++++--
 8 files changed, 197 insertions(+), 125 deletions(-)

diff --git a/ChangeLog.n b/ChangeLog.n
index 86dbd872..0f2a5e2c 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,42 @@
+*******************************************************************************
+join from trunk_afuchs3 to trunk
+    changes from:
+	2008-07-17  Andreas Fuchs  <afuchs@franz.com>
+    to
+	2008-07-13  Andreas Fuchs  <afuchs@franz.com>
+
+*******************************************************************************
+2008-07-17  Andreas Fuchs  <afuchs@franz.com>
+
+	* aclpc/acl-widget.lisp: Make the width for text fields/editors
+	  with a set :value at least *default-text-field-width* big.
+
+2008-07-17  Andreas Fuchs  <afuchs@franz.com>
+
+	* tk-silica/gc-cursor.lisp: Use the right pointer size to
+	  set the GC hooks for the GC cursor shape.
+	* misc/climgccursor.c: Get rid of compiler warnings on
+	  linux/amd64.
+
+2008-07-16  Andreas Fuchs  <afuchs@franz.com>
+
+	* tk-silica/xt-silica.lisp: Add glyph-info-cache and
+	  font-set-cache to speed up int'l text drawing; add method
+	  text-style-font-set that uses the font-set-cache; change
+	  port-glyph-for-character to use the glyph-info-cache.
+	* tk-silica/xt-graphics: change medium-draw-text* to use
+	  text-style-font-set.
+
+2008-07-14  Andreas Fuchs  <afuchs@franz.com>
+
+	* tk-silica/xm-silica.lisp: When setting input focus to a stream pane,
+	  perform the necessary steps to give it X input focus too. (spr34777)
+
+2008-07-13  Andreas Fuchs  <afuchs@franz.com>
+
+	* postscript/postscript-medium.lisp: Draw filled partial circles in a pie diagram
+	  compatible way.
+
 *******************************************************************************
 join from trunk_afuchs3 to trunk
     changes from:
@@ -6296,4 +6335,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile
 	Lots of other stuff
 
 *******************************************************************************
-$Revision: 2.42 $
+$Revision: 2.43 $
diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp
index 57cc724d..bdcf3ab7 100644
--- a/aclpc/acl-widget.lisp
+++ b/aclpc/acl-widget.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-widget.lisp,v 2.16 2008/03/03 21:58:24 layer Exp $
+;; $Id: acl-widget.lisp,v 2.17 2008/07/22 16:29:54 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -324,7 +324,7 @@
 	       (setq w (process-width-specification pane `(,ncolumns :character))))
 	      ((stringp value)
 	       (setq w (max (process-width-specification pane value)
-			    min-w)))
+			    *default-text-field-width*)))
 	      (t
 	       (setq w *default-text-field-width*)))
 	(when (member scroll-mode '(:horizontal :both t :dynamic))
@@ -705,53 +705,53 @@
   (with-slots (x-margin y-margin initial-space-requirement nlines ncolumns) 
       pane
     (let* ((parent (sheet-parent pane))
-	   (parent-viewport-p (isa-viewport parent)))
+           (parent-viewport-p (isa-viewport parent)))
       (let ((w 0) 
-	    (min-w (process-width-specification pane '(1 :character)))
-	    (h 0)
-	    (value (gadget-value pane))
-	    (min-h (process-height-specification pane *min-text-field-height*)))
-	;; WIDTH
-	(cond (parent-viewport-p
-	       (setq w (process-width-specification pane width)))
-	      ((and initial-space-requirement
-		    (plusp (process-width-specification
-			    pane (space-requirement-width initial-space-requirement))))
-	       ;; This is where accepting-values views factors in.
-	       (setq w (max (process-width-specification 
-			     pane (space-requirement-width initial-space-requirement))
-			    min-w)))
-	      (ncolumns
-	       (setq w (process-width-specification pane `(,ncolumns :character))))
-	      ((stringp value)
-	       (setq w (max (process-width-specification pane value)
-			    min-w)))
-	      (t
-	       (setq w *default-text-field-width*)))
-	(setq w (max w min-w))
-
-	;; HEIGHT
-	(cond (parent-viewport-p
-	       (setq h (process-height-specification pane height)))
-	      ((and initial-space-requirement
-		    (plusp (process-height-specification
-			    pane (space-requirement-height initial-space-requirement))))
-	       ;; This is where accepting-values views factors in.
-	       (setq h (max (process-height-specification 
-			     pane (space-requirement-height initial-space-requirement))
-			    min-h)))
-	      (nlines
-	       (setq h (process-height-specification pane `(,nlines :line))))
-	      ((stringp value)
-	       (setq h (process-height-specification pane value)))
-	      (t
-	       (setq h min-h))) 
-	(setq h (max h min-h))
-
-	(make-space-requirement
-	 :width  w :min-width min-w
-	 :height h :min-height min-h
-	 )))))
+            (min-w (process-width-specification pane '(1 :character)))
+            (h 0)
+            (value (gadget-value pane))
+            (min-h (process-height-specification pane *min-text-field-height*)))
+        ;; WIDTH
+        (cond (parent-viewport-p
+               (setq w (process-width-specification pane width)))
+              ((and initial-space-requirement
+                    (plusp (process-width-specification
+                            pane (space-requirement-width initial-space-requirement))))
+               ;; This is where accepting-values views factors in.
+               (setq w (max (process-width-specification 
+                             pane (space-requirement-width initial-space-requirement))
+                            min-w)))
+              (ncolumns
+               (setq w (process-width-specification pane `(,ncolumns :character))))
+              ((stringp value)
+               (setq w (max (process-width-specification pane value)
+                            *default-text-field-width*)))
+              (t
+               (setq w *default-text-field-width*)))
+        (setq w (max w min-w))
+
+        ;; HEIGHT
+        (cond (parent-viewport-p
+               (setq h (process-height-specification pane height)))
+              ((and initial-space-requirement
+                    (plusp (process-height-specification
+                            pane (space-requirement-height initial-space-requirement))))
+               ;; This is where accepting-values views factors in.
+               (setq h (max (process-height-specification 
+                             pane (space-requirement-height initial-space-requirement))
+                            min-h)))
+              (nlines
+               (setq h (process-height-specification pane `(,nlines :line))))
+              ((stringp value)
+               (setq h (process-height-specification pane value)))
+              (t
+               (setq h min-h))) 
+        (setq h (max h min-h))
+
+        (make-space-requirement
+         :width  w :min-width min-w
+         :height h :min-height min-h
+         )))))
 
 (defmethod handle-event ((pane mswin-text-field) (event key-press-event))
   
diff --git a/misc/climgccursor.c b/misc/climgccursor.c
index c567a0ed..4391ae8d 100644
--- a/misc/climgccursor.c
+++ b/misc/climgccursor.c
@@ -19,7 +19,7 @@ static Cursor widget_cursor = 0;
 /* extern int (*gc_before)(),(*gc_after)(); */
 /* static int (*old_gc_before)(),(*old_gc_after)(); */
 
-static find_font_cursor (cursor)
+static Cursor find_font_cursor (cursor)
 int cursor;
 {
     Window window;
@@ -32,10 +32,9 @@ int cursor;
 	    Window root = RootWindowOfScreen(XtScreen(gc_widget));
 
 	    if (!context) context = XUniqueContext();
-
-	    if (XFindContext(display, root, context, &font_cursor)) {
+	    if (XFindContext(display, root, context, (XPointer *)&font_cursor)) {
 		font_cursor = XCreateFontCursor(display, cursor);
-		XSaveContext(display, root, context, (char*)font_cursor);
+		XSaveContext(display, root, context, (XPointer)font_cursor);
 	    }
 	    return (font_cursor);
 	}
@@ -61,11 +60,13 @@ clim_starting_gc()
 {
   /* if (old_gc_before) (*old_gc_before)(); */
   set_the_cursor(find_font_cursor(XC_watch));
+  return 0;
 }
 
 clim_stopping_gc()
 {
   set_the_cursor(widget_cursor);
+  return 0;
   /* if (old_gc_after) (*old_gc_after)(); */
 }
 		      
@@ -98,9 +99,9 @@ Cursor cursor;
     widget_cursor = cursor;
     if (gc_widget != widget) {
 	if (widget) {
-	    /* What does calling add callback repeatably do? */
-	    XtRemoveCallback(widget, XtNdestroyCallback, remove_gc_cursor, widget);
-	    XtAddCallback(widget, XtNdestroyCallback, remove_gc_cursor, widget);
+	    /* What does calling add callback repeatedly do? */
+	    XtRemoveCallback(widget, XtNdestroyCallback, (XtCallbackProc) remove_gc_cursor, widget);
+	    XtAddCallback(widget, XtNdestroyCallback, (XtCallbackProc) remove_gc_cursor, widget);
 	}
 	gc_widget = widget;
     }
diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp
index 30833045..8fc65ec9 100644
--- a/postscript/postscript-medium.lisp
+++ b/postscript/postscript-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $Id: postscript-medium.lisp,v 2.5 2007/12/11 17:20:20 layer Exp $
+;; $Id: postscript-medium.lisp,v 2.6 2008/07/22 16:29:54 layer Exp $
 
 (in-package :postscript-clim)
 
@@ -302,54 +302,57 @@
   (error "This postscript operation is NYI (Not Yet Implemented)."))
 
 (defmethod medium-draw-ellipse* ((medium postscript-medium)
-				 center-x center-y
-				 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
-				 start-angle end-angle filled)
+                                 center-x center-y
+                                 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+                                 start-angle end-angle filled)
   (maybe-send-feature medium 'ellipse *ps-ellipse-code*)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
-	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium))
-	 (clip-region (medium-clipping-region medium)))
+         (ink (medium-ink medium))
+         (line-style (medium-line-style medium))
+         (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform center-x center-y)
     (convert-to-postscript-distances transform
       radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
     (when (null start-angle)
       (setq start-angle 0
-	    end-angle 2pi))
+            end-angle 2pi))
     (when (< end-angle start-angle)
       (setq end-angle (+ end-angle 2pi)))
     (multiple-value-bind (x-radius y-radius)
-	(cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
-	       (values (abs radius-2-dx) (abs radius-1-dy)))
-	      ((and (= radius-2-dx 0) (= radius-1-dy 0))
-	       (values (abs radius-1-dx) (abs radius-2-dy)))
-	      (t (nyi)))
+        (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+               (values (abs radius-2-dx) (abs radius-1-dy)))
+              ((and (= radius-2-dx 0) (= radius-1-dy 0))
+               (values (abs radius-1-dx) (abs radius-2-dy)))
+              (t (nyi)))
       (pixels-to-points x-radius y-radius)
       (flet ((skew-angle (a)
-	       (atan (* (sin a) x-radius)
-		     (* (cos a) y-radius))))
-	(with-postscript-drawing-options (medium printer-stream
-					  :epilogue :default
-					  :ink ink :filled filled
-					  :line-style line-style
-					  :clip-region clip-region)
-	  (ps-pos-op medium "ellipse" center-x center-y
-		     x-radius y-radius
-		     ;; Don't allow the common full-circle case to be
-		     ;; screwed up by floating point error:
-		     (if (zerop start-angle)
-			 0
-			 (radians->degrees (skew-angle start-angle)))
-		     (if (= end-angle 2pi)
-			 360
-			 (radians->degrees (skew-angle end-angle)))))
-	(annotating-postscript (medium printer-stream)
-	  (format printer-stream
-	      "        (medium-draw-ellipse* ~D ~D ~D ~D ~D ~D ~D ~D ...)"
-	    center-x center-y
-	    radius-1-dx radius-1-dy
-	    radius-2-dx radius-2-dy
-	    start-angle end-angle))))))
+               (atan (* (sin a) x-radius)
+                     (* (cos a) y-radius))))
+        (with-postscript-drawing-options (medium printer-stream
+                                          :epilogue :default
+                                          :ink ink :filled filled
+                                          :line-style line-style
+                                          :clip-region clip-region
+                                          :newpath filled)
+          (when filled
+            (ps-pos-op medium "moveto" center-x center-y))
+          (ps-pos-op medium "ellipse" center-x center-y
+                     x-radius y-radius
+                     ;; Don't allow the common full-circle case to be
+                     ;; screwed up by floating point error:
+                     (if (zerop start-angle)
+                         0
+                         (radians->degrees (skew-angle start-angle)))
+                     (if (= end-angle 2pi)
+                         360
+                         (radians->degrees (skew-angle end-angle)))))
+        (annotating-postscript (medium printer-stream)
+          (format printer-stream
+              "        (medium-draw-ellipse* ~D ~D ~D ~D ~D ~D ~D ~D ...)"
+            center-x center-y
+            radius-1-dx radius-1-dy
+            radius-2-dx radius-2-dy
+            start-angle end-angle))))))
 
 ;; These 2 clones of draw-string would be much more modular if there
 ;; were a reasonable way of passing arguments transparently, so that
diff --git a/tk-silica/gc-cursor.lisp b/tk-silica/gc-cursor.lisp
index fbcc01e9..5ae007ee 100644
--- a/tk-silica/gc-cursor.lisp
+++ b/tk-silica/gc-cursor.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: gc-cursor.lisp,v 2.7 2007/04/17 21:45:53 layer Exp $
+;; $Id: gc-cursor.lisp,v 2.8 2008/07/22 16:29:54 layer Exp $
 
 (in-package :xm-silica)
 
@@ -25,28 +25,33 @@
 (defvar *gc-after*  nil)
 
 (defun init-gc-cursor (frame &optional force)
-  (when *use-clim-gc-cursor*
-    (when (or force (null *gc-before*))
-      (let ((vec (make-array 2 :element-type '(unsigned-byte 32))))
-	(tk::init_clim_gc_cursor_stuff vec)
-	(setq *gc-before* (aref vec 0)
-	      *gc-after*  (aref vec 1))
-	(pushnew (make-array 1 :element-type '(unsigned-byte 32)
-			     :initial-element *gc-before*)
-		 (excl:gc-before-c-hooks))
+  
+  (let ((pointer-type (first
+                       (list #+(and 64bit (not alpha)) '(unsigned-byte 64)
+                             ;; otherwise, use 32 bits:
+                             '(unsigned-byte 32)))))
+    (when *use-clim-gc-cursor*
+      (when (or force (null *gc-before*))
+        (let ((vec (make-array 2 :element-type pointer-type)))
+          (tk::init_clim_gc_cursor_stuff vec)
+          (setq *gc-before* (aref vec 0)
+                *gc-after*  (aref vec 1))
+          (pushnew (make-array 1 :element-type pointer-type
+                               :initial-element *gc-before*)
+                   (excl:gc-before-c-hooks))
 	
-	(pushnew (make-array 1 :element-type '(unsigned-byte 32)
-			     :initial-element *gc-after*)
-		 (excl:gc-after-c-hooks))))
-    (let* ((sheet (frame-top-level-sheet frame))
-	   (mirror (and sheet (sheet-direct-mirror sheet))))
-      (if mirror
-	  (tk::set_clim_gc_cursor_widget
-	   mirror
-	   (realize-cursor (port sheet)
-			   sheet
-			   (sheet-pointer-cursor sheet)))
-	(tk::set_clim_gc_cursor_widget 0 0)))))
+          (pushnew (make-array 1 :element-type pointer-type
+                               :initial-element *gc-after*)
+                   (excl:gc-after-c-hooks))))
+      (let* ((sheet (frame-top-level-sheet frame))
+             (mirror (and sheet (sheet-direct-mirror sheet))))
+        (if mirror
+            (tk::set_clim_gc_cursor_widget
+             mirror
+             (realize-cursor (port sheet)
+                             sheet
+                             (sheet-pointer-cursor sheet)))
+            (tk::set_clim_gc_cursor_widget 0 0))))))
 
 (defun reinitialize-gc-cursor ()
   ;; Force init-gc-cursor to go through its initialization
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index ec8fb3ec..72bbb833 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-silica.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $
+;; $Id: xm-silica.lisp,v 2.9 2008/07/22 16:29:54 layer Exp $
 
 (in-package :xm-silica)
 
@@ -131,6 +131,12 @@
 
 ;;; hacks for explicit focus
 
+(defmethod (setf port-keyboard-input-focus) :before ((sheet clim-stream-sheet)
+                                                     (port motif-port))
+  ;; re-set focus away from e.g. push buttons that have it and are
+  ;; reluctant to give it up.
+  (note-sheet-tree-grafted port sheet))
+
 (defmethod note-sheet-tree-grafted :after ((port motif-port)
 					   (sheet clim-stream-sheet))
   ;; this is a hack which enables this child widget to take input
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 4160d918..70163088 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-graphics.lisp,v 2.11 2008/06/24 16:51:12 layer Exp $
+;; $Id: xt-graphics.lisp,v 2.12 2008/07/22 16:29:54 layer Exp $
 
 (in-package :tk-silica)
 
@@ -1561,7 +1561,10 @@
                      (setq y-factor (sin alpha))
                      (setq x-factor (cos alpha)))))))
         (let ((drawable (medium-drawable medium))
-              (font (text-style-mapping port text-style *all-character-sets*)))
+              (font (excl:ics-target-case
+                      (:-ics (text-style-mapping port text-style
+                                                 *all-character-sets*))
+                      (:+ics (text-style-font-set port text-style)))))
           (when drawable
             (fix-coordinates x y)
             (discard-illegal-coordinates medium-draw-text* x y)
@@ -1574,7 +1577,7 @@
                   (excl:ics-target-case
                     (:+ics
                      (port-draw-rotated-multibyte-text port drawable gc x y string start end
-                                                       (font-set-from-font-list port font)
+                                                       font
                                                        towards-x towards-y transform-glyphs))
                     (:-ics
                      (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil))
@@ -1582,8 +1585,7 @@
                                              font towards-x towards-y transform-glyphs)))
                   (excl:ics-target-case
                     (:+ics
-                     (tk::draw-multibyte-string drawable
-                                                (font-set-from-font-list port font)
+                     (tk::draw-multibyte-string drawable font
                                                 gc x y string start end))
                     (:-ics
                      (setf (tk::gcontext-font gc) (text-style-mapping port text-style nil))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index d2d76038..08d25ddb 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-silica.lisp,v 2.15 2008/06/24 16:51:12 layer Exp $
+;; $Id: xt-silica.lisp,v 2.16 2008/07/22 16:29:54 layer Exp $
 
 (in-package :xm-silica)
 
@@ -40,6 +40,8 @@
      (cursor-font :initform nil)
      (cursor-cache :initform nil)
      (font-cache :initform (make-hash-table :test #'equal))
+     (font-set-cache :initform (make-hash-table :test #'equal))
+     (glyph-info-cache :initform (make-hash-table :test #'equal))
      (compose-status :initform (make-xcomposestatus)
 		     :reader port-compose-status)
      #+ignore ;; figure out how to get this translation
@@ -1098,9 +1100,16 @@ setup."
   (:+ics
    (defmethod port-glyph-for-character ((port xt-port) character text-style &optional our-font)
      (declare (ignore our-font)) ; We need the font set, not the font.
-     (let* ((fonts (text-style-mapping port text-style *all-character-sets*))
-            (font-set (font-set-from-font-list port fonts)))
-       (port-glyph-for-character-from-font-set port character font-set)))
+     (let* ((font-set (text-style-font-set port text-style)))
+       (if (characterp character)
+           (with-slots (glyph-info-cache) port
+              (values-list
+               (or (gethash (cons character text-style) glyph-info-cache)
+                   (setf (gethash (cons character text-style) glyph-info-cache)
+                         (multiple-value-list
+                          (port-glyph-for-character-from-font-set port character font-set))))))
+           (port-glyph-for-character-from-font-set port character font-set))))
+   
    (defmethod port-glyph-for-character-from-font-set ((port xt-port) character font-set)
      (multiple-value-bind (native-string length) (excl:string-to-native (string character))
        (unwind-protect
@@ -1161,6 +1170,13 @@ setup."
                (push (cons c mapping) mappings))))
          (reverse mappings))))
 
+(defmethod text-style-font-set ((port xt-port) text-style)
+  (with-slots (font-set-cache) port
+     (or (gethash text-style font-set-cache)
+         (setf (gethash text-style font-set-cache)
+               (font-set-from-font-list
+                port (text-style-mapping port text-style *all-character-sets*))))))
+
 (defmethod font-set-from-font-list ((port xt-port) font-list)
   (let ((name (format nil "~{~A~^,~}"
                       (mapcar (lambda (font) (tk::font-name (cdr font)))
-- 
GitLab