diff --git a/.cvsignore b/.cvsignore index 5d8aa2878417b1111425113a545c31ae3b8e9352..3424e022c569ba18016289df7c573438c61ded2a 100755 --- a/.cvsignore +++ b/.cvsignore @@ -7,3 +7,5 @@ slim slim.ol coverage-report.lisp postscript.output +test-suite-reportol.lisp +test-suite-reportxm.lisp diff --git a/Makefile.defs b/Makefile.defs index 167a6b5e27eb02328579ebe10c59c8cc15a554bf..45aa967201e5eb2a24492ffac3efbfa318f0911a 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.4 93/03/15 08:27:09 cer Exp $ +# $fiHeader: Makefile.defs,v 1.6 93/04/16 09:26:13 layer Exp $ # # Makefile.defs for CLIM 2.0 # @@ -22,12 +22,14 @@ TRAIN_TIMES=2 # view, file, print PSVIEW=:file HPGLVIEW=:file +TRAIN_COMPILE=t FRAME_TESTS=t TRAIN_LISP= \ (load \"misc/train.lisp\") \ - (train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES) :psview $(PSVIEW) :hpglview $(HPGLVIEW)) \ + (train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES)\ + :compile $(TRAIN_COMPILE) :psview $(PSVIEW) :hpglview $(HPGLVIEW)) \ (exit 0) TRAIN_TEXT = \ @@ -270,7 +272,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/stream-trampolines.fasl GENERIC-GADGETS = clim/db-menu.fasl clim/db-list.fasl clim/db-text.fasl silica/db-button.fasl \ - silica/db-slider.fasl silica/scroll-pane.fasl + silica/db-slider.fasl silica/scroll-pane.fasl silica/db-label.fasl XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl @@ -388,6 +390,7 @@ ALL_SRC = utils/excl-verification.lisp \ silica/db-border.lisp \ silica/db-scroll.lisp \ silica/db-button.lisp \ + silica/db-label.lisp \ silica/db-slider.lisp \ clim/gestures.lisp \ clim/defprotocol.lisp \ diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 5049ae6a41b545272168ea39d6356211fc50180e..96666b6cdd82ff6692b1d6139344bc2def1cad78 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.27 93/04/02 18:40:58 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.28 93/04/07 09:06:37 cer Exp $ (in-package :clim-internals) @@ -943,3 +943,34 @@ circular graphs without accounting for this case. (map nil #'(lambda (root) (traverse nil nil root max-depth)) root-objects))) + +;;-- This is a version that searches all of the old children. +;;-- Graph-output records can loose reorder children quite easily and +;;-- it seems worthwhile searching. + +(defmethod find-child-output-record + ((record basic-graph-output-record) use-old-children record-type + &rest initargs &key unique-id id-test &allow-other-keys) + (declare (dynamic-extent initargs)) + (flet ((do-match (candidate) + ;; (class-name (class-of ...)) should just be type-of, but not in PCL. + (and (eq record-type (class-name (class-of candidate))) + (apply #'match-output-records candidate initargs)))) + (let ((elts-to-find (when use-old-children (output-record-old-children record)))) + (if use-old-children + (let ((found-record + (if unique-id + (find-with-test unique-id elts-to-find + #'output-record-unique-id id-test) + ;; UNIQUE-ID can be NIL when we are coming through + ;; INVOKE-WITH-NEW-OUTPUT-RECORD to create new records + (or (and (do-match (first elts-to-find)) + (first elts-to-find)) + (dolist (child (output-record-old-children record)) + (when (do-match child) + (return child))))))) + (when found-record + (setf (output-record-old-children record) + (delete found-record (output-record-old-children record))) + found-record)) + (call-next-method))))) diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp index d0443ce9892956975bcb5d9398e8bd8b775a2bd1..8c85594ca498784569c8693ec01c24143ccfac91 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.17 93/03/31 10:38:40 cer Exp $ +;; $fiHeader: incremental-redisplay.lisp,v 1.18 93/04/07 09:06:42 cer Exp $ (in-package :clim-internals) @@ -946,7 +946,6 @@ ;;--- since we have to do the erase first ;;--- Anyway things are screwed up when the parent has changed ;;--- Since we dont know where things are. - ((and old-parent (not (eq (output-record-parent record) old-parent)) (not (eq (output-record-generation-tick old-parent) *generation-tick*))) diff --git a/demo/browser.lisp b/demo/browser.lisp index 747c51ef4a547291b81786ba179db25c923ec9a5..62693b989ca7b36cb80a04e9c38acdbcc96f80ea 100644 --- a/demo/browser.lisp +++ b/demo/browser.lisp @@ -3,7 +3,7 @@ ;;; Simple extensible browser ;;; Scott McKay -;; $fiHeader: browser.lisp,v 1.19 93/03/19 09:44:09 cer Exp $ +;; $fiHeader: browser.lisp,v 1.20 93/04/07 09:07:01 cer Exp $ (in-package :clim-browser) @@ -1345,8 +1345,8 @@ (define-browser-command (com-show-snapshots :menu t) () (with-slots (snapshots) *application-frame* (dolist (snapshot snapshots) - (fresh-line) - (present snapshot 'snapshot)))) + (fresh-line *query-io*) + (present snapshot 'snapshot :stream *query-io*)))) (define-browser-command (com-recover-snapshot :menu t) ((snapshot (with-slots (snapshots) *application-frame* diff --git a/misc/train.lisp b/misc/train.lisp index f037f632b936e638bfb86ce9378a28658fa541fd..aaf852185d86a92a0058d4f19898061006d43440 100644 --- a/misc/train.lisp +++ b/misc/train.lisp @@ -20,13 +20,21 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: train.lisp,v 1.4 93/03/19 09:44:22 cer Exp $ +;; $fiHeader: train.lisp,v 1.5 93/04/02 13:36:34 cer Exp $ -(defun train-clim (&key (train-times 2) (psview nil) (frame-tests t) (errorp t) (hpglview nil)) +(defun train-clim (&key (train-times 2) + (psview nil) + (frame-tests t) + (errorp t) + (hpglview nil) + (compile t)) (setq *global-gc-behavior* nil) - (load - "test/test.lisp") - (clim-user::with-test-reporting () + (load "test/test.lisp") + (clim-user::with-test-reporting (:file (if (excl::featurep :clim-motif) + "test-suite-reportxm.lisp" + "test-suite-reportol.lisp")) + (when compile + (load (compile-file "test/test-suite"))) (when frame-tests (clim-user::train-clim-2 train-times) (clim-user::do-frame-tests errorp)) diff --git a/test/test-driver.lisp b/test/test-driver.lisp index b685d5a3f79c49554068a1d275acd2e5a00ecbb1..79b5b7b0ac2c2986f951ec12ff9c05cba309136d 100644 --- a/test/test-driver.lisp +++ b/test/test-driver.lisp @@ -44,7 +44,8 @@ (defun handler-invocation-debugger-hook (invocation condition) (format excl:*initial-terminal-io* "The following error occurred: ~A~%" condition)) -(defun wait-for-clim-input-state (invocation &optional (timeout 300)) +(defvar *default-input-state-timeout* 300) +(defun wait-for-clim-input-state (invocation &optional (timeout *default-input-state-timeout*)) (let ((process (invocation-process invocation))) (mp:process-allow-schedule) (if timeout @@ -183,27 +184,27 @@ (when *test-successes* (push test (cdr *test-successes*)))) -(defmacro with-test-reporting ((&rest options &key) &body body) +(defmacro with-test-reporting ((&rest options &key file) &body body) `(invoke-with-test-reporting #'(lambda () ,@body) ,@options)) -(defun invoke-with-test-reporting (continuation) +(defun invoke-with-test-reporting (continuation &rest options) (let ((*test-successes* (list nil)) (*test-failures* (list nil))) (funcall continuation) (pop *test-successes*) (pop *test-failures*) - (generate-test-report))) + (apply #'generate-test-report options))) -(defun generate-test-report () +(defun generate-test-report (&key file) (format t "~4%") (when *test-failures* (format t "The following tests failed:~%") (dolist (x *test-failures*) (format t "~10t~A : ~A~%" (car x) (cdr x)))) - (when (probe-file "test-suite-report.lisp") + (when (probe-file file) (let (old-successes old-failures) - (with-open-file (*standard-input* "test-suite-report.lisp") + (with-open-file (*standard-input* file) (let ((*package* (find-package :clim-user))) (setq old-successes (read) old-failures (read)))) @@ -237,7 +238,7 @@ (format t "~10t~A ~%" x))) - (with-open-file (*standard-output* "test-suite-report.lisp" + (with-open-file (*standard-output* file :direction :output :if-exists :supersede) (let ((*package* (find-package :clim-user))) (print *test-successes*) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 5bc8dd99bba86d00e35564fad36387e218523067..8d13465882cfe27b19f694639a86cd5c0e0fff7a 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.59 93/04/07 17:23:55 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.60 93/04/08 13:18:17 colin Exp $ (in-package :clim-user) @@ -1006,7 +1006,7 @@ people, shall not perish from the earth. (circle 75 100 40 2) (circle 125 100 40 3)) (stream-set-cursor-position stream 0 150) - (format stream "~S" (accept 'integer :stream stream))) + (format stream "~&~S" (accept 'integer :stream stream))) (define-test (ordering-test-2a output-recording) (stream) "The three overlapping rectangles should have the correct sensitivity." @@ -1017,7 +1017,7 @@ people, shall not perish from the earth. (rect 0 0 100 100 2) (rect 25 25 125 125 3)) (stream-set-cursor-position stream 0 160) - (format stream "~S" (accept 'integer :stream stream))) + (format stream "~&~S" (accept 'integer :stream stream))) (define-test (ordering-test-2b output-recording) (stream) "The three overlapping rectangles should have the correct sensitivity." @@ -1028,7 +1028,7 @@ people, shall not perish from the earth. (rect 0 0 100 100 2) (rect 50 50 150 150 3)) (stream-set-cursor-position stream 0 240) - (format stream "~S" (accept 'integer :stream stream))) + (format stream "~&~S" (accept 'integer :stream stream))) (define-test (cursorpos-table output-recording) (stream) "Write some strings separated by horizontal cursor motion. After refreshing, the output should look the same." @@ -1877,7 +1877,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (dolist (point '((n 0 -30) (s 0 30) (e 30 0) (w -30 0))) (apply #'draw-compass-point stream ptype point))))) #+ignore (declare (dynamic-extent #'draw-compass-point #'draw-compass)) - (with-menu (menu stream :scroll-bars nil) + (with-menu (menu stream :scroll-bars nil :label "Compass point") #-silica (setf (window-label menu) "Compass point") (format stream "~S" (menu-choose-from-drawer menu 'menu-item #'draw-compass))))) @@ -2132,7 +2132,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (accepts (a (member :red :blue :green)) (b (subset :red :blue :green)) (c boolean) - (d (float 0 1) :view '(slider-view :decimal-places 2)) + (d (float 0 1) :view '(slider-view :width 100 :decimal-places 2)) (e (integer 0 10) :view +slider-view+) (f (member :red :blue :green) :view +text-field-view+) (g (integer 0 10) :view +text-field-view+) @@ -2566,7 +2566,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (terpri stream)))) (define-benchmark (clipped-text-output :iterations 3) (stream) - "Draw lines through a clipping region" + "Draw text through a clipping region" (with-drawing-options (stream :clipping-region *chess-board-clip-region*) (repeat 5 (write-string "Four" stream) diff --git a/test/test.lisp b/test/test.lisp index b2072e4685fdbf00f7bcffb9bf732e6b303a203e..a147c4c0eb0bbe7ee5a5498f7232d40030c4dfc3 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.45 93/03/19 09:46:41 cer Exp $ +;; $fiHeader: test.lisp,v 1.46 93/03/31 10:39:54 cer Exp $ (in-package :clim-user) @@ -89,7 +89,7 @@ x) (list +red+ +green+))) (:pointer-documentation t) - (:geometry :width 300 :height 300)) + (:geometry :width 800 :height 800)) ;;; More frames diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index a93546e83c4e998e38ce86063231f1714c2683bd..7000f27fab90ee0b8cf443b9d930e0260ad17e5e 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.42 93/03/31 10:40:12 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.43 93/04/02 13:37:17 cer Exp $ (in-package :xm-silica) @@ -187,8 +187,11 @@ basic-pane) ()) -(defmethod initialize-instance :after ((fr openlook-frame-pane) &key frame frame-manager contents thickness) - (declare (ignore frame frame-manager thickness)) +(defmethod initialize-instance :after ((fr openlook-frame-pane) &key + frame frame-manager contents thickness + background) + (declare (ignore frame frame-manager thickness) + (ignore background)) (sheet-adopt-child fr contents)) ;; OpenLook viewport @@ -441,6 +444,7 @@ ;;; Push button (defclass openlook-push-button (push-button + openlook-labelled-gadget openlook-action-pane xt-leaf-pane) ()) @@ -451,8 +455,7 @@ (parent t) (sheet openlook-push-button)) (with-accessors ((label gadget-label)) sheet - (values 'tk::oblong-button - (and label (list :label label))))) + (values 'tk::oblong-button nil))) ;; @@ -746,13 +749,13 @@ (incf sum-w width) (incf sum-h height) (maxf max-w width))) - (case orientation - (:horizontal (make-space-requirement - :width (+ sum-w (* spacing (1- (length children)))) - :height max-h)) - (:vertical (make-space-requirement - :width max-w - :height (+ sum-h (* spacing (1- (length children)))))))))) + (ecase orientation + (:fixedrows (make-space-requirement + :width (+ sum-w (* spacing (1- (length children)))) + :height max-h)) + (:fixedcols (make-space-requirement + :width max-w + :height (+ sum-h (* spacing (1- (length children)))))))))) ;;; @@ -823,6 +826,7 @@ (mmax 100)) (values (if editablep 'tk::slider 'tk::gauge) (append + (list :drag-c-b-type :release) #+dunno (and label (list :title-string label)) (list :slider-min mmin @@ -935,19 +939,16 @@ (normalize-space-for-text-field-or-label sheet sr)) -(defun process-width-specification (sheet width) - (break "Make me work") +(defmethod process-width-specification (sheet width) (when (numberp width) (return-from process-width-specification width)) (let ((chars (etypecase width (list (assert (eq (second width) :character)) (first width)) (string (length width))))) - (multiple-value-bind (font left-margin right-margin) - (tk::get-values (sheet-direct-mirror sheet) - :font :left-margin :right-margin) + (let ((font (tk::get-values (sheet-direct-mirror sheet) :font))) (let ((font-width (font-list-max-width-and-height font))) - (+ (* 2 (+ left-margin right-margin)) (* font-width chars)))))) + (* font-width chars))))) (defun font-list-max-width-and-height (font) (values (tk::font-width font) (tk::font-height font))) @@ -962,9 +963,8 @@ (first width)) (string (length width))))) (multiple-value-bind (font top-margin bottom-margin) - (tk::get-values (sheet-direct-mirror sheet) - :font :top-margin :bottom-margin) - (let ((font-height (nth-value 1 (font-list-max-width-and-height font-list)))) + (tk::get-values (sheet-direct-mirror sheet) :font :top-margin :bottom-margin) + (let ((font-height (nth-value 1 (font-list-max-width-and-height font)))) (+ top-margin bottom-margin (* font-height chars)))))) @@ -1012,6 +1012,18 @@ (and value `(:source ,value)) (list :wrap-mode (if word-wrap :wrap-white-space :wrap-off)))))) +(defmethod process-width-specification ((sheet openlook-text-editor) width) + (when (numberp width) (return-from process-width-specification width)) + (let ((chars (etypecase width + (list + (assert (eq (second width) :character)) + (first width)) + (string (length width))))) + (multiple-value-bind (font left-margin right-margin) + (tk::get-values (sheet-direct-mirror sheet) :font :left-margin :right-margin) + (let ((font-width (font-list-max-width-and-height font))) + (+ left-margin right-margin (* font-width chars)))))) + (defmethod (setf gadget-word-wrap) :after (nv (gadget openlook-text-editor)) (tk::set-values (sheet-direct-mirror gadget) :wrap-mode (if word-wrap :wrap-white-space :wrap-off))) @@ -1471,7 +1483,7 @@ (test set-gadget-test)) sheet (let ((item (find nv items :test test :key value-key))) (assert item) - (let ((button (find item (option-menu-buttons sheet) :key #'second))) + (let ((button (car (find item (option-menu-buttons sheet) :key #'second)))) (with-no-value-changed-callbacks (tk::set-values button :default t)))))) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 18c4447ae9298ccd75768aa98b2f89a3cdb4f5dc..c489c77c91cf98324c70ceb72dc0a7807181f278 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.52 93/04/02 13:37:20 cer Exp $ +;; $fiHeader: xm-frames.lisp,v 1.53 93/04/08 13:19:00 colin Exp $ (in-package :xm-silica) @@ -273,56 +273,6 @@ ;;--- Perhaps port-update-frame-settings ? -(defmethod update-frame-settings ((framem motif-frame-manager) (frame t)) - ;;--- Lets see how this works out - (let ((shell (sheet-shell (frame-top-level-sheet frame)))) - (let ((sr (compose-space (frame-top-level-sheet frame)))) - (tk::set-values shell - :min-width (fix-coordinate (space-requirement-min-width sr)) - :min-height (fix-coordinate (space-requirement-min-height sr)))) - - (let ((geo (clim-internals::frame-geometry frame))) - (destructuring-bind - (&key left top width height &allow-other-keys) geo - ;;-- what about width and height - (when (and width height) - (tk::set-values shell :width (fix-coordinate width) - :height (fix-coordinate height))) - (when (and left top) - (tk::set-values shell - :x (fix-coordinate left) - :y (fix-coordinate top))))) - - (tk::set-values shell :title (frame-pretty-name frame)) - (let ((icon (clim-internals::frame-icon frame))) - (flet ((decode-pixmap (x) - (etypecase x - (string x) - (pattern - (let ((sheet (frame-top-level-sheet frame))) - (with-sheet-medium (medium sheet) - (second - (decode-gadget-background medium sheet x)))))))) - (destructuring-bind - (&key (name (frame-pretty-name frame)) pixmap clipping-mask) icon - ;;-- Dialog shells do not have :icon-name resource - (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 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 (or name (frame-pretty-name frame))))))) - - ;;; (defmethod frame-manager-construct-menu @@ -576,9 +526,12 @@ (:menu-bar nil)) -(defmethod clim-internals::frame-manager-get-menu ((framem motif-frame-manager) &key scroll-bars) +(defmethod clim-internals::frame-manager-get-menu ((framem + motif-frame-manager) &key scroll-bars + label) (let ((frame (make-application-frame 'motif-menu-frame :scroll-bars scroll-bars + :label label :frame-manager framem :save-under t))) ;; This so that ports can do something interesting with popped-up diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index a33d6d70d4ff690677b366340719884f07e43b34..34d0201b80de2d8925be9285c9175ef90a14a389 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.33 93/04/02 13:37:30 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.34 93/04/07 09:07:25 cer Exp $ (in-package :xm-silica) @@ -57,14 +57,6 @@ (defclass motif-geometry-manager (xt-geometry-manager) ()) - -(defmethod change-widget-geometry ((parent tk::xm-dialog-shell) child - &rest args - &key x y width height) - (declare (ignore x y args)) - (tk::set-values child :width width :height height :x x :y y)) - - (defmethod find-shell-class-and-initargs ((port motif-port) sheet) (if (popup-frame-p sheet) (values 'tk::xm-dialog-shell diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index a4311266849c16952fa08e274f532f660088f837..6feeec4df90d84d5ef5127cbb6f23f5ddcfbef61 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.31 93/04/02 13:37:33 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.32 93/04/08 13:19:06 colin Exp $ (in-package :xm-silica) @@ -241,3 +241,52 @@ (map-over-sheets #'update-sheet sheet))))) + +(defmethod update-frame-settings ((framem xt-frame-manager) (frame t)) + ;;--- Lets see how this works out + (let ((shell (sheet-shell (frame-top-level-sheet frame)))) + (let ((sr (compose-space (frame-top-level-sheet frame)))) + (tk::set-values shell + :min-width (fix-coordinate (space-requirement-min-width sr)) + :min-height (fix-coordinate (space-requirement-min-height sr)))) + + (let ((geo (clim-internals::frame-geometry frame))) + (destructuring-bind + (&key left top width height &allow-other-keys) geo + ;;-- what about width and height + (when (and width height) + (tk::set-values shell :width (fix-coordinate width) + :height (fix-coordinate height))) + (when (and left top) + (tk::set-values shell + :x (fix-coordinate left) + :y (fix-coordinate top))))) + + (tk::set-values shell :title (frame-pretty-name frame)) + (let ((icon (clim-internals::frame-icon frame))) + (flet ((decode-pixmap (x) + (etypecase x + (string x) + (pattern + (let ((sheet (frame-top-level-sheet frame))) + (with-sheet-medium (medium sheet) + (second + (decode-gadget-background medium sheet x)))))))) + (destructuring-bind + (&key (name (frame-pretty-name frame)) pixmap clipping-mask) icon + ;;-- Dialog shells do not have :icon-name resource + (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 frame-manager-note-pretty-name-changed ((framem xt-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 (or name (frame-pretty-name frame)))))))