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