From f435f558ff29ffe3f408e035765c2ec6b301c201 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Fri, 2 Apr 1993 13:37:41 +0000 Subject: [PATCH] Makefile.defs Minor mods and added support for climhpgl.fasl and tests Removed xm-menus,graphics, and ol-graphics.lisp Makefile.generic added support for climhpgl.fasl and tests clim/accept-values.lisp graphic labels in accept-values-command-buttons clim/frames.lisp Added frame-current-panes, fixed problem with command disabling. clim/pixmap-streams.lisp Changed indentation climtoys/ccc.lisp Added com-show-class-generic-functions demo/bitmap-editor.lisp Indentation hpgl/hpgl-port.lisp Made hpgl-port have palette hpgl/pkg.lisp Fixed provide misc/compile-1.lisp Compile hpgl now misc/dev-load-1.lisp load hpgl now misc/train.lisp hpgl training, reporting of test results postscript/postscript-port.lisp calls make-palette sys/sysdcl.lisp removed ol-graphics etc test/postscript-tests.lisp output file name depends on type. test/test-clim.lisp Added etsts test/test-driver.lisp Support for reporting of tests tk/xlib.lisp Added composestatus support tk-silica/ol-gadgets.lisp Menu bar remembers buttons for disabling tk-silica/xm-frames.lisp Menu bar remembers buttons for disabling, accelerators only for pulldown menus tk-silica/xm-gadgets.lisp compose-space buttons with pixmap labels tk-silica/xm-silica.lisp minor mod tk-silica/xt-frames.lisp mapping from command to button to support disabling tk-silica/xt-graphics.lisp added make-medium method for xt-port tk-silica/xt-silica.lisp compose-status support --- Makefile.defs | 17 +++----- Makefile.generic | 11 +++-- clim/accept-values.lisp | 24 +++++++---- clim/frames.lisp | 18 ++++++-- hpgl/hpgl-port.lisp | 7 ++- misc/compile-1.lisp | 11 ++++- misc/dev-load-1.lisp | 3 +- misc/train.lisp | 27 ++++++++---- sys/sysdcl.lisp | 5 +-- test/test-clim.lisp | 64 +++++++++++++++++++++------ test/test-driver.lisp | 88 +++++++++++++++++++++++++++++++++++--- tk-silica/ol-gadgets.lisp | 12 +++++- tk-silica/xm-frames.lisp | 45 +++++++++++-------- tk-silica/xm-gadgets.lisp | 22 +++++++--- tk-silica/xm-silica.lisp | 32 +++++--------- tk-silica/xt-frames.lisp | 33 +++++++++++++- tk-silica/xt-graphics.lisp | 7 ++- tk-silica/xt-silica.lisp | 8 ++-- tk/xlib.lisp | 10 ++--- 19 files changed, 326 insertions(+), 118 deletions(-) diff --git a/Makefile.defs b/Makefile.defs index 292789ab..8e598407 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.3 93/03/04 18:59:13 colin Exp $ +# $fiHeader: Makefile.defs,v 1.4 93/03/15 08:27:09 cer Exp $ # # Makefile.defs for CLIM 2.0 # @@ -20,13 +20,14 @@ MV = /usr/fi/mv-nfs TRAIN_TIMES=2 # view, file, print -PSVIEW=file +PSVIEW=:file +HPGLVIEW=:file FRAME_TESTS=t TRAIN_LISP= \ (load \"misc/train.lisp\") \ - (train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \ + (train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES) :psview $(PSVIEW) :hpglview $(HPGLVIEW)) \ (exit 0) TRAIN_TEXT = \ @@ -105,7 +106,7 @@ OLC_UNDEFS=misc/undefinedsymbols.colit # These are the fasls and the .o that form the product -CLIM_GENERIC_FASLS=climg.fasl clim-debug.fasl climps.fasl climgg.fasl +CLIM_GENERIC_FASLS=climg.fasl clim-debug.fasl climps.fasl climgg.fasl climhpgl.fasl CLIM_OL_FASLS= climol.fasl clim-debugol.fasl CLIM_XM_FASLS= climxm.fasl clim-debugxm.fasl # clim1compat.fasl @@ -315,14 +316,12 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xt-stipples.fasl \ tk-silica/xm-silica.fasl \ tk-silica/xt-graphics.fasl \ - tk-silica/xm-graphics.fasl \ tk-silica/image.fasl \ tk-silica/xt-frames.fasl \ tk-silica/xm-frames.fasl \ tk-silica/xm-dialogs.fasl \ tk-silica/xt-gadgets.fasl \ tk-silica/xm-gadgets.fasl \ - tk-silica/xm-menus.fasl \ tk-silica/xt-pixmaps.fasl \ tk-silica/xt-cursor.fasl \ tk-silica/last.fasl @@ -333,7 +332,6 @@ OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xt-stipples.fasl \ tk-silica/ol-silica.fasl \ tk-silica/xt-graphics.fasl \ - tk-silica/ol-graphics.fasl \ tk-silica/image.fasl \ tk-silica/xt-frames.fasl \ tk-silica/ol-frames.fasl \ @@ -347,6 +345,8 @@ POSTSCRIPT_CLIM= postscript/postscript-port.fasl \ postscript/postscript-medium.fasl \ postscript/laserwriter-metrics.fasl +HPGL_OBJS= hpgl/pkg.fasl hpgl/hpgl-port.fasl hpgl/hpgl-medium.fasl + # Used for tags ALL_SRC = utils/excl-verification.lisp \ utils/lisp-package-fixups.lisp \ @@ -486,13 +486,11 @@ ALL_SRC = utils/excl-verification.lisp \ tk-silica/xt-stipples.lisp \ tk-silica/xm-silica.lisp \ tk-silica/xt-graphics.lisp \ - tk-silica/xm-graphics.lisp \ tk-silica/image.lisp \ tk-silica/xt-frames.lisp \ tk-silica/xm-frames.lisp \ tk-silica/xt-gadgets.lisp \ tk-silica/xm-gadgets.lisp \ - tk-silica/xm-menus.lisp \ tk-silica/xt-cursor.lisp \ tk-silica/xt-pixmaps.lisp \ tk/ol-defs.lisp \ @@ -502,7 +500,6 @@ ALL_SRC = utils/excl-verification.lisp \ tk/ol-widgets.lisp \ tk/ol-callbacks.lisp \ tk-silica/ol-silica.lisp \ - tk-silica/ol-graphics.lisp \ tk-silica/ol-frames.lisp \ tk-silica/ol-gadgets.lisp diff --git a/Makefile.generic b/Makefile.generic index 3036e7cb..f868db64 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.generic,v 1.3 93/03/04 18:59:20 colin Exp $ +# $fiHeader: Makefile.generic,v 1.4 93/03/31 10:38:24 cer Exp $ # # Makefile.generic for CLIM 2.0 # @@ -54,7 +54,7 @@ compile-ol: $(OPENLOOK_OBJS) FORCE # Concatenation cat: cat-xm cat-ol -cat-g: climg.fasl clim-debug.fasl climps.fasl climgg.fasl # clim1compat.fasl +cat-g: climg.fasl clim-debug.fasl climps.fasl climgg.fasl climhpgl.fasl # clim1compat.fasl cat-xm: cat-g climxm.fasl clim-debugxm.fasl cat-ol: cat-g climol.fasl clim-debugol.fasl @@ -108,6 +108,10 @@ climps.fasl: $(POSTSCRIPT_CLIM) $(CAT) $(POSTSCRIPT_CLIM) > $(TMP)/climps.fasl_`whoami` $(MV) $(TMP)/climps.fasl_`whoami` climps.fasl +climhpgl.fasl : $(HPGL_OBJS) + $(CAT) $(HPGL_OBJS) > $(TMP)/climhpgl.fasl_`whoami` + $(MV) $(TMP)/climhpgl.fasl_`whoami` climhpgl.fasl + clim1compat.fasl : $(CLIM1COMPAT) $(CAT) $(CLIM1COMPAT) > $(TMP)/clim1compat.fasl_`whoami` $(MV) $(TMP)/clim1compat.fasl_`whoami` clim1compat.fasl @@ -178,10 +182,9 @@ benchmark: testps : $(ECHO) "\ (load \"test/postscript-tests.lisp\") \ - (clim-user::run-postscript-tests :output :$(PSVIEW)) \ + (clim-user::run-postscript-tests :output $(PSVIEW)) \ " | $(CLIM) $(CLOPTS) -batch - echo-train: -$(ECHO) "$(TRAIN_LISP)" diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 886f9b7a..b0a3ea46 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.56 93/03/19 09:43:09 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.57 93/03/31 10:38:30 cer Exp $ (in-package :clim-internals) @@ -1344,8 +1344,10 @@ (stream continuation (view gadget-dialog-view) prompt &key (documentation (if (stringp prompt) prompt - (with-output-to-string (stream) - (funcall prompt stream)))) + ;;-- What is the right thing to do? + (ignore-errors + (with-output-to-string (stream) + (funcall prompt stream))))) (query-identifier (list ':button documentation)) (cache-value t) (cache-test #'eql) resynchronize) @@ -1359,11 +1361,6 @@ :documentation documentation :resynchronize resynchronize))) (make-pane 'push-button - :label (if (stringp prompt) - prompt - ;;--- Perhaps we should create a pixmap - (with-output-to-string (stream) - (funcall prompt stream))) :id record :client client :activate-callback #'(lambda (button) @@ -1375,4 +1372,13 @@ :sheet sheet :presentation-type 'command :value `(com-avv-command-button ,client ,record) - :frame *application-frame*)))))))))) + :frame *application-frame*))))) + + :label (if (stringp prompt) + prompt + (pixmap-from-menu-item stream + prompt + #'funcall + nil))))))) + + diff --git a/clim/frames.lisp b/clim/frames.lisp index 9d336eda..6c905610 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.61 93/03/19 09:43:26 cer Exp $ +;; $fiHeader: frames.lisp,v 1.62 93/03/31 10:38:34 cer Exp $ (in-package :clim-internals) @@ -27,7 +27,6 @@ ;; have actually been realized so far (panes :initarg :panes :accessor frame-panes) (all-panes :initform nil) - (current-panes :initform nil :accessor frame-current-panes) (initialized-panes :initform nil) (pane-constructors :initarg :pane-constructors) (top-level-sheet :accessor frame-top-level-sheet @@ -62,6 +61,7 @@ :resize-frame nil :top-level 'default-frame-top-level)) + (defmethod port ((frame standard-application-frame)) (port (frame-manager frame))) @@ -1033,6 +1033,8 @@ (cond ((second (assoc pane-name all-panes))) (errorp (error "There is no pane named ~S in frame ~S" pane-name frame))))) + + ;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal ;; I/O operations, that is, a CLIM stream pane (defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t)) @@ -1046,6 +1048,16 @@ (when errorp (error "There is no CLIM stream pane named ~S in frame ~S" pane-name frame))))) +(defmethod frame-current-panes ((frame standard-application-frame)) + (let ((panes nil) + (top (frame-panes frame))) + (when top + (map-over-sheets #'(lambda (sheet) + (when (panep sheet) + (push sheet panes))) + top)) + panes)) + (defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p) ;; First display all the :accept-values panes, then display the rest. ;; We do this to ensure that all side-effects from :accept-values panes @@ -1183,7 +1195,7 @@ (note-command-enabled (frame-manager frame) frame command-name)) (t (push command-name disabled-commands) - (note-command-enabled (frame-manager frame) frame command-name))))) + (note-command-disabled (frame-manager frame) frame command-name))))) ;;--- There is the compiler bug with (eval-when (compile load eval) ...) diff --git a/hpgl/hpgl-port.lisp b/hpgl/hpgl-port.lisp index 5312eb7b..fb4225c0 100644 --- a/hpgl/hpgl-port.lisp +++ b/hpgl/hpgl-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: hpgl-clim; Base: 10; Lowercase: Yes -*- -;;; $fiHeader$ +;;; $fiHeader: hpgl-port.lisp,v 1.1 93/03/04 08:57:28 cer Exp $ "Copyright (c) 1991 by International Lisp Associates. All rights reserved." "Portions copyright (c) 1992 Franz Inc. All rights reserved" @@ -270,6 +270,11 @@ :port port :color-p t :dynamic-p nil)) + +(defmethod initialize-instance :after ((port hpgl-port) &key) + (with-slots (silica::default-palette) port + (setf silica::default-palette (make-palette port)))) + (defmethod realize-graft ((port hpgl-port) (graft standard-graft)) (with-slots (silica::mm-height silica::mm-width diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 512aae10..52306f86 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.19 93/03/19 09:44:18 cer Exp $ +;; $fiHeader: compile-1.lisp,v 1.20 93/03/31 10:39:06 cer Exp $ (in-package :user) @@ -82,8 +82,15 @@ "test/test-demos")) (compile-file file) (load file)) + #+ignore (load "compatibility/sysdcl.lisp") - #+ignore (clim-defsys::compile-system 'clim-compatibility :propagate t)) + #+ignore (clim-defsys::compile-system 'clim-compatibility :propagate t) + + (load "hpgl/sysdcl") + (clim-defsys::compile-system 'hpgl-clim :propagate t) + (clim-defsys::load-system 'hpgl-clim) + + ) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 81b6130e..aae89ebb 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.23 93/03/19 09:44:20 cer Exp $ +;; $fiHeader: dev-load-1.lisp,v 1.24 93/03/31 10:39:08 cer Exp $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -58,6 +58,7 @@ (load "postscript/sysdcl") (load "climps.fasl") + (load "climhpgl.fasl") (compile-file-if-needed "test/test-suite") diff --git a/misc/train.lisp b/misc/train.lisp index acad6367..f037f632 100644 --- a/misc/train.lisp +++ b/misc/train.lisp @@ -20,17 +20,26 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: train.lisp,v 1.3 92/12/14 15:02:56 cer Exp $ +;; $fiHeader: train.lisp,v 1.4 93/03/19 09:44:22 cer Exp $ -(defun train-clim (&key (train-times 2) (psview nil) (frame-tests t) (errorp t)) +(defun train-clim (&key (train-times 2) (psview nil) (frame-tests t) (errorp t) (hpglview nil)) (setq *global-gc-behavior* nil) - (load "test/test.lisp") - (when frame-tests - (clim-user::train-clim-2 train-times) - (clim-user::do-frame-tests errorp)) - (when psview - (load "test/postscript-tests.lisp") - (clim-user::run-postscript-tests :output psview)) + (load + "test/test.lisp") + (clim-user::with-test-reporting () + (when frame-tests + (clim-user::train-clim-2 train-times) + (clim-user::do-frame-tests errorp)) + (when psview + (load "test/postscript-tests.lisp") + (clim-user::run-postscript-tests :output psview)) + + (when hpglview + (load "test/postscript-tests.lisp") + (require :climhpgl) + (load "test/hpgl-tests.lisp") + (clim-user::run-hpgl-tests :output hpglview))) + (with-open-file (*standard-output* "coverage-report.lisp" :if-exists :supersede :direction :output) (generate-coverage-report)) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index d1f2bd52..3143d7d1 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.35 92/12/17 15:33:24 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.36 93/03/04 19:01:15 colin Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -410,14 +410,12 @@ ("xt-stipples") ("xm-silica") ("xt-graphics") - ("xm-graphics") ("image") ("xt-frames") ("xm-frames") ("xm-dialogs") ("xt-gadgets") ("xm-gadgets") - ("xm-menus") ("xt-cursor") ("xt-pixmaps") ("last")) @@ -435,7 +433,6 @@ ("xt-stipples") ("ol-silica") ("xt-graphics") - ("ol-graphics") ("image") ("xt-frames") ("ol-frames") diff --git a/test/test-clim.lisp b/test/test-clim.lisp index d0e696ef..4ebccc35 100644 --- a/test/test-clim.lisp +++ b/test/test-clim.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test-clim.lisp,v 1.1 93/03/19 09:46:34 cer Exp $ +;; $fiHeader: test-clim.lisp,v 1.2 93/03/31 10:39:46 cer Exp $ (in-package :clim-user) @@ -346,7 +346,8 @@ (run-printer-tests output :postscript)) (defun run-printer-tests (output printer-type) - (exercise-frame 'clim-postscript-tests + (exercise-frame (clim-utils:fintern "~A~A" 'printer-tests printer-type) + 'clim-postscript-tests `(:width 600 :height 600 :printer-type ,printer-type) (mapcar #'(lambda (command) (append command `(:output ,output))) @@ -458,6 +459,55 @@ ) (com-frame-test-quit)) +(define-frame-test test-tf109 (tf109) + ((com-change-set-gadget-items) + (com-change-set-gadget-items :which t) + (com-change-set-gadget-items)) + (com-quit)) + + +(define-frame-test test-tf111 (tf111) + () + (com-quit)) + +;;; Disable/enable command stuff. + +(define-application-frame enable-disable-frame () + + () + (:panes + (i :interactor)) + (:layouts + (default i))) + +(define-enable-disable-frame-command (com-enable-disable-foo :name nil :menu t) + ((i 'integer :gesture :select)) + (present (* i i) 'integer)) + +(define-enable-disable-frame-command (com-enable-disable-bar :name nil :menu t) + ((i 'integer :gesture :describe) + (j 'integer)) + (present (* i j) 'integer)) + +(define-enable-disable-frame-command (com-enable-disable-quit :name nil :menu t) + () + (frame-exit *application-frame*)) + +(define-enable-disable-frame-command (com-enable-disable-sensitive :name t) + ((enabled 'boolean)) + (setf (command-enabled 'com-enable-disable-frame *application-frame*) enabled)) + +(define-frame-test test-enable-disable-command (enable-disable-frame + :disabled-commands '(com-enable-disable-frame) + :width 400 :height 400) + ((com-enable-disable-sensitive t) + (:sleep 1) + (com-enable-disable-sensitive nil) + (:sleep 1)) + (com-enable-disable-quit)) + + +;;; This should be at the end: ;;; make the training selective. (locally @@ -469,13 +519,3 @@ (setq excl:*global-gc-behavior* nil) -(define-frame-test test-tf109 (tf109) - ((com-change-set-gadget-items) - (com-change-set-gadget-items :which t) - (com-change-set-gadget-items)) - (com-quit)) - - -(define-frame-test test-tf111 (tf111) - () - (com-quit)) diff --git a/test/test-driver.lisp b/test/test-driver.lisp index 7ad556ad..b685d5a3 100644 --- a/test/test-driver.lisp +++ b/test/test-driver.lisp @@ -150,7 +150,7 @@ (wait-for-clim-input-state invocation timeout))) (execute-command-in-frame (or avv-frame frame) command))))))))) -(defun exercise-frame (class initargs commands exit-command &optional (error *catch-errors-in-tests*)) +(defun exercise-frame (test-name class initargs commands exit-command &optional (error *catch-errors-in-tests*)) (flet ((doit () (let ((invocation (make-instance 'invocation :class class :initargs initargs))) (unwind-protect @@ -165,10 +165,87 @@ (if error (handler-case (doit) (error (condition) - (warn "The following error occurred: ~A" condition))) + (note-test-failed test-name condition)) + (:no-error (&rest ignore) + (declare (ignore ignore)) + (note-test-succeeded test-name))) (doit)))) - +(defvar *test-successes* nil) +(defvar *test-failures* nil) + +(defun note-test-failed (test reason) + (warn "The following error occurred: ~A" reason) + (when *test-failures* + (push (cons test reason) (cdr *test-failures*)))) + +(defun note-test-succeeded (test) + (when *test-successes* + (push test (cdr *test-successes*)))) + +(defmacro with-test-reporting ((&rest options &key) &body body) + `(invoke-with-test-reporting #'(lambda () ,@body) ,@options)) + +(defun invoke-with-test-reporting (continuation) + (let ((*test-successes* (list nil)) + (*test-failures* (list nil))) + (funcall continuation) + (pop *test-successes*) + (pop *test-failures*) + (generate-test-report))) + +(defun generate-test-report () + (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") + (let (old-successes old-failures) + (with-open-file (*standard-input* "test-suite-report.lisp") + (let ((*package* (find-package :clim-user))) + (setq old-successes (read) old-failures (read)))) + + (let ((first t)) + (dolist (x *test-failures*) + (when (member (car x) old-successes) + (when first + (format t "The following tests have for failed the first time:~%") + (setq first nil)) + (format t "~10t~A : ~A~%" (car x) (cdr x))))) + + (let ((first t)) + (dolist (x *test-failures*) + (when (member (car x) old-failures) + (when first + (format t "The following tests have failed again:~%") + (setq first nil)) + (format t "~10t~A : ~A~%" (car x) (cdr x))))) + + (let ((first t)) + (dolist (x *test-successes*) + (when (member x old-failures) + (when first + (format t "The following tests have succeeded finally:~%") + (setq first nil)) + (format t "~10t~A~%" x)))))) + + (when *test-successes* + (format t "The following tests succeeded:~%") + (dolist (x *test-successes*) + (format t "~10t~A ~%" x))) + + + (with-open-file (*standard-output* "test-suite-report.lisp" + :direction :output :if-exists :supersede) + (let ((*package* (find-package :clim-user))) + (print *test-successes*) + (print (mapcar #'car *test-failures*))))) + + + + (defun walk-over-presentations (function output-record) (labels ((find-object-1 (record x-offset y-offset) (with-bounding-rectangle* (left top right bottom) record @@ -367,7 +444,7 @@ `(progn (pushnew ',name *frame-tests*) (defun ,name () - (exercise-frame ',class ',initargs ',commands ',exit-command)))) + (exercise-frame ',name ',class ',initargs ',commands ',exit-command)))) (defmacro define-command-sequence (name &rest commands) `(defun ,name (invocation) @@ -400,7 +477,8 @@ (defun test-it (&optional filename (errorp *catch-errors-in-tests*)) (let* ((file (pathname (or filename (format nil "/tmp/foofile~A" (gensym)))))) - (exercise-frame 'clim-tests + (exercise-frame 'test-it + 'clim-tests '(:width 600 :height 400 :left 0 :top 0) `(((run-benchmarks-to-dummy-file :file ,file) :timeout 1800)) `(exit-clim-tests) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index e41f4e7f..a93546e8 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.41 93/03/25 15:41:16 colin Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.42 93/03/31 10:40:12 cer Exp $ (in-package :xm-silica) @@ -237,7 +237,7 @@ ; sheet) ) -(defclass openlook-menu-bar (xt-leaf-pane menu-bar) ()) +(defclass openlook-menu-bar (xt-leaf-pane xt-menu-bar menu-bar) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) @@ -382,7 +382,15 @@ :label menu :managed t :parent parent + :sensitive (command-enabled + (car (command-menu-item-value item)) + (slot-value sheet 'silica::frame)) options))) + + (when top + (push (cons (car (command-menu-item-value item)) button) + (menu-bar-command-name-to-button-table sheet))) + (set-button-accelerator-from-keystroke sheet button keystroke) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index d06ba88f..c2885d5a 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.50 93/03/19 09:46:59 cer Exp $ +;; $fiHeader: xm-frames.lisp,v 1.51 93/03/31 10:40:17 cer Exp $ (in-package :xm-silica) @@ -56,7 +56,8 @@ ;;; Definitions of the individual classes -(defclass motif-menu-bar (xt-leaf-pane menu-bar) ()) +(defclass motif-menu-bar (xt-leaf-pane xt-menu-bar menu-bar) + ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-menu-bar)) @@ -117,7 +118,9 @@ (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)) + (options font-list) + (ct (menu-bar-command-table sheet)) + (flatp (flat-command-table-menu-p ct))) (labels ((update-menu-item-sensitivity (widget frame commands) (declare (ignore widget)) (dolist (cbs commands) @@ -159,9 +162,9 @@ :label-string menu :sub-menu-id submenu options))) - - (set-button-mnemonic sheet - cb (getf (command-menu-item-options item) :mnemonic)) + (unless flatp + (set-button-mnemonic sheet + cb (getf (command-menu-item-options item) :mnemonic))) (let* ((ct (find-command-table (second item))) (tick (slot-value ct 'clim-internals::menu-tick))) @@ -217,17 +220,26 @@ :label-string menu :managed t :parent parent + :sensitive (command-enabled + (car (command-menu-item-value item)) + (slot-value sheet 'silica::frame)) options))) (push (list item button) commands-and-buttons) - (set-button-accelerator-from-keystroke - sheet - button keystroke) + (when flatp + (push (cons (car (command-menu-item-value item)) + button) + (menu-bar-command-name-to-button-table sheet))) + + (unless flatp + (set-button-accelerator-from-keystroke + sheet + button keystroke) - (set-button-mnemonic - sheet - button (getf (command-menu-item-options item) :mnemonic)) + (set-button-mnemonic + sheet + button (getf (command-menu-item-options item) :mnemonic))) (when (getf (command-menu-item-options item) :documentation) (tk::add-callback @@ -248,9 +260,8 @@ command-table) commands-and-buttons))) - (let ((ct (menu-bar-command-table sheet))) - (make-menu-for-command-table - ct mirror (not (flat-command-table-menu-p ct))))) + (make-menu-for-command-table + ct mirror (not flatp))) mirror)) (defun display-motif-help (widget port documentation) @@ -387,8 +398,8 @@ :label-insensitive-pixmap pixmap options))) (xt::add-widget-cleanup-function - button - #'tk::destroy-pixmap pixmap) + button + #'tk::destroy-pixmap pixmap) button)))) (when (clim-internals::menu-item-documentation item) (tk::add-callback button diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 1bbe5599..e598bb26 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.68 93/03/25 15:41:27 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.69 93/03/31 10:40:20 cer Exp $ (in-package :xm-silica) @@ -161,9 +161,19 @@ (defmethod compose-space ((sheet motif-label-pane) &key width height) (declare (ignore width height)) - (make-space-requirement - :width (process-width-specification sheet `(,(max 1 (length (gadget-label sheet))) :character)) - :height (process-height-specification sheet `(1 :line)))) + (compute-space-requirement-for-push-button-or-label sheet)) + +(defun compute-space-requirement-for-push-button-or-label (sheet) + (let ((label (gadget-label sheet))) + (etypecase label + ((or null string) + (make-space-requirement + :width (process-width-specification sheet `(,(max 1 (length label)) :character)) + :height (process-height-specification sheet `(1 :line)))) + (tk::pixmap + (make-space-requirement + :width (xt::pixmap-width label) + :height (xt::pixmap-height label)))))) ;;; Push button @@ -210,9 +220,7 @@ (defmethod compose-space ((sheet motif-push-button) &key width height) (declare (ignore width height)) - (make-space-requirement - :width (process-width-specification sheet `(,(max 1 (length (gadget-label sheet))) :character)) - :height (process-height-specification sheet `(1 :line)))) + (compute-space-requirement-for-push-button-or-label sheet)) ;;; range pane mixin diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 6911de9c..35eb162d 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.31 92/12/16 16:50:47 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.32 93/03/31 10:40:23 cer Exp $ (in-package :xm-silica) @@ -66,26 +66,16 @@ (defmethod find-shell-class-and-initargs ((port motif-port) sheet) - (cond - #+ignore - ((typep (pane-frame sheet) 'clim-internals::menu-frame) - (values 'xt::override-shell - '(:width 1 - :height 1))) - - ( ;;--- hack alert - (popup-frame-p sheet) - (values 'tk::xm-dialog-shell - (append - (let ((x (find-shell-of-calling-frame sheet))) - (and x `(:transient-for ,x))) - '(:keyboard-focus-policy :pointer) - (and (typep (pane-frame sheet) - 'clim-internals::menu-frame) - '(:override-redirect t))))) - - (t - (call-next-method)))) + (if (popup-frame-p sheet) + (values 'tk::xm-dialog-shell + (append + (let ((x (find-shell-of-calling-frame sheet))) + (and x `(:transient-for ,x))) + ;;'(:keyboard-focus-policy :pointer) + (and (typep (pane-frame sheet) + 'clim-internals::menu-frame) + '(:override-redirect t)))) + (call-next-method))) (defmethod make-cursor-widget-for-port ((port motif-port) parent) (make-instance 'tk::xm-my-drawing-area diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index d265fad2..ddf172b3 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.29 93/03/19 09:47:07 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.30 93/03/31 10:40:25 cer Exp $ (in-package :xm-silica) @@ -73,7 +73,8 @@ (defun command-button-callback (button dunno frame command-table item) (declare (ignore dunno button)) (execute-command-in-frame - frame (substitute clim-internals::*application-frame-marker* frame (second item)) + frame (substitute clim-internals::*application-frame-marker* frame + (command-menu-item-value item)) :presentation-type `(command :command-table ,command-table))) @@ -206,3 +207,31 @@ (defmethod invoke-with-mouse-grabbed-in-window ((framem xt-frame-manager) (window t) continuation &key) (invoke-with-pointer-grabbed window continuation)) + + + +(defclass xt-menu-bar () + ((command-name-to-button-table + :accessor menu-bar-command-name-to-button-table + :initform nil))) + +(defmethod note-sheet-degrafted :after ((sheet xt-menu-bar)) + (setf (menu-bar-command-name-to-button-table sheet) nil)) + +(defmethod note-command-enabled :after ((framem xt-frame-manager) frame command) + (update-command-button-status frame command t)) + +(defmethod note-command-disabled :after ((framem xt-frame-manager) frame command) + (update-command-button-status frame command nil)) + +(defun update-command-button-status (frame command enabled) + (let ((sheet (frame-top-level-sheet frame))) + (when sheet + (flet ((update-sheet (sheet) + (when (typep sheet 'xt-menu-bar) + (let ((button (cdr (assoc command (menu-bar-command-name-to-button-table sheet))))) + (when button + (tk::set-sensitive button enabled)))))) + (map-over-sheets #'update-sheet sheet))))) + + diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 050af4d8..f1d621e9 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.66 93/03/19 09:47:10 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.67 93/03/31 10:40:30 cer Exp $ (in-package :tk-silica) @@ -76,6 +76,11 @@ (indirect-inks :initform nil) (clip-mask :initform nil))) +(defmethod make-medium ((port xt-port) sheet) + (make-instance 'xt-medium + :port port + :sheet sheet)) + (defmethod medium-drawable ((medium xt-medium)) (with-slots (drawable sheet) medium (or drawable diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 6cdf2b7f..7b7858f9 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.73 93/03/25 15:41:40 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.74 93/03/31 10:40:33 cer Exp $ (in-package :xm-silica) @@ -40,7 +40,9 @@ (depth :accessor port-depth) (visual-class :accessor port-visual-class) (cursor-font :initform nil) - (cursor-cache :initform nil)) + (cursor-cache :initform nil) + (compose-status :initform (x11:make-xcomposestatus) + :reader port-compose-status)) (:default-initargs :allow-loose-text-style-size-mapping t :deep-mirroring t) (:documentation "The port for X intrinsics based ports")) @@ -1115,7 +1117,7 @@ (declare (ignore sheet mirror) (optimize (speed 3) (safety 0))) (multiple-value-bind (character keysym) - (tk::lookup-string event) + (tk::lookup-string event (port-compose-status (port sheet))) (setq character (and (= (length (the simple-string character)) 1) (aref (the simple-string character) 0))) ;;--- Map the asci control-characters into the common lisp diff --git a/tk/xlib.lisp b/tk/xlib.lisp index ca7fd7c3..ec5ebebc 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.40 93/03/04 19:01:38 colin Exp $ +;; $fiHeader: xlib.lisp,v 1.41 93/03/18 14:38:50 colin Exp $ (in-package :tk) @@ -619,13 +619,13 @@ (defvar *lookup-string-buffers* nil) -(defun lookup-string (event) +(defun lookup-string (event &optional (compose-status 0)) (declare (optimize (speed 3) (safety 0))) - (let ((buffer (or (pop *lookup-string-buffers*) + (let ((buffer (or (excl:without-interrupts (pop *lookup-string-buffers*)) (excl::malloc 256)))) (declare (type (unsigned-byte 32) buffer)) (with-ref-par ((keysym 0)) - (let* ((nchars (x11:xlookupstring event buffer 256 keysym 0)) + (let* ((nchars (x11:xlookupstring event buffer 256 keysym compose-struct)) (result (make-string nchars))) (declare (fixnum nchars) (simple-string result)) @@ -633,7 +633,7 @@ (declare (fixnum i)) (setf (schar result i) (code-char (sys:memref-int buffer 0 i :unsigned-byte)))) - (push buffer *lookup-string-buffers*) + (excl:without-interrupts (push buffer *lookup-string-buffers*)) (values result (aref keysym 0)))))) -- GitLab