From 53cc1b821ac7871e13ec165f4a17f6c47fc0a9b4 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 27 Apr 1993 14:36:09 +0000
Subject: [PATCH] .cvsignore		Ignore extra files Makefile.defs
 	Added hpgl to directory list, Uncommented malloclib stuff
 clim/command.lisp	Implemented ensure-command-in-command-table and :after
 :replace clim/incremental-redisplay.lisp	Setf all-new slot of record to
 NIL after its used climtoys/ib.lisp	Usual hacking
 demo/graphics-editor.lisp	made command-table menu  use :divider
 tk/make-classes.lisp		Map list and scrolling-list to ol-list
 tk/xm-font-list.lisp		Motif 1.2 font list code. tk/xm-funs.lisp
 		Motif 1.2 font list code. tk-silica/ol-gadgets.lisp
 command menu updating and :divider stuff. tk-silica/ol-silica.lisp	ensure
 widget has a window tk-silica/xm-frames.lisp	command table menu :divider
 stuff. utils/packages.lisp		Export stream-redisplaying-p

---
 .cvsignore                      |  2 ++
 Makefile.defs                   | 23 +++++++------
 clim/incremental-redisplay.lisp |  3 +-
 tk-silica/ol-gadgets.lisp       | 39 ++++++++++++++++-----
 tk-silica/ol-silica.lisp        | 31 +++++++++--------
 tk-silica/xm-frames.lisp        | 25 ++++++++++----
 tk/make-classes.lisp            |  4 +--
 tk/xm-font-list.lisp            | 61 ++++++++++++++++++---------------
 tk/xm-funs.lisp                 | 38 +++++++++++++++++++-
 9 files changed, 153 insertions(+), 73 deletions(-)

diff --git a/.cvsignore b/.cvsignore
index 3424e022..f5856c7f 100755
--- a/.cvsignore
+++ b/.cvsignore
@@ -9,3 +9,5 @@ coverage-report.lisp
 postscript.output
 test-suite-reportol.lisp
 test-suite-reportxm.lisp
+hpgl.output
+foo.diffs
diff --git a/Makefile.defs b/Makefile.defs
index 45aa9672..2c3cf806 100644
--- a/Makefile.defs
+++ b/Makefile.defs
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.defs,v 1.6 93/04/16 09:26:13 layer Exp $
+# $fiHeader: Makefile.defs,v 1.7 93/04/16 09:44:41 cer Exp $
 #
 #  Makefile.defs for CLIM 2.0
 #
@@ -68,7 +68,7 @@ PREMALLOCS = '-m 401408'
 CLIM-SMALL	= ./slim-small
 
 PUBDIRS	= sys utils silica clim demo test genera clx pre-silica postscript compatibility
-DIRS0	=  tk tk-silica misc cloe climtoys
+DIRS0	=  tk tk-silica misc cloe climtoys hpgl
 DIRS	= $(PUBDIRS) xlib $(DIRS0)
 CHEAP_CLEAN	= $(PUBDIRS) $(DIRS0)
 
@@ -147,17 +147,18 @@ COMPOSEROBJS= /scm/4.1/sparc/src/code/excldep.o /scm/4.1/sparc/src/code/socket.o
 	      /scm/4.1/sparc/src/code/io.o /scm/4.1/sparc/src/code/exclio.o \
 	      /scm/4.1/sparc/src/code/RunStatus.o
 
-MALLOCOBJS =
+
+
+ALLMALLOCOBJS= $(PWD)/malloclib/malloc.o $(PWD)/malloclib/free.o $(PWD)/malloclib/realloc.o \
+	    $(PWD)/malloclib/calloc.o $(PWD)/malloclib/string.o \
+	    $(PWD)/malloclib/malloc_chk.o $(PWD)/malloclib/malloc_chn.o \
+	    $(PWD)/malloclib/memory.o $(PWD)/malloclib/tostring.o \
+	    $(PWD)/malloclib/m_perror.o $(PWD)/malloclib/m_init.o \
+	    $(PWD)/malloclib/mallopt.o $(PWD)/malloclib/dump.o $(PWD)/malloclib/leak.o
 # Uncomment to enable malloc debugging.
