From ab1fe6e4b3c17db14532ebe94003c5e4a09190d5 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Fri, 3 Apr 1992 12:04:58 +0000 Subject: [PATCH] fixes --- Makefile | 14 +- clim/cursor.lisp | 13 +- clim/frames.lisp | 43 +++++- clim/menus.lisp | 39 ++++-- clx/clx-port.lisp | 7 +- genera/genera-port.lisp | 4 +- notes/clim.todo | 3 +- silica/db-scroll.lisp | 96 ++++++------- silica/db-slider.lisp | 12 +- silica/gadgets.lisp | 21 ++- silica/layout.lisp | 17 +-- sys/sysdcl.lisp | 8 +- test/test.lisp | 14 +- tk-silica/ol-silica.lisp | 16 +-- tk-silica/xm-gadgets.lisp | 89 +++++++++--- tk-silica/xm-menus.lisp | 264 ++++++++++++++++++++++++----------- tk-silica/xm-silica.lisp | 26 ++-- tk-silica/xt-cursor.lisp | 19 +-- tk-silica/xt-gadgets.lisp | 18 ++- tk-silica/xt-silica.lisp | 8 +- tk/foreign.lisp | 6 +- tk/load-ol.lisp | 23 +-- tk/load-xm.lisp | 11 +- tk/make-classes.lisp | 12 +- tk/make-widget.lisp | 15 +- tk/ol-init.lisp | 6 +- tk/resources.lisp | 14 +- tk/xm-init.lisp | 6 +- tk/xt-init.lisp | 3 +- utils/excl-verification.lisp | 9 +- utils/packages.lisp | 7 +- 31 files changed, 565 insertions(+), 278 deletions(-) diff --git a/Makefile b/Makefile index e4e833a6..a4994ec3 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.18 92/03/24 19:38:26 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.19 92/03/30 17:52:42 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -27,7 +27,9 @@ MV = /usr/fi/mv-nfs TAGS = /usr/fi/lib/emacs/etc/etags TMP = /usr/tmp SRC_FILES= */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ - misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.motif + misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.motif \ + misc/undefinedsymbols.xt + DEST=/dev/null CL_SRC=/vapor/usr/tech/cer/cl/src @@ -222,7 +224,7 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xm-gadgets.fasl \ tk-silica/xm-menus.fasl \ tk-silica/xt-pixmaps.fasl \ - tk-silica/xm-cursor.fasl + tk-silica/xt-cursor.fasl OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ @@ -235,6 +237,7 @@ OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/ol-frames.fasl \ tk-silica/xt-gadgets.fasl \ tk-silica/ol-gadgets.fasl \ + tk-silica/xt-cursor.fasl \ tk-silica/xt-pixmaps.fasl GENERIC-OBJS= $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS) @@ -301,7 +304,8 @@ clim-xm: FORCE $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) ls -lt $(CLIM) >> Clim-sizes.n ls -lt $(CLIM) - + -echo removing clim*.fasls + /bin/rm -f clim*.fasl clim-debug.fasl clim-ol: FORCE -$(RM) $(CLIM) @@ -327,7 +331,7 @@ clim-small: FORCE # Misc clean: - find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim.fasl clim-debug.fasl + find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim*.fasl clim-debug.fasl cheapclean: find $(CHEAP_CLEAN) -name "*.fasl" -print | xargs rm -f diff --git a/clim/cursor.lisp b/clim/cursor.lisp index adb70480..535e9ff6 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cursor.lisp,v 1.6 92/02/26 10:23:35 cer Exp $ +;; $fiHeader: cursor.lisp,v 1.7 92/03/04 16:21:20 cer Exp Locker: cer $ (in-package :clim-internals) @@ -132,6 +132,17 @@ ;;; state transitions. For example, the cursor might be getting the focus, and ;;; thus change from a hollow rectangle to a filled one (or in Genera, it might ;;; start blinking). + +(defmethod port-note-cursor-change :after ((port port) + cursor + stream + type + old + new) + (declare (ignore old type cursor)) + (setf (port-keyboard-input-focus port) + (and new stream))) + (defmethod port-note-cursor-change ((port port) cursor stream (type (eql 'cursor-state)) old new) (declare (ignore old)) diff --git a/clim/frames.lisp b/clim/frames.lisp index c036717a..6925d29f 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.10 92/03/10 10:12:33 cer Exp Locker: cer $ +;; ;; $fiHeader: frames.lisp,v 1.11 92/03/24 19:37:49 cer Exp Locker: cer $ (in-package :clim-internals) @@ -303,7 +303,9 @@ `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name)) (symbol-macrolet ,(mapcar #'(lambda (pane-spec) - (destructuring-bind (name code) pane-spec + (destructuring-bind (name code . ignore) + pane-spec + (declare (ignore ignore code)) `(,name (find-or-make-pane-named ,frame ',name)))) panes) (let ((*application-frame* ,frame)) @@ -318,13 +320,46 @@ (defun compute-pane-constructor-code (panes) `(list ,@(mapcar #'(lambda (pane-spec) - (destructuring-bind (name code) pane-spec + (destructuring-bind (name code . rest) pane-spec + (setq code (canonicalize-pane-spec name code rest)) `(list ',name #'(lambda (frame framem) (with-look-and-feel-realization (framem frame) ,code))))) panes))) - + +(defun canonicalize-pane-spec (name code rest) + (cond ((symbolp code) + (multiple-value-bind + (class options) + (find-pane-class-and-options code) + `(realize-pane ',class ,@rest :name ',name ,@options))) + ((null rest) + code) + (t + (error "Invalid pane specification: ~S" + (list* name code rest))))) + +(defmacro define-pane-type (type class . options) + `(defmethod find-pane-class-and-options ((type (eql ',type))) + (values ',class ',options))) + +(define-pane-type :interactor interactor-pane) +(define-pane-type :application application-pane) +(define-pane-type :pointer-documentation pointer-documentation-pane) +(define-pane-type :command-menu command-menu-pane) +(define-pane-type :scroll-bar scroll-bar) +(define-pane-type :slider slider) +(define-pane-type :push-button push-button) +(define-pane-type :label-pane label-pane) +(define-pane-type :text-field text-field) +(define-pane-type :text-editor silica::text-editor) +(define-pane-type :toggle-button toggle-button) +(define-pane-type :radio-box radio-box) +(define-pane-type :menu-bar menu-bar) + +;;; + (defmethod find-or-make-pane-named ((frame standard-application-frame) name) (with-slots (all-panes pane-constructors) frame (second (or (assoc name all-panes) diff --git a/clim/menus.lisp b/clim/menus.lisp index 81492b48..46a9da69 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.15 92/03/10 10:12:44 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.16 92/03/24 19:37:54 cer Exp Locker: cer $ (in-package :clim-internals) @@ -186,6 +186,14 @@ (defun menu-item-documentation (menu-item) (menu-item-getf menu-item :documentation)) +(defun menu-item-type (menu-item) + (or (menu-item-getf menu-item :type) + :item)) + +(defun menu-item-active (menu-item) + (or (atom menu-item) + (menu-item-getf menu-item :active t))) + ;; Item list can be a general sequence... (defun menu-item-item-list (menu-item) (menu-item-getf menu-item :item-list)) @@ -242,13 +250,26 @@ :x-spacing x-spacing :y-spacing y-spacing :move-cursor nil) (flet ((format-item (item) - (let ((presentation - (with-output-as-presentation (menu item presentation-type - :single-box T) - (formatting-cell (menu :align-x cell-align-x :align-y cell-align-y) - (funcall item-printer item menu))))) - (when (and default-item (eq item default-item)) - (setf default-presentation presentation))))) + (let ((type (menu-item-type item))) + (unless (eq type :separator) + (flet ((printit () + (formatting-cell (menu :align-x cell-align-x :align-y cell-align-y) + (funcall item-printer item + menu)))) + (ecase type + (:item + (if (menu-item-active item) + (let ((presentation + (with-output-as-presentation (menu item presentation-type + :single-box T) + (printit)))) + (when (and default-item (eq item default-item)) + (setf default-presentation + presentation))) + ;;-- Perhaps it should be grayed out in someway? + (printit))) + (:label (printit)) + (:separator))))))) (declare (dynamic-extent #'format-item)) (map nil #'format-item items))) default-presentation) @@ -267,7 +288,7 @@ (if style (with-text-style (stream style) (write-string string stream)) - (write-string string stream)))) + (write-string string stream)))) (defclass static-menu () ((name :initarg :name) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index e72dfe23..c87861d7 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -3,7 +3,7 @@ (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: clx-port.lisp,v 1.3 92/03/04 16:20:55 cer Exp $ +;;; $fiHeader: clx-port.lisp,v 1.4 92/03/10 10:12:08 cer Exp Locker: cer $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -567,11 +567,6 @@ (integerize-coordinate x) (integerize-coordinate y))) -(defmethod port-note-cursor-change ((port clx-port) cursor stream type old new) - (declare (ignore type old)) - ;;--- Where should this be, really? - (setf (port-keyboard-input-focus port) (and new stream))) - ;;--- Doesn't this need a sheet/stream argument? (defmethod port-force-output ((port clx-port)) diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp index 82d6454c..5de613ba 100644 --- a/genera/genera-port.lisp +++ b/genera/genera-port.lisp @@ -3,7 +3,7 @@ (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: genera-port.lisp,v 1.1 92/02/24 13:28:08 cer Exp $ +;;; $fiHeader: genera-port.lisp,v 1.2 92/03/04 16:22:52 cer Exp Locker: cer $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -540,8 +540,6 @@ (defmethod port-note-cursor-change ((port genera-port) cursor stream type old new) (declare (ignore type old)) - ;;--- Where should this be, really? - (setf (port-keyboard-input-focus port) (and new stream)) (ensure-blinker-matches-cursor cursor stream)) diff --git a/notes/clim.todo b/notes/clim.todo index 775b75d6..3c985078 100644 --- a/notes/clim.todo +++ b/notes/clim.todo @@ -1,4 +1,4 @@ -K%% $fiHeader: clim.todo,v 1.12 92/03/13 09:55:56 cer Exp Locker: cer $ +K%% $fiHeader: clim.todo,v 1.13 92/03/24 19:37:35 cer Exp Locker: cer $ %% ****************************************** SWM things @@ -213,6 +213,7 @@ K%% $fiHeader: clim.todo,v 1.12 92/03/13 09:55:56 cer Exp Locker: cer $ - Labels in menus - Hierarchical menus * Locking + * check for duplicate pane names. %% ******************************************* JDI things diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 0a68bf23..6c68612d 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.9 92/03/24 19:36:28 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.10 92/03/30 17:52:02 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -84,39 +84,42 @@ ;; Kinda bogus benchmark optimization -- if the scrollbar was full size ;; before, and the viewport is bigger than the extent, don't bother with ;; the fancy math. - (if (and (eql (the (integer 0 100) current-size) 100) - (> (- vmax vmin) (- max min))) - (return-from update-scrollbar)) - (let* ((size (the fixnum (truncate (* 100.0 - (the single-float - (if (zerop (- max min)) - 1.0 - (min 1.0 (the single-float - (/ (float (- vmax vmin) 0.0s0) - (float (- max min) 0.0s0)))))))))) - (pos (the single-float - (min 1.0 - (the single-float - (max 0.0 - (the single-float - (if (zerop (- (- max min) (- vmax vmin))) - 0.0 - (the single-float - (/ (float (- vmin min) 0.0s0) - (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) - (value (min (the fixnum (- 100 size)) - (the fixnum (truncate (* 100 pos)))))) - (declare (fixnum size value) - (type single-float pos)) - (unless (and current-size - current-value - (eq current-size size) - (eq current-value value)) - (setf current-size size - current-value value) - (change-scrollbar-values scrollbar - :slider-size size - :value value))))) + (let ((range (float (gadget-range scrollbar) 0.0s0))) + (declare (type single-float range)) + (if (and (and current-size (= (the single-float current-size) range)) + (> (- vmax vmin) (- max min))) + (return-from update-scrollbar)) + (let* ((size (the single-float + (* range + (the single-float + (if (zerop (- max min)) + 1.0 + (min 1.0 (the single-float + (/ (float (- vmax vmin) 0.0s0) + (float (- max min) 0.0s0))))))))) + (pos (the single-float + (min 1.0 + (the single-float + (max 0.0 + (the single-float + (if (zerop (- (- max min) (- vmax vmin))) + 0.0 + (the single-float + (/ (float (- vmin min) 0.0s0) + (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) + (value (+ (gadget-min-value scrollbar) + (* (- range size) pos)))) + (declare (type single-float pos size)) + (unless (and current-size + current-value + (= current-size size) + (= current-value value)) + (setf current-size size + current-value value) + (change-scrollbar-values scrollbar + :slider-size size + :value value)))))) + (defmethod scrollbar-value-changed-callback :before @@ -126,15 +129,14 @@ size) (declare (ignore id)) (with-slots (current-size current-value) sheet - (setf current-size (truncate size) - current-value (truncate value)))) + (setf current-size (float size 0.0s0) + current-value (float value 0.0s0)))) (defmethod scrollbar-value-changed-callback (sheet (client scroller-pane) id value size) - (declare (ignore sheet)) (with-slots (viewport contents) client (let* ((extent (if (typep contents 'clim-internals::output-recording-mixin) (stream-output-history contents) @@ -146,22 +148,22 @@ (scroll-extent contents :x (bounding-rectangle-min-x viewport) - :y (truncate - (+ (bounding-rectangle-min-y extent) + :y (+ (bounding-rectangle-min-y extent) (* (max 0 (- (bounding-rectangle-height extent) (bounding-rectangle-height viewport))) - (if (= size 100) + (if (= size (gadget-range sheet)) 0 - (/ value (- 100 size)))))))) + (/ (- value (gadget-min-value sheet)) + (- (gadget-range sheet) size))))))) (:horizontal (scroll-extent contents - :x (truncate - (* (max 0 (- (bounding-rectangle-width extent) - (bounding-rectangle-width viewport))) - (if (= size 100) - 0 - (/ value (- 100 size))))) + :x (* (max 0 (- (bounding-rectangle-width extent) + (bounding-rectangle-width viewport))) + (if (= size (gadget-range sheet)) + 0 + (/ (- value (gadget-min-value sheet)) + (- (gadget-range sheet) size)))) :y (bounding-rectangle-min-y viewport))))))) (defun update-region (stream nminx nminy nmaxx nmaxy &key no-repaint) diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp index 664d5d3f..38fee356 100644 --- a/silica/db-slider.lisp +++ b/silica/db-slider.lisp @@ -3,7 +3,7 @@ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;; $fiHeader: db-slider.lisp,v 1.3 92/03/10 15:45:47 cer Exp Locker: cer $ +;; $fiHeader: db-slider.lisp,v 1.4 92/03/24 19:36:30 cer Exp Locker: cer $ (in-package :silica) @@ -15,15 +15,11 @@ sheet-permanently-enabled-mixin mute-repainting-mixin space-requirement-mixin) - ((thickness :initarg :thickness :initform 20) - (min-value :initarg :min-value - :accessor slider-min-value) - (max-value :initarg :max-value - :accessor slider-max-value) - (show-value :initarg :show-value + ((thickness :initarg :thickness :initform 20) + (show-value :initarg :show-value :accessor slider-show-value) (armed :initform nil)) - (:default-initargs :value 0 :min-value 0 :max-value 1 + (:default-initargs :value 0 :show-value nil)) (defmethod compose-space ((pane slider-pane) &key width height) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index b0814ff7..229edade 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.12 92/03/24 19:36:39 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.13 92/03/30 17:52:04 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -124,12 +124,26 @@ (values (+ 4 (stream-string-width text text-style medium)) (+ 4 (text-style-height text-style medium)))))) +;;;- We might want a way of changing the range and the value together. + +(defclass range-gadget-mixin () + ((min-value :initarg :min-value :accessor gadget-min-value) + (max-value :initarg :max-value :accessor gadget-max-value)) + (:default-initargs :min-value 0.0 :max-value 1.0)) + +(defmethod gadget-range ((gadget range-gadget-mixin)) + (- (gadget-max-value gadget) + (gadget-min-value gadget))) + +(defmethod gadget-range* ((gadget range-gadget-mixin)) + (values (gadget-min-value gadget) + (gadget-max-value gadget))) ;;; The intent is that the real implementations inherit from these ;;; Slider (defclass slider - (value-gadget oriented-gadget labelled-gadget) + (value-gadget oriented-gadget range-gadget-mixin labelled-gadget) ((drag-callback :initarg :drag-callback :initform nil :reader slider-drag-callback))) @@ -139,8 +153,9 @@ ;; Scroll bar + (defclass scrollbar - (value-gadget oriented-gadget) + (value-gadget range-gadget-mixin oriented-gadget) ((current-value :initform nil) (current-size :initform nil) (drag-callback :initarg :drag-callback :initform nil diff --git a/silica/layout.lisp b/silica/layout.lisp index 9c8f73c9..fa4fa75a 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: layout.lisp,v 1.8 92/03/04 16:19:45 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.9 92/03/24 19:36:44 cer Exp Locker: cer $ (in-package :silica) @@ -147,14 +147,15 @@ ;;--- What about PANE-FOREGROUND/BACKGROUND vs. MEDIUM-FOREGROUND/BACKGROUND? (defclass pane - (sheet - sheet-transformation-mixin - standard-sheet-input-mixin - standard-repainting-medium - permanent-medium-sheet-output-mixin - mute-repainting-mixin) + (sheet + sheet-transformation-mixin + standard-sheet-input-mixin + standard-repainting-medium + permanent-medium-sheet-output-mixin + mute-repainting-mixin) ((frame :reader pane-frame :initarg :frame) - (framem :reader pane-frame-manager :initarg :frame-manager))) + (framem :reader pane-frame-manager :initarg :frame-manager) + (name :initform nil :reader pane-name))) (defmethod panep ((x pane)) t) (defmethod panep ((x t)) nil) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 9a45ac17..5e9dd6c1 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.9 92/03/24 19:37:59 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.10 92/03/30 17:52:35 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -9,7 +9,9 @@ (eval-when (compile load eval) ;;; Tell the world that we're here - ;;------------- This needs to be in the CLIM.fasl also. +;;;;------------- This needs to be in the CLIM.fasl also. + ;; currently its in excl-verification but that does not seem the + ;; best place. (pushnew :clim *features*) (pushnew :clim-2 *features*) @@ -507,7 +509,7 @@ ("xt-gadgets") ("xm-gadgets") ("xm-menus") - ("xm-cursor") + ("xt-cursor") ("xt-pixmaps")) #+(and Silica Allegro) diff --git a/test/test.lisp b/test/test.lisp index fb696594..0116d88e 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.16 92/03/24 19:38:10 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.17 92/03/30 17:52:38 cer Exp Locker: cer $ (in-package :clim-user) @@ -146,12 +146,12 @@ (a (horizontally () (realize-pane 'push-button :label "Press me") (realize-pane 'push-button :label "Squeeze me"))) - (b (realize-pane 'toggle-button)) - (c (realize-pane 'slider)) - (d (realize-pane 'text-field)) - (e (realize-pane 'interactor-pane - :width 300 :max-width +fill+ - :height 300 :max-height +fill+))) + (b :toggle-button) + (c :slider) + (d :text-field) + (e :interactor + :width 300 :max-width +fill+ + :height 300 :max-height +fill+)) (:layout (:default (vertically () diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 16f0b86b..5b4cf3af 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.6 92/03/04 16:20:32 cer Exp Locker: cer $ +;; $fiHeader: ol-silica.lisp,v 1.7 92/03/24 19:37:03 cer Exp Locker: cer $ (in-package :xm-silica) @@ -34,10 +34,10 @@ (warn "Changing the default server path to ~S" (setq *default-server-path* '(:openlook))) -(defmethod port-note-cursor-change ((port openlook-port) - cursor stream type old new) - (declare (ignore old type cursor)) - (call-next-method) - ;;--- This is in both xm and ol to perhaps should be an after on xt - (setf (port-keyboard-input-focus port) - (and new stream))) +(defmethod make-cursor-widget-for-port ((port openlook-port) parent) + (make-instance 'tk::draw-area + :parent parent + :width 2 + :height 11 + :managed t)) + diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index c10e2336..3ee892a4 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.17 92/03/24 19:37:09 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.18 92/03/30 17:52:46 cer Exp Locker: cer $ (in-package :xm-silica) @@ -29,7 +29,7 @@ (push-button motif-push-button) (label-pane motif-label-pane) (text-field motif-text-field) - (silica::text-editor motif-text-editor) + (text-editor motif-text-editor) (toggle-button motif-toggle-button) (menu-bar motif-menu-bar) (viewport xm-viewport) @@ -98,7 +98,7 @@ ;;; Label -(defclass motif-label-pane (xt-leaf-pane silica::label-pane) +(defclass motif-label-pane (xt-leaf-pane label-pane) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) @@ -186,6 +186,32 @@ ()) +(defmethod gadget-value ((gadget motif-value-pane)) + ;;--- We should use the scale functions to get the value + (let ((mirror (sheet-direct-mirror gadget))) + (if mirror + (multiple-value-bind + (smin smax) (silica::gadget-range* gadget) + (multiple-value-bind + (value mmin mmax) + (tk::get-values mirror :value :minimum :maximum) + (silica::compute-symmetric-value + mmin mmax value smin smax))) + (call-next-method)))) + + +(defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key) + (let ((gadget (sheet-mirror gadget))) + (when gadget + (multiple-value-bind + (smin smax) (silica::gadget-range* gadget) + (multiple-value-bind + (mmin mmax) + (tk::get-values gadget :minimum :maximum) + (tk::set-values gadget + :value (silica::compute-symmetric-value + smin smax nv mmin mmax))))))) + (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-slider)) @@ -209,10 +235,10 @@ :max-height +fill+)) (:horizontal (make-space-requirement :height (if (gadget-label m) ; - ;Should ask the label how big - ;it wants to be and add that in + ;Should ask the label how big + ;it wants to be and add that in (+ x 20) - x) + x) :min-width x :width (* 2 x) :max-width +fill+))))) @@ -228,8 +254,9 @@ (parent t) (sheet motif-scrollbar)) (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::xm-scroll-bar - (list :orientation orientation)))) + ;;-- we should really decide what the min and max resources should be + (values 'tk::xm-scroll-bar + (list :orientation orientation)))) (defmethod (setf silica::scrollbar-size) (nv (sb motif-scrollbar)) (tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv)) @@ -239,12 +266,25 @@ (tk::set-values (sheet-direct-mirror sb) :value nv) nv) -(defmethod change-scrollbar-values ((sb motif-scrollbar) &rest args - &key slider-size value) - (declare (ignore slider-size value)) - (apply #'tk::set-values - (sheet-direct-mirror sb) - args)) +;;;--- We should use the motif functions for getting and changing the +;;;--- values + +(defmethod change-scrollbar-values ((sb motif-scrollbar) &key slider-size value) + (let ((mirror (sheet-direct-mirror sb))) + (multiple-value-bind + (smin smax) (silica::gadget-range* sb) + (multiple-value-bind + (mmin mmax) (tk::get-values mirror :minimum :maximum) + (tk::set-values + mirror + :slider-size + (integerize-coordinate + (silica::compute-symmetric-value + smin smax slider-size mmin mmax)) + :value (integerize-coordinate + (silica::compute-symmetric-value + smin smax value mmin mmax))))))) + (defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scrollbar) (widget t)) (tk::add-callback widget @@ -255,14 +295,18 @@ (defun scrollbar-changed-callback-1 (widget sheet) (multiple-value-bind - (value size) - (tk::get-values widget :value :slider-size) - (scrollbar-value-changed-callback - sheet - (gadget-client sheet) - (gadget-id sheet) - value - size))) + (smin smax) (silica::gadget-range* sheet) + (multiple-value-bind + (value size mmin mmax) + (tk::get-values widget :value :slider-size :minimum :maximum) + (scrollbar-value-changed-callback + sheet + (gadget-client sheet) + (gadget-id sheet) + (silica::compute-symmetric-value + mmin mmax value smin smax) + (silica::compute-symmetric-value + mmin mmax size smin smax))))) (defmethod compose-space ((m motif-scrollbar) &key width height) @@ -307,6 +351,7 @@ (t (values 'tk::xm-drawing-area (list :resize-policy :none + :name (string (frame-name (pane-frame sheet))) :margin-width 0 :margin-height 0))))) ;;; diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp index c00a9b6a..bc214b92 100644 --- a/tk-silica/xm-menus.lisp +++ b/tk-silica/xm-menus.lisp @@ -18,97 +18,197 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-menus.lisp,v 1.6 92/03/10 15:39:59 cer Exp Locker: cer $ +;; $fiHeader: xm-menus.lisp,v 1.7 92/03/24 19:37:11 cer Exp Locker: cer $ (in-package :xm-silica) + +;;-- This is generic and should be specialized on xt-port + (defmethod port-menu-choose ((port motif-port) items &rest keys &key printer presentation-type - cache associated-window - default-style label) + default-style label + cache + (unique-id items) + (id-test 'equal) + (cache-value items) + (cache-test #'equal)) + (declare (ignore keys)) (declare (values value chosen-item gesture)) - (let ((simplep (and (null printer) - (null presentation-type)))) - (unless (and (not cache)) - (return-from port-menu-choose - (call-next-method))) - ;; We can use labels for the menu items, so use a Motif menu - (let ((menu (make-instance 'tk::xm-popup-menu - :parent (or (and associated-window - (sheet-mirror associated-window)) - (port-application-shell - port)) - :managed nil)) - (return-value nil) - (value-returned nil)) - (when label - (make-instance 'tk::xm-label - :parent menu - :managed nil - :label-string label) - (make-instance 'tk::xm-separator - :managed nil - :parent menu)) - (map nil #'(lambda (item) - (let ((menu-button - (if simplep - (make-instance 'tk::xm-push-button - :parent menu - :managed nil - :label-string (string - (menu-item-display item))) - (make-instance 'tk::xm-push-button - :parent menu - :managed nil - :label-type :pixmap - :label-pixmap - (pixmap-from-menu-item - associated-window - item - printer - presentation-type)))) - (value (menu-item-value item))) - (tk::add-callback - menu-button - :activate-callback - #'(lambda (&rest args) - (declare (ignore args)) - (setq return-value (list value item) - value-returned t))))) - items) - ;; - (tk::add-callback (widget-parent menu) - :popdown-callback - #'(lambda (&rest ignore) - (setq value-returned t))) - ;; - (tk::manage-children (tk::widget-children menu)) - ;; - (multiple-value-bind - (ignore win1 win2 x y root-x root-y) - (tk::query-pointer (tk::display-root-window - (port-display port))) - (declare (ignore ignore win1 win2 x y)) - (tk::set-values menu :x root-x :y root-y) - (loop - (when value-returned (return nil)) - (tk::manage-child menu) - ;; Now we have to wait - (port-force-output port) - (mp::process-wait "Returned value" #'(lambda () - ;;-- This is to deal - ;;-- with the race - ;;-- condition where - ;;-- the menu go down - ;;-- to quick - (or (not (tk::is-managed-p menu)) - value-returned)))) - ;; destroy the menu - (tk::unmanage-child menu) - (values-list return-value))))) + (let (menu closure) + (when cache + (let ((x (assoc unique-id + (port-menu-cache port) + :test id-test))) + (when x + (destructuring-bind + (menu-cache-value amenu aclosure) x + (if (funcall cache-test cache-value menu-cache-value) + (setq menu amenu closure aclosure) + (progn + (setf (port-menu-cache port) + (delete x (port-menu-cache port))) + ;;--- it would be nice todo this + #+ignore + (tk::destroy-widget amenu))))))) + + (unless menu + (multiple-value-setq + (menu closure) + (port-construct-menu port + items + printer + presentation-type + associated-window + default-style + label)) + (when cache + (push (list unique-id menu closure) + (port-menu-cache port)))) + + ;; initialize the closure + (funcall closure t) + ;; + (multiple-value-bind + (ignore win1 win2 x y root-x root-y) + (tk::query-pointer (tk::display-root-window + (port-display port))) + (declare (ignore ignore win1 win2 x y)) + (tk::set-values menu :x root-x :y root-y) + (loop + (when (funcall closure) (return nil)) + (tk::manage-child menu) + ;; Now we have to wait + (port-force-output port) + (mp::process-wait "Returned value" #'(lambda () + ;;-- This is to deal + ;;-- with the race + ;;-- condition where + ;;-- the menu go down + ;;-- to quick + (or (not (tk::is-managed-p menu)) + (funcall closure))))) + ;; destroy the menu + (tk::unmanage-child menu) + (values-list (nth-value 1 (funcall closure)))))) + +(defmethod port-construct-menu ((port motif-port) + items + printer + presentation-type + associated-window + default-style + label) + (declare (ignore default-style)) + (let (value-returned + return-value + (simplep (and (null printer) + (null presentation-type))) + (menu (make-instance 'tk::xm-popup-menu + :parent (or (and associated-window + (sheet-mirror associated-window)) + (port-application-shell + port)) + :managed nil))) + (when label + (make-instance 'tk::xm-label + :parent menu + :managed nil + :label-string label) + (make-instance 'tk::xm-separator + :managed nil + :separator-type :double-line + :parent menu)) + (labels ((construct-menu-from-items (menu items) + (map nil #'(lambda (item) + (ecase (clim-internals::menu-item-type item) + (:separator + (make-instance 'tk::xm-separator + :managed nil + :parent menu)) + (:label + (make-instance 'tk::xm-label + :parent menu + :managed nil + :label-string (string + (menu-item-display item)))) + (:item + (if (clim-internals::menu-item-item-list item) + (let* ((submenu (make-instance + 'tk::xm-pulldown-menu + :managed nil + :parent menu)) + (menu-button + (if simplep + (make-instance 'tk::xm-cascade-button + :parent menu + :sensitive (clim-internals::menu-item-active item) + :managed nil + :sub-menu-id submenu + :label-string (string + (menu-item-display item))) + (make-instance 'tk::xm-cascade-button + :parent menu + :managed nil + :sub-menu-id submenu + :sensitive (clim-internals::menu-item-active item) + :label-type :pixmap + :label-pixmap + (pixmap-from-menu-item + associated-window + item + printer + presentation-type))))) + (declare (ignore menu-button)) + (construct-menu-from-items + submenu + (clim-internals::menu-item-item-list item))) + (let ((menu-button + (if simplep + (make-instance 'tk::xm-push-button + :parent menu + :sensitive (clim-internals::menu-item-active item) + :managed nil + :label-string (string + (menu-item-display item))) + (make-instance 'tk::xm-push-button + :parent menu + :managed nil + :sensitive (clim-internals::menu-item-active item) + :label-type :pixmap + :label-pixmap + (pixmap-from-menu-item + associated-window + item + printer + presentation-type)))) + (value (menu-item-value item))) + (tk::add-callback + menu-button + :activate-callback + #'(lambda (&rest args) + (declare (ignore args)) + (setq return-value (list value item) + value-returned t)))))))) + items) + ;; + (tk::manage-children (tk::widget-children menu)))) + + (construct-menu-from-items menu items)) + (tk::add-callback (widget-parent menu) + :popdown-callback + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (setq value-returned t))) + (values menu + #'(lambda (&optional init) + (if init + (setf value-returned nil return-value nil) + (values value-returned return-value)))))) + (defun pixmap-from-menu-item (associated-window menu-item printer presentation-type) (with-menu (menu associated-window) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index b96244e3..55b56e74 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.10 92/03/04 16:20:39 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.11 92/03/09 17:41:26 cer Exp Locker: cer $ (in-package :xm-silica) @@ -31,23 +31,6 @@ (defmethod find-port-type ((type (eql ':motif))) 'motif-port) -(ff:defforeign 'xmprocesstraversal - :entry-point "_XmProcessTraversal") - -(defmethod port-note-cursor-change ((port motif-port) - cursor stream type old new) - (declare (ignore old type cursor)) - (call-next-method) - ;;--- This probably is bogus because of the current focus policy - (when new - (xmprocesstraversal (sheet-mirror stream) 0)) - ;;--- Where should this be, really? - (setf (port-keyboard-input-focus port) - (and new stream))) - - - - (defmethod change-widget-geometry ((parent tk::xm-drawing-area) child &rest args &key x y width height) @@ -110,3 +93,10 @@ about their children")) '(:keyboard-focus-policy :pointer)))) (t (call-next-method)))) + +(defmethod make-cursor-widget-for-port ((port motif-port) parent) + (make-instance 'tk::xm-drawing-area + :parent parent + :width 2 + :height 11 + :managed t)) diff --git a/tk-silica/xt-cursor.lisp b/tk-silica/xt-cursor.lisp index 8c4b750a..e0a35c28 100644 --- a/tk-silica/xt-cursor.lisp +++ b/tk-silica/xt-cursor.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-cursor.lisp,v 1.2 92/02/26 10:23:23 cer Exp $ +;; $fiHeader: xm-cursor.lisp,v 1.3 92/03/04 16:20:33 cer Exp Locker: cer $ (in-package :xm-silica) @@ -31,7 +31,7 @@ (state (cursor-state cursor)) (focus (cursor-focus cursor))) (let* ((mirror (sheet-mirror stream)) - (blinker (ensure-blinker-for-cursor stream mirror cursor))) + (blinker (ensure-blinker-for-cursor port stream mirror cursor))) (when blinker (let ((transformation (sheet-native-transformation stream))) (multiple-value-bind (x y) (bounding-rectangle* cursor) @@ -47,7 +47,12 @@ (t (tk::unmanage-child blinker))))))))) -(defmethod ensure-blinker-for-cursor (sheet mirror cursor) +;;--- Whenever the sheet-native-region changes we have to move the +;;--- cursor. Perhaps unmanaging it if its not visible. +;;--- Also, rather than using set-values to position it we should use +;;--- XtMoveWidget + +(defmethod ensure-blinker-for-cursor (port sheet mirror cursor) ;; Make sure that is the widget for the cursor ;;----- This is going to fail in all kinds of ways ;;----- For example if the window is ungrafted and then regrafted @@ -56,11 +61,8 @@ (or (getf clim-internals::plist 'gadget) (setf (getf clim-internals::plist 'gadget) (let ((gadget - (make-instance 'tk::xm-drawing-area - :parent mirror - :width 2 - :height 11 - :managed t))) + (make-cursor-widget-for-port + port mirror))) (xt::realize-widget gadget) (let ((window (tk::widget-window gadget))) (setf (tk::drawable-save-under window) t @@ -70,3 +72,4 @@ (setf (tk::drawable-save-under window) t (xt::drawable-backing-store window) t)) gadget))))) + diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index f3f0f74e..83e2bf62 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.6 92/02/24 13:06:25 cer Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.7 92/03/04 16:20:42 cer Exp Locker: cer $ (in-package :xm-silica) @@ -51,6 +51,22 @@ (declare (ignore realizer type)) options) +;;; Pane + +(defmethod find-widget-class-and-initargs-for-sheet :around + ((port xt-port) (parent t) + (pane pane)) + ;; Include the name of the pane + (multiple-value-bind + (class initargs) + (call-next-method) + (let ((name (pane-name pane))) + (values class + (progn + (when (and name (not (getf initargs :name))) + (setf (getf initargs :name) (string name))) + initargs))))) + ;; Background/foreground/text-style mixin (defmethod find-widget-class-and-initargs-for-sheet :around diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index eb917b65..9e314e93 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.15 92/03/24 19:37:17 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.16 92/03/30 17:52:50 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,7 +30,10 @@ (context :reader port-context) (copy-gc :initform nil) (type :allocation :class - :initform :xt :reader port-type)) + :initform :xt :reader port-type) + (menu-cache + :initform nil + :accessor port-menu-cache)) (:default-initargs :allow-loose-text-style-size-mapping t) (:documentation "The port for X intrinsics based ports")) @@ -408,6 +411,7 @@ (find-shell-class-and-initargs port sheet) (apply #'make-instance class :parent (find-shell-parent port sheet) + :name (string (frame-name (pane-frame sheet))) initargs)) (sheet-mirror ma)))) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 6ab1189a..e59353d3 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign.lisp,v 1.6 92/03/09 17:40:42 cer Exp $ +;; $fiHeader: foreign.lisp,v 1.7 92/03/30 17:51:33 cer Exp Locker: cer $ (in-package :tk) @@ -54,8 +54,8 @@ (defun open-display (&key (context (create-application-context)) (host nil) - (name "foo") - (class "Foo") + (name "clim") + (class "Clim") (options 0) (num-options 0) (argc 0) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 1288832d..af036763 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,11 +20,11 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.6 92/02/24 13:03:09 cer Exp Locker: cer $ +;; $fiHeader: load-ol.lisp,v 1.7 92/03/30 17:51:37 cer Exp Locker: cer $ (in-package :tk) -(defvar *libxol-pathname* "/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") +(defvar *libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") (defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") (defun load-from-ol () @@ -35,11 +35,18 @@ "misc/undefinedsymbols.olit") '("__unpack_quadruple" "__unpacked_to_decimal" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000") - (list *libxol-pathname* - *libxt-pathname* - x11::*libx11-pathname*))) + "__prod_b10000" + "__carry_out_b10000" + "__prod_65536_b10000" + ;; got these when compiling on ox + "__pack_integer" + "_class_double" + "_class_single" + "_class_extended" + "__unpack_integer" + ) + (list *libxol-pathname* + *libxt-pathname* + x11::*libx11-pathname*))) (load-from-ol) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index da2e9a7e..b67698ee 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.8 92/03/24 19:36:13 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.9 92/03/30 17:51:39 cer Exp Locker: cer $ (in-package :tk) @@ -40,7 +40,14 @@ '("__unpack_quadruple" "__prod_b10000" "__carry_out_b10000" - "__prod_65536_b10000") + "__prod_65536_b10000" + ;; got these when compiling on ox + "__pack_integer" + "_class_double" + "_class_single" + "_class_extended" + "__unpack_integer" + ) (list *libxm-pathname* *libxt-pathname* x11::*libx11-pathname*))) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 9ad67114..dd26be3f 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.10 92/03/09 17:40:47 cer Exp $ +;; $fiHeader: make-classes.lisp,v 1.11 92/03/30 17:51:42 cer Exp Locker: cer $ (in-package :tk) @@ -166,6 +166,7 @@ (defun add-accessors-for-toolkit-class (class) + #+ignore (dolist (r (class-direct-resources class)) (let* ((rname (resource-name r)) (name (intern (format nil "~A-~A" 'widget rname)))) @@ -182,8 +183,7 @@ (get-values x rname)))) (add-method (ensure-generic-function `(setf ,name)) - (make-instance 'clos:: - standard-method + (make-instance 'clos::standard-method :lambda-list '(nv x) :qualifiers nil :specializers (list (find-class t) class) @@ -191,8 +191,10 @@ (set-values x rname nv) nv)))))) -(defun define-toolkit-classes (classes) - (make-classes classes)) +(defun define-toolkit-classes (&rest classes) + (make-classes (remove-duplicates + (apply #'append classes) + :test #'string=))) (defun widget-class-name (h) diff --git a/tk/make-widget.lisp b/tk/make-widget.lisp index 276cd6ff..26a981d9 100644 --- a/tk/make-widget.lisp +++ b/tk/make-widget.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: user -*- +;; -*- mode: common-lisp; package: tk -*- ;; ;; -[]- ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-widget.lisp,v 1.3 92/01/31 14:54:57 cer Exp $ +;; $fiHeader: make-widget.lisp,v 1.4 92/02/24 13:03:30 cer Exp Locker: cer $ (in-package :tk) @@ -47,3 +47,14 @@ (apply #'create-popup-shell name (class-of w) parent args)) +;; Where should this go?? + +(defmacro define-widget-accessor (name class resource) + `(progn + (defmethod ,name ((widget ,class)) + (get-values widget ,resource)) + (defmethod (setf ,name) (nv (widget ,class)) + (set-values widget ,resource nv)))) + +(define-widget-accessor widget-children composite :children) +(define-widget-accessor widget-num-children composite :num-children) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index e9ba1b39..4520a346 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.7 92/03/09 17:40:52 cer Exp Locker: cer $ +;; $fiHeader: ol-init.lisp,v 1.8 92/03/24 19:36:17 cer Exp Locker: cer $ (in-package :tk) @@ -73,7 +73,9 @@ (unless *ol-done* (ol-initialize) (xt-initialize) - (define-toolkit-classes *openlook-classes*) + (define-toolkit-classes + *intrinsic-classes* + *openlook-classes*) (setq *ol-done* t)) (defmethod make-widget ((w event) diff --git a/tk/resources.lisp b/tk/resources.lisp index cdd90ce7..8d156770 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.11 92/03/10 10:11:31 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.12 92/03/30 17:51:49 cer Exp Locker: cer $ (in-package :tk) @@ -132,9 +132,15 @@ (char*-to-string (sys:memref-int (foreign-pointer-address string) 0 0 :signed-long))))) -(defmethod convert-resource-out ((parent t) (type (eql 'separator-type)) value) - (ecase value - (:single-line 1))) + +(define-enumerated-resource separator-type (:no-line + :single-line + :double-line + :single-dashed-line + :double-dashed-line + :shadow-etched-in + :shadow-etched-out)) + (defmethod convert-resource-out ((parent t) (type (eql 'menu-widget)) value) value) diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp index 6e835b7f..1054a871 100644 --- a/tk/xm-init.lisp +++ b/tk/xm-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-init.lisp,v 1.5 92/02/24 13:04:03 cer Exp Locker: cer $ +;; $fiHeader: xm-init.lisp,v 1.6 92/03/24 19:36:19 cer Exp Locker: cer $ (in-package :tk) @@ -29,7 +29,9 @@ (unless *xm-done* (xt-initialize) - (define-toolkit-classes *motif-classes*) + (define-toolkit-classes + *intrinsic-classes* + *motif-classes*) (setq *xm-done* t)) diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp index 3bdc3c44..b31e5716 100644 --- a/tk/xt-init.lisp +++ b/tk/xt-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-init.lisp,v 1.2 92/02/24 13:04:16 cer Exp Locker: cer $ +;; $fiHeader: xt-init.lisp,v 1.3 92/03/24 19:36:21 cer Exp Locker: cer $ (in-package :tk) @@ -30,5 +30,4 @@ (defun xt-initialize () (unless *xt-done* (toolkit-initialize) - (define-toolkit-classes *intrinsic-classes*) (setq *xt-done* t))) diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 4fcead83..0741cca7 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: excl-verification.lisp,v 1.6 92/03/24 19:36:55 cer Exp Locker: cer $ +;; $fiHeader: excl-verification.lisp,v 1.7 92/03/30 17:52:11 cer Exp Locker: cer $ (in-package :sys) @@ -8,6 +8,13 @@ (assert (eq excl::*current-case-mode* :case-insensitive-lower)) +(eval-when (compile load eval) + (pushnew :clim *features*) + (pushnew :clim-2 *features*) + (pushnew :clim-2.0 *features*) + (pushnew :silica *features*) + ) + #-Silica (eval-when (compile load eval) (require :clx)) diff --git a/utils/packages.lisp b/utils/packages.lisp index bb4dd380..9a0f0939 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.7 92/03/10 10:11:54 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.8 92/03/24 19:36:56 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2513,6 +2513,7 @@ note-frame-enabled notify-user pane-frame + pane-name pane-needs-redisplay panes-need-redisplay pane-viewport @@ -2582,6 +2583,10 @@ gadget-indicator-type gadget-label gadget-orientation + gadget-min-value + gadget-max-value + gadget-range + gadget-range* gadget-value label-pane menu-bar -- GitLab