From b08bc0aadd3fc2a8b27b5b32b1e6d1e695f1b028 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Mon, 9 Nov 1992 10:56:25 +0000 Subject: [PATCH] * Makefile : Added db-text to GENERIC-GADGETS. climtoys now in clim directory * clim/frames.lisp : (setf frame-pretty-name) updates window title and icon * clim/ptypes1.lisp : presentation-subtypep to handle second argument of and/or * demos/navfun.lisp : Fixed delete command Changed gestures * genera/genera-mirror.lisp : Removed #+ignore * misc/compile-1.lisp : climtoys in clim-2.0 directory * misc/dev-load-1.lisp : ditto * silica/framem.lisp : disown-frame NILs shell, initialized-panes and frame-panes slots * tk/callbacks.lisp : browse-selection handled * tk-silica/xm-frames.lisp : (setf frame-pretty-name) updates title and icon-name * tk-silica/xm-gadgets.lisp : Fix :exclusive mode list-pane * utils/lisp-utilities.lisp : Disable package locking for deftype eql --- .cvsignore | 7 ++++++ Makefile | 13 +++++------ clim/accept-values.lisp | 44 +++++++++++++++++++++++--------------- clim/db-list.lisp | 4 +++- clim/db-stream.lisp | 3 ++- clim/frames.lisp | 22 ++++++++++++++++++- clim/gadget-output.lisp | 26 ++++++++-------------- clim/ptypes2.lisp | 19 +++++++++++++--- demo/navfun.lisp | 15 ++++++------- demo/plot.lisp | 8 ++++--- genera/genera-mirror.lisp | 4 +--- misc/compile-1.lisp | 6 +++--- misc/dev-load-1.lisp | 6 +++--- silica/framem.lisp | 5 ++++- tk-silica/xm-frames.lisp | 15 ++++++++++--- tk-silica/xm-gadgets.lisp | 16 ++++++++------ tk-silica/xt-graphics.lisp | 4 ++-- tk/callbacks.lisp | 4 ++-- utils/lisp-utilities.lisp | 6 +++++- 19 files changed, 145 insertions(+), 82 deletions(-) create mode 100755 .cvsignore diff --git a/.cvsignore b/.cvsignore new file mode 100755 index 00000000..d92d458e --- /dev/null +++ b/.cvsignore @@ -0,0 +1,7 @@ +stub-xt.c +stub-x.c +stub-olit.c +stub-motif.c +Clim-sizes.n +slim + diff --git a/Makefile b/Makefile index 7b929f12..0b3f306f 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.59 92/11/05 19:24:25 cer Exp $ +# $fiHeader: Makefile,v 1.60 92/11/05 19:28:07 cer Exp $ # # Makefile for CLIM 2.0 # @@ -13,6 +13,7 @@ CLOPTS = -qq TRAIN_TIMES=2 TRAIN_LISP= \ + (progn \ (load \"test/test.lisp\") \ (clim-user::train-clim-2 $(TRAIN_TIMES)) \ (clim-user::do-frame-tests) \ @@ -20,8 +21,8 @@ TRAIN_LISP= \ :output-file \ (if (excl::featurep :clim-motif) \"misc/clos-preloadxm.fasl\" \ \"misc/clos-preloadol.fasl\") \ - ) \ - (exit 0) + )) \ + (exit 0) TRAIN_TEXT = \ $(ECHO) "\ @@ -266,7 +267,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/item-list-manager.fasl \ clim/stream-trampolines.fasl -GENERIC-GADGETS = clim/db-menu.fasl clim/db-text.fasl silica/db-button.fasl \ +GENERIC-GADGETS = clim/db-menu.fasl clim/db-list.fasl clim/db-text.fasl silica/db-button.fasl \ silica/db-slider.fasl XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl @@ -672,7 +673,7 @@ BENCHMARK_FILE=nil benchmark: $(ECHO) "\ - (load \"/vapor/usr/tech/cer/stuff/climtoys/test-clim.lisp\") \ + (load \"climtoys/test-clim.lisp\") \ (clim-user::benchmark-clim $(BENCHMARK_FILE)) \ " | $(CLIM) $(CLOPTS) -batch @@ -681,7 +682,7 @@ PSVIEW=view testps : $(ECHO) "\ - (load \"/vapor/usr/tech/cer/stuff/climtoys/test-clim.lisp\") \ + (load \"climtoys/test-clim.lisp\") \ (load \"test/postscript-tests.lisp\") \ (clim-user::run-postscript-tests :output :$(PSVIEW)) \ " | $(CLIM) $(CLOPTS) -batch diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 7bfaf989..8d41e054 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.40 92/10/28 11:31:22 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.41 92/11/06 18:58:53 cer Exp $ (in-package :clim-internals) @@ -11,9 +11,10 @@ ;;; For historical reasons "AVV" means "accepting-values"... (defclass accept-values-stream - (standard-encapsulating-stream) + (standard-encapsulating-stream) ((avv-record :initform nil) - (avv-frame :initform nil))) + (avv-frame :initform nil) + (align-prompts :initform nil :initarg :align-prompts))) ;; Don't allow old AVV queries to be sensitive (defvar *accept-values-tick* 0) @@ -105,7 +106,7 @@ &allow-other-keys) (declare (dynamic-extent accept-args)) ;;--- When ACTIVE-P is NIL, this should do some sort of "graying out" - (let ((align-prompts (slot-value (slot-value stream 'avv-frame) 'align-prompts)) + (let ((align-prompts (slot-value stream 'align-prompts)) query-identifier query) (cond (align-prompts ;; The user has asked to line up the labels, so oblige him @@ -206,7 +207,6 @@ :initform nil :initarg :initially-select-query-identifier) (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass) (check-overlapping :initform t :initarg :check-overlapping) - (align-prompts :initform nil :initarg :align-prompts) (own-window :initform nil :initarg :own-window) (own-window-properties :initform nil :initarg :own-window-properties)) (:top-level (accept-values-top-level)) @@ -293,7 +293,6 @@ (cons initially-select-query-identifier modify-initial-query)) :resynchronize-every-pass resynchronize-every-pass :check-overlapping check-overlapping - :align-prompts align-prompts :resize-frame resize-frame :scroll-bars scroll-bars))) (when command-table @@ -314,11 +313,11 @@ (cons initially-select-query-identifier modify-initial-query)) :resynchronize-every-pass resynchronize-every-pass :check-overlapping check-overlapping - :align-prompts align-prompts ;; This frame won't necessarily be adopted, so make ;; sure that we share the sheet with the parent frame ;; in the case of "inlined" dialogs :top-level-sheet (frame-top-level-sheet *application-frame*)))) + (setf (slot-value avv-stream 'align-prompts) align-prompts) (when command-table (setf (frame-command-table frame) command-table)) (unwind-protect @@ -335,9 +334,10 @@ (defmethod accept-values-top-level ((frame accept-values) &rest args) (declare (ignore args)) (with-slots (stream continuation resynchronize-every-pass check-overlapping - align-prompts selected-item initially-select-query-identifier + selected-item initially-select-query-identifier own-window own-window-properties exit-button-stream) frame (let* ((original-view (stream-default-view stream)) + (align-prompts (slot-value stream 'align-prompts)) (return-values nil) (initial-query nil) exit-button-record @@ -1034,11 +1034,16 @@ ;; guaranteed that those queries will be valid at all times. (defun accept-values-pane-displayer (frame pane &key displayer + align-prompts resynchronize-every-pass (check-overlapping t) max-height max-width) (declare (ignore max-height max-width)) - (let* ((stream-and-record (and (not *frame-layout-changing-p*) + (setq align-prompts (ecase align-prompts + ((t :right) :right) + ((:left) :left) + ((nil) nil))) + (let* ((stream-and-record (and (not *frame-layout-changing-p*) (gethash pane *pane-to-avv-stream-table*))) (avv-stream (car stream-and-record)) (avv-record (cdr stream-and-record))) @@ -1050,20 +1055,25 @@ (when resynchronize-every-pass (redisplay avv-record avv-stream :check-overlapping check-overlapping))))) (t - (accept-values-pane-displayer-1 frame pane displayer))))) + (accept-values-pane-displayer-1 frame pane displayer align-prompts))))) -(defun accept-values-pane-displayer-1 (frame pane displayer) - (let ((avv-stream (make-instance 'accept-values-stream :stream pane)) +(defun accept-values-pane-displayer-1 (frame pane displayer align-prompts) + (let ((avv-stream (make-instance 'accept-values-stream + :align-prompts align-prompts + :stream pane)) (avv-record nil)) (setf (slot-value avv-stream 'avv-frame) frame) (letf-globally (((stream-default-view pane) (frame-manager-dialog-view (frame-manager frame)))) (setq avv-record - (updating-output (avv-stream) - (with-new-output-record - (avv-stream 'accept-values-output-record avv-record) - (setf (slot-value avv-stream 'avv-record) avv-record) - (funcall displayer frame avv-stream))))) + (updating-output (avv-stream) + (with-new-output-record + (avv-stream 'accept-values-output-record avv-record) + (setf (slot-value avv-stream 'avv-record) avv-record) + (if align-prompts + (formatting-table (avv-stream) + (funcall displayer frame avv-stream)) + (funcall displayer frame avv-stream)))))) (unless *sizing-application-frame* (setf (gethash pane *pane-to-avv-stream-table*) (cons avv-stream avv-record))))) diff --git a/clim/db-list.lisp b/clim/db-list.lisp index 895c023b..5440a1ec 100644 --- a/clim/db-list.lisp +++ b/clim/db-list.lisp @@ -1,7 +1,9 @@ -u;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- "Copyright (c) 1992 by Symbolics, Inc. All rights reserved." +;; $fiHeader: db-stream.lisp,v 1.35 92/11/06 18:59:18 cer Exp $ + (in-package :silica) ;yes, this file is in the Silica package ;;; List panes and option panes diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 495bdcf9..6e3abcd6 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.34 92/10/28 11:31:30 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.35 92/11/06 18:59:18 cer Exp $ (in-package :clim-internals) @@ -413,6 +413,7 @@ (defmethod (setf window-label) (label (stream clim-stream-sheet)) nil) + (defmethod (setf window-visibility) (visibility (stream clim-stream-sheet)) (let ((frame (pane-frame stream))) (if frame diff --git a/clim/frames.lisp b/clim/frames.lisp index da21ecf5..f58ad346 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.48 92/10/28 11:31:36 cer Exp $ +;; $fiHeader: frames.lisp,v 1.49 92/11/06 18:59:35 cer Exp $ (in-package :clim-internals) @@ -711,11 +711,31 @@ nil) + +;;; + +(defmethod (setf frame-pretty-name) :before (nv (frame standard-application-frame)) + (assert (typep nv 'string) () + "The new pretty-name is not a string")) + +(defmethod (setf frame-pretty-name) :after (nv (frame standard-application-frame)) + (declare (ignore nv)) + (let ((framem (frame-manager frame))) + (when framem (frame-manager-note-pretty-name-changed framem frame)))) + +(defmethod frame-manager-note-pretty-name-changed ((framem standard-frame-manager) + (frame standard-application-frame)) + nil) + +;;; + + (define-condition frame-exit (condition) ((frame :initarg :frame :reader frame-exit-frame)) (:report (lambda (condition stream) (format stream "Exit from frame ~A" (frame-exit-frame condition))))) + (defgeneric run-frame-top-level (frame &key &allow-other-keys)) ;;--- It would be nice to have the CLIM 0.9 START-FRAME and STOP-FRAME functions diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 44714f97..6262d86c 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.35 92/10/29 15:02:40 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.36 92/11/06 18:59:38 cer Exp $ (in-package :clim-internals) @@ -284,9 +284,9 @@ ;;--- number of items, etc. +radio-box-view+) -(define-presentation-method gadget-includes-prompt-p - ((type completion) (stream t) (view radio-box-view)) - t) +;(define-presentation-method gadget-includes-prompt-p +; ((type completion) (stream t) (view radio-box-view)) +; nil) (define-presentation-method accept-present-default ((type completion) stream (view radio-box-view) @@ -349,11 +349,7 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier)))))) - (values (if (stringp prompt) - (vertically () - (make-pane 'label-pane :label prompt) - (outlining () radio-box)) - (outlining () radio-box)) + (values (outlining () radio-box) radio-box)))))) @@ -364,9 +360,9 @@ (framem standard-frame-manager) &key) +check-box-view+) -(define-presentation-method gadget-includes-prompt-p - ((type subset-completion) (stream t) (view check-box-view)) - t) +;(define-presentation-method gadget-includes-prompt-p +; ((type subset-completion) (stream t) (view check-box-view)) +; nil) (define-presentation-method accept-present-default ((type subset-completion) stream (view check-box-view) @@ -432,11 +428,7 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier)))))) - (values (if (stringp prompt) - (vertically () - (make-pane 'label-pane :label prompt) - (outlining () check-box)) - (outlining () check-box)) + (values (outlining () check-box) check-box))))) diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index beae1b18..2546b744 100644 --- a/clim/ptypes2.lisp +++ b/clim/ptypes2.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes2.lisp,v 1.16 92/11/05 17:15:39 cer Exp $ +;; $fiHeader: ptypes2.lisp,v 1.17 92/11/06 19:00:24 cer Exp $ (in-package :clim-internals) @@ -398,10 +398,23 @@ type-parameters) (values t t) (values nil nil))) + ((eq type-name 'or) - (values nil nil)) + (if (every #'(lambda (type) + (presentation-subtypep type putative-supertype)) + type-parameters) + (values t t) + (values nil nil))) + ((eq supertype-name 'and) - (values nil nil)) + (if (every #'(lambda (supertype) + (with-presentation-type-decoded (type-name) type + (unless (member type-name '(not satisfies)) + (presentation-subtypep type supertype)))) + supertype-parameters) + (values t t) + (values nil nil))) + ((eq supertype-name 'or) (if (some #'(lambda (supertype) (presentation-subtypep type supertype)) supertype-parameters) diff --git a/demo/navfun.lisp b/demo/navfun.lisp index 78299308..b4533a66 100644 --- a/demo/navfun.lisp +++ b/demo/navfun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: navfun.lisp,v 1.18 92/10/07 14:43:39 cer Exp $ +;; $fiHeader: navfun.lisp,v 1.19 92/10/28 11:33:01 cer Exp $ (in-package :clim-demo) @@ -1259,11 +1259,10 @@ '(or aircraft victor-airway route named-position ground-position)) ;;; Delete <object> -(define-flight-planner-command (com-delete-object :name t :menu "Delete") +(define-flight-planner-command com-delete-object ((object 'concrete-object :prompt "Object") - &key - (presentation 't :default nil) - (window 't :default nil)) + (presentation 't) + (window 't)) (let ((stream (frame-standard-input *application-frame*))) (etypecase object (ground-position @@ -1290,7 +1289,7 @@ ;; So that we don't see the keyword arguments... (format stream "Delete Object ~A" object))) (object presentation window) - (list object :presentation presentation :window window)) + (list object presentation window)) ;;; Describe <object> (define-flight-planner-command (com-describe-object :name t :menu "Describe") @@ -1410,13 +1409,13 @@ (define-presentation-to-command-translator flight-plan (route com-flight-plan flight-planner - :gesture :describe + :gesture :edit :priority +1) (object) (list object)) (define-flight-planner-command (com-show-distance :name t :menu t) - ((start 'route-start-object :gesture :select) + ((start 'route-start-object) (end 'route-start-object)) (multiple-value-bind (distance tc) (geodesic (point-latitude start) diff --git a/demo/plot.lisp b/demo/plot.lisp index 209306ee..76ff9378 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.15 92/10/29 16:55:34 cer Exp $ +;; $fiHeader: plot.lisp,v 1.16 92/11/06 19:03:02 cer Exp $ (in-package :clim-demo) @@ -495,8 +495,9 @@ :label "Options" :scroll-bars :both :display-function `(accept-values-pane-displayer - :resynchronize-every-pass t - :displayer display-options) + :align-prompts t + :resynchronize-every-pass t + :displayer display-options) :width :compute :height :compute) (command :interactor :height '(5 :line))) (:pointer-documentation t) @@ -798,6 +799,7 @@ (defvar *plot-demos* nil) + (defun do-plot-demo (&key (port (find-port)) (force nil)) (let* ((framem (find-frame-manager :port port)) (frame diff --git a/genera/genera-mirror.lisp b/genera/genera-mirror.lisp index 9361d41f..ff8c83af 100644 --- a/genera/genera-mirror.lisp +++ b/genera/genera-mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-mirror.lisp,v 1.13 92/10/28 11:32:41 cer Exp Locker: cer $ +;; $fiHeader: genera-mirror.lisp,v 1.14 92/11/05 17:15:44 cer Exp $ (in-package :genera-clim) @@ -603,7 +603,6 @@ (pointer (port-pointer port))) ;;----- There should be no need to do this ;;----- button up/down should have updated the state - #+ignore (if (zerop mouse-buttons) (setf (pointer-button-state pointer) 0) (setf (pointer-button-state pointer) @@ -628,7 +627,6 @@ (pointer (port-pointer port))) ;;-- This looks bogus ;;-- Are there not multiple buttons?? - #+ignore (setf (pointer-button-state pointer) 0) (when sheet (distribute-event diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 6b363878..469ff450 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.14 92/11/05 17:15:56 cer Exp $ +;; $fiHeader: compile-1.lisp,v 1.15 92/11/06 19:03:27 cer Exp $ (in-package :user) @@ -74,8 +74,8 @@ (clim-defsys::compile-system 'clim-demo :propagate t) (load "compatibility/sysdcl.lisp") (clim-defsys::load-system 'clim-demo) - (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") - (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") + (when (probe-file "climtoys/sysdcl.lisp") + (load "climtoys/sysdcl.lisp") (clim-defsys::compile-system 'clim-toys)) (load "compatibility/sysdcl.lisp") #+ignore diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 2f4258dc..7a23c619 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.18 92/11/05 17:15:57 cer Exp $ +;; $fiHeader: dev-load-1.lisp,v 1.19 92/11/06 19:03:29 cer Exp $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -69,8 +69,8 @@ (clim-defsys::load-system 'clim-demo) - (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") - (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") + (when (probe-file "climtoys/sysdcl.lisp") + (load "climtoys/sysdcl.lisp") (tenuring (clim-defsys::load-system 'clim-toys))) (ignore-errors (require :composer)) diff --git a/silica/framem.lisp b/silica/framem.lisp index eb4fc26c..e40dcd10 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: framem.lisp,v 1.22 92/10/28 13:17:08 cer Exp $ +;; $fiHeader: framem.lisp,v 1.23 92/11/06 19:03:48 cer Exp $ (in-package :silica) @@ -134,6 +134,9 @@ (defmethod disown-frame :after ((framem standard-frame-manager) frame) (setf (frame-manager-frames framem) (delete frame (frame-manager-frames framem)) + (frame-shell frame) nil + (slot-value frame 'clim-internals::initialized-panes) nil + (frame-panes frame) nil (slot-value frame 'frame-manager) nil)) (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 597b305d..70ff3936 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.36 92/11/05 17:15:59 cer Exp $ +;; $fiHeader: xm-frames.lisp,v 1.37 92/11/06 19:04:31 cer Exp $ (in-package :xm-silica) @@ -269,15 +269,24 @@ (second (decode-gadget-background medium sheet x)))))))) (destructuring-bind - (&key name pixmap clipping-mask) icon + (&key (name (frame-pretty-name frame)) pixmap clipping-mask) icon ;;-- Dialog shells do not have :icon-name resource - (when (and name (typep shell 'tk::top-level-shell)) + (when (typep shell 'tk::top-level-shell) (tk::set-values shell :icon-name name)) (when pixmap (tk::set-values shell :icon-pixmap (decode-pixmap pixmap))) (when clipping-mask (tk::set-values shell :clip-mask (decode-pixmap clipping-mask)))))))) +(defmethod clim-internals::frame-manager-note-pretty-name-changed ((framem motif-frame-manager) + (frame standard-application-frame)) + (let ((shell (frame-shell frame))) + (tk::set-values shell :title (frame-pretty-name frame)) + (when (typep shell 'tk::top-level-shell) + (destructuring-bind (&key name &allow-other-keys) (clim-internals::frame-icon frame) + ;;-- Dialog shells do not have :icon-name resource + (tk::set-values shell :icon-name (frame-pretty-name frame)))))) + ;;; diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 08b4a2a5..8b73b4ca 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.53 92/11/06 14:32:44 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.54 92/11/06 19:04:34 cer Exp $ (in-package :xm-silica) @@ -891,7 +891,7 @@ :selected-items ,selected-items)) :selection-policy ,(ecase mode - (:exclusive :single-select) + (:exclusive :browse-select) (:nonexclusive :multiple-select)) ,@(and visible-items `(:visible-item-count ,visible-items)) :items ,(mapcar name-key items) @@ -901,10 +901,12 @@ (declare (ignore item-count)) (let ((item (funcall (set-gadget-value-key sheet) (nth (1- item-position) (set-gadget-items sheet))))) - (queue-value-changed-event - widget sheet - (and (not (funcall (set-gadget-test sheet) item (gadget-value sheet))) - item)))) + ;;-- In browse select mode you get told when it is clicked on + ;;-- even if it is already set. + (unless (funcall (set-gadget-test sheet) item (gadget-value sheet)) + (queue-value-changed-event + widget sheet + item)))) (defun list-pane-multiple-selection-callback (widget item-positions sheet) (declare (ignore item-count)) @@ -920,7 +922,7 @@ (defmethod add-sheet-callbacks ((port motif-port) (sheet motif-list-pane) (widget xt::xm-list)) (ecase (list-pane-mode sheet) (:exclusive - (tk::add-callback widget :single-selection-callback + (tk::add-callback widget :browse-selection-callback 'list-pane-single-selection-callback sheet)) (:nonexclusive (tk::add-callback widget :multiple-selection-callback diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index c191ef1f..10bfe5b9 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.49 92/11/06 10:01:19 colin Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.50 92/11/06 19:04:40 cer Exp $ (in-package :tk-silica) @@ -97,7 +97,7 @@ (let ((frame (pane-frame (medium-sheet medium)))) (if frame (frame-palette frame) - (port-default-palette (port sheet))))) + (port-default-palette (port medium))))) #+ignore (defmethod (setf frame-manager-palette) :after diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 6828ff73..65029fbc 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.17 92/09/08 10:34:01 cer Exp $ +;; $fiHeader: callbacks.lisp,v 1.18 92/09/24 09:37:16 cer Exp $ (in-package :tk) @@ -125,7 +125,7 @@ ("cancelCallback") ("applyCallback") ("okCallback") - ("browseSelectionCallback") + ("browseSelectionCallback" :single-selection) ("singleSelectionCallback" :single-selection) ("defaultActionCallback") ("extendedSelectionCallback") diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index f25fa977..fe0b8219 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: lisp-utilities.lisp,v 1.21 92/10/28 11:31:05 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.22 92/11/06 19:05:07 cer Exp $ (in-package :clim-utils) @@ -1223,8 +1223,12 @@ (defun realp (x) (typep x 'real)) +;;--- Why do we need this. Whats wrong with member???? + #+(or Allegro Cloe-Runtime) +(#+Allegro excl::without-package-locks #-Allegro progn (deftype eql (x) `(member ,x)) +) (defconstant *end-of-file-marker* :eof) (deftype end-of-file-marker () -- GitLab