-#
-# MALLOCOBJS= $(PWD)/malloclib/malloc.o $(PWD)/malloclib/free.o $(PWD)/malloclib/realloc.o \
-#	    $(PWD)/malloclib/calloc.o $(PWD)/malloclib/string.o \
-#	    $(PWD)/malloclib/malloc_chk.o $(PWD)/malloclib/malloc_chn.o \
-#	    $(PWD)/malloclib/memory.o $(PWD)/malloclib/tostring.o \
-#	    $(PWD)/malloclib/m_perror.o $(PWD)/malloclib/m_init.o \
-#	    $(PWD)/malloclib/mallopt.o $(PWD)/malloclib/dump.o $(PWD)/malloclib/leak.o
+#MALLOCOBJS =ALLMALLOCOBJS=
+MALLOCOBJS =
 
-#
 # "Compile time objects" -- these go into clim-debug.fasl
 #
 DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \
diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp
index 8c85594c..aca28699 100644
--- a/clim/incremental-redisplay.lisp
+++ b/clim/incremental-redisplay.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: incremental-redisplay.lisp,v 1.18 93/04/07 09:06:42 cer Exp $
+;; $fiHeader: incremental-redisplay.lisp,v 1.19 93/04/16 09:44:52 cer Exp $
 
 (in-package :clim-internals)
 
@@ -925,6 +925,7 @@
   (with-slots (all-new old-bounding-rectangle contents-ok old-parent) record
     ;; if it's all-new, don't bother walking the hierarchy, just redraw.
     (cond (all-new
+	   (setf all-new nil)
 	   (values nil nil
 		   (list (list record
 			       (bounding-rectangle-shift-position
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 32660aa9..c154bb07 100644
--- a/tk-silica/ol-gadgets.lisp
+++ b/tk-silica/ol-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-gadgets.lisp,v 1.45 93/04/23 09:18:40 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.46 93/04/26 20:18:30 colin Exp $
 
 
 (in-package :xm-silica)
@@ -322,9 +322,13 @@
   
   (let* ((mirror (call-next-method))
 	(text-style (pane-text-style sheet))
-	(font-list (list :font (text-style-mapping port text-style)))
-	(options font-list))
-    (labels ((update-menu-item-sensitivity (widget frame commands)
+	(font-list (list :font (text-style-mapping port text-style))))
+    (labels ((compute-options (item)
+	       (let ((text-style (getf (command-menu-item-options item) :text-style)))
+		 (if text-style
+		     (list :font (text-style-mapping port text-style))
+		   font-list)))
+	     (update-menu-item-sensitivity (widget frame commands)
 	       (declare (ignore widget))
 	       (dolist (cbs commands)
 		 (tk::set-sensitive (second cbs)
@@ -350,6 +354,23 @@
 				     widget)
 				  (assert widget))))
 		     
+		     #-ignore
+		     (setf (tk::widget-create-popup-child-proc shell)
+		       #'(lambda (shell)
+			   (declare (ignore shell))
+			   (let ((children
+				  (tk::widget-children menu-pane)))
+			     (when (or (null children)
+				       (/= tick
+					   (setq tick
+					     (slot-value ct 'clim-internals::menu-tick))))
+			       (tk::unmanage-children children)
+			       #+should-we-do-this-since-olit-has-problems
+			       (mapc #'tk::destroy-widget children)
+			       (make-command-for-command-table-1 mb item)))))
+		     
+		     ;;--- This does not get called.
+		     #+ignore
 		     (xt::add-callback 
 		      shell :popup-callback
 		      #'(lambda (shell)
@@ -383,8 +404,10 @@
 			   (unless top
 			     (apply #'make-instance 'xt::static-text
 					    :parent parent
-					    :string " "
-					    options)))
+					    :string (ecase (command-menu-item-value item)
+						      ((nil :divider) " ")
+						      (:label menu))
+					    (compute-options item))))
 			  (:function
 			   ;;--- Do this sometime
 			   )
@@ -393,7 +416,7 @@
 			      (apply #'make-instance 'tk::menu-button
 						     :parent parent
 						     :label menu
-						     options) 
+						     (compute-options item))
 			      item))
 
 			  (t
@@ -405,7 +428,7 @@
 						 :sensitive (command-enabled
 							     (car (command-menu-item-value item))
 							     (slot-value sheet 'silica::frame))
-						 options)))
+						 (compute-options item))))
 			     
 			     (when top
 			       (push (cons (car (command-menu-item-value item)) button)
diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp
index 70f43f01..84a47017 100644
--- a/tk-silica/ol-silica.lisp
+++ b/tk-silica/ol-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-silica.lisp,v 1.16 92/11/13 14:47:13 cer Exp $
+;; $fiHeader: ol-silica.lisp,v 1.17 93/04/23 09:18:43 cer Exp $
 
 (in-package :xm-silica)
 
@@ -49,20 +49,21 @@
   (when new 
     (let ((mirror (sheet-mirror stream)))
       (when mirror 
-	(let ((window (tk::widget-window mirror)))
-	  (with-port-event-lock (port)
-	    (excl:without-interrupts
-	      (let ((display (port-display port)))
-		(tk:with-server-grabbed (display)
-		  (when (eq (tk::window-map-state window) :viewable)
-		    ;;--- There could very well be a race condition involving
-		    ;;--- a couple of processes.  Another process could have made
-		    ;;--- this window go away at this point
-		    (tk::ol_set_input_focus 
-		     mirror
-		     2			; RevertToParent
-		     ;;-- This is not exact but it might work better.
-		     (xt::xt-last-timestamp-processed display))))))))))))
+	(let ((window (tk::widget-window mirror nil)))
+	  (when window
+	    (with-port-event-lock (port)
+	      (excl:without-interrupts
+		(let ((display (port-display port)))
+		  (tk:with-server-grabbed (display)
+		    (when (eq (tk::window-map-state window) :viewable)
+		      ;;--- There could very well be a race condition involving
+		      ;;--- a couple of processes.  Another process could have made
+		      ;;--- this window go away at this point
+		      (tk::ol_set_input_focus 
+		       mirror
+		       2	; RevertToParent
+		       ;;-- This is not exact but it might work better.
+		       (xt::xt-last-timestamp-processed display)))))))))))))
 
 (defmethod change-widget-geometry ((parent tk::draw-area) child
 				   &rest args
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 4fe0e20e..a9b286e3 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.54 93/04/16 09:45:56 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.55 93/04/23 09:18:45 cer Exp $
 
 (in-package :xm-silica)
 
@@ -124,10 +124,14 @@
   (let* ((mirror (call-next-method))
 	 (text-style (pane-text-style sheet))
 	 (font-list (list :font-list (text-style-mapping port text-style)))
-	 (options font-list)
 	 (ct (menu-bar-command-table sheet))
 	 (flatp (flat-command-table-menu-p ct)))
-    (labels ((update-menu-item-sensitivity (widget frame commands)
+    (labels ((compute-options (item)
+	       (let ((text-style (getf (command-menu-item-options item) :text-style)))
+		 (if text-style
+		     (list :font-list (text-style-mapping port text-style))
+		   font-list)))
+	     (update-menu-item-sensitivity (widget frame commands)
 	       (declare (ignore widget))
 	       (dolist (cbs commands)
 		 (tk::set-sensitive (second cbs)
@@ -167,7 +171,7 @@
 					 :parent parent
 					 :label-string menu
 					 :sub-menu-id submenu
-					 options)))
+					 (compute-options item))))
 		 (unless flatp
 		   (set-button-mnemonic sheet
 					cb (getf (command-menu-item-options item) :mnemonic)))
@@ -200,7 +204,14 @@
 		      (let ((type (command-menu-item-type item)))
 			(case type
 			  (:divider
-			   (make-instance 'tk::xm-separator :parent parent))
+			   (ecase (command-menu-item-value item)
+			     (:label 
+			      (apply #'make-instance 'tk::xm-label
+				     :label-string menu
+				     :parent parent
+				     (compute-options item)))
+			     ((nil :divider)
+			      (make-instance 'tk::xm-separator :parent parent))))
 			  (:function
 			   ;;--- Do this sometime
 			   )
@@ -218,7 +229,7 @@
 						 :label-string menu
 						 :sub-menu-id
 						 submenu
-						 options)))
+						 (compute-options item))))
 				 (declare (ignore cb))
 				 (setq parent submenu)))
 			     (let ((button 
@@ -229,7 +240,7 @@
 					   :sensitive (command-enabled
 						       (car (command-menu-item-value item))
 						       (slot-value sheet 'silica::frame))
-					   options)))
+					   (compute-options item))))
 			       (push (list item button)
 				     commands-and-buttons)
 			       
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 4d350e3d..ef289887 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.30 93/04/16 09:26:36 layer Exp $
+;; $fiHeader: make-classes.lisp,v 1.31 93/04/23 09:18:30 cer Exp $
 
 (in-package :tk)
 
@@ -230,7 +230,7 @@
   (let ((name (lispify-tk-name x)))
     (case name
       ;; Openlook
-      (list 'ol-list)
+      ((list scrolling-list) 'ol-list)
       (event-obj 'event)
       (t name))))
   
diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp
index 6dfa142f..550a9288 100644
--- a/tk/xm-font-list.lisp
+++ b/tk/xm-font-list.lisp
@@ -20,24 +20,34 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-font-list.lisp,v 1.8 92/11/20 08:46:19 cer Exp $
+;; $fiHeader: xm-font-list.lisp,v 1.9 93/03/01 14:26:30 cer Exp $
 
 (in-package :tk)
 
+(defconstant xm-font-is-font 0)
+(defconstant xm-font-list-default-tag "XmFONTLIST_DEFAULT_TAG_STRING")
+
 (defmethod convert-resource-out (parent (type (eql 'font-list)) value)
   (declare (ignore parent))
+  (export-font-list value))
+
+(defun export-font-list (value)
   (when (atom value)
     (setq value (list value)))
-  (let* ((charset xm_string_default_char_set)
-	 (font-list
-	  (xm_font_list_create 
-	   (car value)
-	   charset)))
+  (let* ((font-list
+	  (xm_font_list_append_entry
+	   0			; old entry
+	   (xm_font_list_entry_create
+	    xm-font-list-default-tag
+	    xm-font-is-font
+	    (car value)))))
     (dolist (font (cdr value))
       (setq font-list
-	(xm_font_list_add font-list 
-			  font
-			  charset)))
+	(xm_font_list_append_entry font-list 
+				   (xm_font_list_entry_create
+				    ""
+				    xm-font-is-font
+				    font))))
     font-list))
 
 #+:dec3100
@@ -55,26 +65,21 @@
 	   (aref context 0)))
 	(res nil))
     (with-ref-par
-	((char-set 0)
-	 (font 0))
+	((type 0))
       (loop
-	(when (zerop 
-	       (xm_font_list_get_next_font
-		context
-		char-set
-		font))
-	  (return nil))
-	(push (list (let ((x (aref char-set 0)))
-		      (prog1
-			  (ff:char*-to-string x)
-		      (xt_free x)))
-		    (let ((x (aref font 0)))
-		      (intern-object-address
-		       x
-		       'font
-		       :name :unknown!)))
-	      res))
+	(let ((entry (xm_font_list_next_entry context)))
+	  (when (zerop entry)
+	    (return nil))
+	  (setf (aref type 0) 0)
+	  (push (list 
+		 xm_string_default_char_set
+		 (let ((font (xm_font_list_entry_get_font entry type)))
+		   (assert (= (aref type 0) 0))
+		   (intern-object-address
+		    font
+		    'font
+		    :name :unknown!)))
+		res)))
       (xm_font_list_free_font_context context)
       res)))
-	
 
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index 5f04e2a4..7b626170 100644
--- a/tk/xm-funs.lisp
+++ b/tk/xm-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-funs.lisp,v 1.6 92/08/18 17:53:50 cer Exp $
+;; $fiHeader: xm-funs.lisp,v 1.7 92/12/14 15:04:09 cer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -149,3 +149,39 @@
     :arg-checking nil
     :return-type :void)
 
+
+
+
+(defforeign 'xm_font_list_append_entry
+    :entry-point (ff:convert-to-lang "XmFontListAppendEntry")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
+
+(defforeign 'xm_font_list_entry_create
+    :entry-point (ff:convert-to-lang "XmFontListEntryCreate")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address foreign-address foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
+
+
+
+(defforeign 'xm_font_list_entry_get_font
+    :entry-point (ff:convert-to-lang "XmFontListEntryGetFont")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
+
+(defforeign 'xm_font_list_next_entry
+    :entry-point (ff:convert-to-lang "XmFontListNextEntry")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
-- 
GitLab