diff --git a/clim/command.lisp b/clim/command.lisp index c3c159d745eba2ed3c7b1115a1e148d9e0a78e98..b466361d7d8993e81d7a12c695931d6fdb7832b2 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.3 92/02/24 13:07:07 cer Exp $ +;; $fiHeader: command.lisp,v 1.4 92/03/04 16:21:15 cer Exp Locker: cer $ (in-package :clim-internals) diff --git a/clim/db-border.lisp b/clim/db-border.lisp deleted file mode 100644 index 3f614f745a10a2bb258e1f04e46d2837bfd89627..0000000000000000000000000000000000000000 --- a/clim/db-border.lisp +++ /dev/null @@ -1,257 +0,0 @@ -;;; -*- Mode: Lisp; Package: WINDSHIELD; Base: 10.; Syntax: Common-Lisp -*- -;; -;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. -;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. -;; -;; The software, data and information contained herein are proprietary -;; to, and comprise valuable trade secrets of, Franz, Inc. They are -;; given in confidence by Franz, Inc. pursuant to a written license -;; agreement, and may be stored and used only in accordance with the terms -;; of such license. -;; -;; Restricted Rights Legend -;; ------------------------ -;; Use, duplication, and disclosure of the software, data and information -;; contained herein by any agency, department or entity of the U.S. -;; Government are subject to restrictions of Restricted Rights for -;; Commercial Software developed at private expense as specified in FAR -;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;;; -;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. -;;; -;; $fiHeader: db-border.lisp,v 1.2 92/01/02 15:33:03 cer Exp $ - - -(in-package :silica) - - -;;; -;;; Border Panes -;;; - -(define-pane-class border-pane (composite-pane - simple-wrapper-mixin - mute-input-mixin) - ((thickness :initform 1 :initarg :thickness :accessor thickness))) - -(defmethod compose-space ((pane border-pane)) - (with-slots (thickness) pane - (unless (numberp thickness) - (error "Non-number border size not yet supported.")) - (let ((child (sheet-child pane))) - (space-req+* (compose-space child) - :hs (* 2 thickness) - :vs (* 2 thickness))))) - -(defmethod allocate-space ((pane border-pane) width height) - (with-slots (thickness) pane - (move-and-resize-sheet* (sheet-child pane) - thickness thickness - (- width (* 2 thickness)) - (- height (* 2 thickness))))) - -(define-pane-class outlined-pane (pane-background-mixin - layout-mixin - border-pane) - () - (:default-initargs :background *black*)) - - -(defvar *default-shadow-thickness* 2) - -(defclass shadowed-style (repaint-handler) - ((darker-color :initform *gray* :initarg :darker-color) - (lighter-color :initform *white* :initarg :lighter-color) - (popin-p :initform nil :initarg :popin-p)) - (:default-initargs :thickness *default-shadow-thickness*)) - -(define-pane-class shadowed-pane (shadowed-style - border-pane) - - ()) - -(defmethod handle-repaint ((shadow shadowed-style) repaint-region - &key medium &allow-other-keys) - #-PCL;; PCL uses this variable for method-table cache misses, unfortunately. - (declare (ignore repaint-region)) - (with-slots (thickness popin-p darker-color lighter-color) shadow - (let* ((width (bounding-rectangle-width shadow)) - (height (bounding-rectangle-height shadow))) - - ;; left side and top - (draw-polygon* - medium (list 0 0 0 height width height width (- height thickness) - thickness (- height thickness) thickness 0) - :ink (if popin-p darker-color lighter-color) - :filled t) - - ;; ???? disable this code on non-monochrome - (unless popin-p - (draw-line* medium thickness thickness thickness (- height thickness)) - (draw-line* medium thickness (- height thickness) - (- width thickness) (- height thickness))) - - ;; right-side and bottom - (draw-polygon* - medium (list width 0 width height - (- width thickness) (- height thickness) - (- width thickness) thickness thickness thickness 0 0) - :ink (if popin-p lighter-color darker-color) - :filled t) - - ;; disable this code on non-monochrome - (when popin-p - (draw-line* medium thickness thickness (- width thickness) thickness) - (draw-line* medium (- width thickness) thickness - (- width thickness) (- height thickness)))))) - - -;;; -;;; Labelled Border -;;; - -(define-pane-class labelled-border-pane (composite-pane - simple-wrapper-mixin - mute-input-mixin - text-part) - ((thickness :initform 1 :initarg :thickness :accessor thickness))) - -(defmethod compose-space ((pane labelled-border-pane)) - (with-slots (thickness) pane - (unless (numberp thickness) - (error "Non-number border size not yet supported.")) - (let ((child (sheet-child pane))) - (space-req+* (compose-space child) - :hs (* 2 thickness) - :vs (+ (* 2 thickness) (text-height pane)))))) - -(defmethod allocate-space ((pane labelled-border-pane) width height) - (with-slots (thickness) pane - (let ((th (text-height pane))) - (move-and-resize-sheet* (sheet-child pane) - thickness (+ th thickness) - (- width (* 2 thickness)) - (- height (* 2 thickness) th))))) - -(defmethod handle-repaint ((pane labelled-border-pane) repaint-region - &key medium &allow-other-keys) - ;; Will we lose if we ignore the repaint region? - (declare (ignore repaint-region)) - (with-slots (text-style background ink text halign valign) pane - (with-bounding-rectangle* (minx miny maxx maxy) (sheet-region pane) - (let* ((th (text-height pane)) - (th/2 miny #+ignore (floor th 2)) - (tw (text-width pane)) - (lw (floor (- maxx minx tw) 2)) - ) - - (draw-rectangle* medium minx miny maxx maxy - :filled t - :ink background) - (let ((maxx (1- maxx)) - (maxy (1- maxy))) - (draw-line* medium minx th/2 minx maxy) - (draw-line* medium maxx th/2 maxx maxy) - (draw-line* medium minx maxy maxx maxy) - - (draw-line* medium minx th/2 (1- lw) th/2) - (draw-line* medium (- maxx (1- lw)) th/2 maxx th/2) - - - ) - - (draw-text-rectangle* medium text - minx miny maxx th - :align-x :center - :align-y :center - :text-style text-style - :ink ink))))) - -;;; -;;; Spacer Pane -;;; - -(define-pane-class spacer-pane (pane-background-mixin - mute-input-mixin - composite-pane - simple-wrapper-mixin - client-space-space-req-mixin - space-req-cache-mixin) - ((halign :initform :center :initarg :halign :accessor spacer-halign) - (valign :initform :center :initarg :valign :accessor spacer-valign)) - #+ignore - (:default-initargs :hs+ +fill+ :vs+ +fill+) - (:default-initargs :halign :left :valign :bottom - :hs 2 :vs 2)) - - -(defmethod compose-space ((pane spacer-pane)) - (let ((child (sheet-child pane))) - (with-slots (client-space-req) pane - (space-req+ (compose-space child) client-space-req)))) - -(defmacro allocate-amount (contract amount (space space+ space-)) - `(with-slots (space-req client-space-req) ,contract - (let ((stretch-p (> ,amount (,space space-req))) - give extra used) - (if stretch-p - (progn (setq give (,space+ space-req)) - (setq extra (min (- ,amount (,space space-req)) - give))) - (progn (setq give (,space- space-req)) - (setq extra (min (- (,space space-req) ,amount) - give)))) - ;; Allocate Space to the Children - (let* ((alloc (,space client-space-req))) - (when (> give 0) - (if stretch-p - (progn (setq used (/ (* (,space+ client-space-req) extra) - give)) - (incf alloc used)) - (progn (setq used (/ (* (,space- client-space-req) extra) - give)) - (decf alloc used)))) - alloc)))) - -(defmethod allocate-space ((pane spacer-pane) width height) - (with-slots (space-req halign valign) pane - - (unless space-req (compose-space pane)) ;; Needs the space-req-cache filled - - (let* ((child (sheet-child pane)) - (child-space (compose-space child)) - (child-width (space-req-hs child-space)) - (child-height (space-req-vs child-space)) - (hspace (allocate-amount pane width (space-req-hs - space-req-hs+ - space-req-hs-))) - (hoff (floor hspace 2)) - (vspace (allocate-amount pane height (space-req-vs - space-req-vs+ - space-req-vs-))) - (voff (floor vspace 2)) - new-x new-y new-w new-h) - - (setf new-w (- width hspace)) - - ;; Note when given the space wanted, the align won't make a difference. - (setf new-x (ecase halign - (:left hoff) - (:center (max 0 (floor (- width child-width) 2))) - (:right (max 0 (- width hoff child-width))))) - - (setf new-h (- height vspace)) - (setf new-y (ecase valign - (:bottom voff) - (:center (max 0 (floor (- height child-height) 2))) - (:top (max 0 (- height voff child-height))))) - - (move-and-resize-sheet* child new-x new-y new-w new-h)))) - - - - - - diff --git a/clim/menus.lisp b/clim/menus.lisp index 26db72c3d5380fe3d5b4b794a915d01c525f72ff..2a040e294a31eeaea08a55c95f02cb5e80e4d163 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.12 92/02/26 10:23:38 cer Exp $ +;; $fiHeader: menus.lisp,v 1.13 92/03/04 16:22:00 cer Exp Locker: cer $ (in-package :clim-internals) diff --git a/demo/listener.lisp b/demo/listener.lisp index ba082ba0973539349b738252643a5060e00a1b75..b5335316c582f79dd66b1f6cb3cd271bd72e9838 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: listener.lisp,v 1.4 92/02/28 09:17:59 cer Exp $ +;; $fiHeader: listener.lisp,v 1.5 92/03/04 16:23:00 cer Exp Locker: cer $ (in-package :clim-demo) diff --git a/notes/clim.todo b/notes/clim.todo index fe05cff7c8946b2e946f3b4ee11c2dfc67a39f77..3e72ed4673a87848f27caf62a6f9cfae3f722532 100644 --- a/notes/clim.todo +++ b/notes/clim.todo @@ -1,45 +1,65 @@ -%% $fiHeader: clim.todo,v 1.6 92/03/02 19:16:26 cer Exp Locker: cer $ +%% $fiHeader: clim.todo,v 1.7 92/03/04 10:47:05 cer Exp Locker: cer $ -%% ****************************************** SWM THINGS +%% ****************************************** SWM things % Silica back-ends * [swm] Genera + - Get the basic port working. + - When a sheet has only a TOP-LEVEL-SHEET as its parent, and overlaps no + other sheet, mirror it. + - Mirrored sheets on Genera should use Genera scroll bars. * [swm] Raw CLX % Holes to fill in - * [swm] Protocol for deciding whether prompt-for-accept should or not. + * [swm] Protocol for deciding whether PROMPT-FOR-ACCEPT should or not. * [swm] Complete abstract gadgets. - Take whatever is needed from ILA CLIM in order to get the non-adaptive - gadgets together. - * [swm] Write a "null" frame manager that implements the same look and feel for all - ports. + gadgets together. + - Most gadgets should use temporary mediums. + - Do some graphic design work (but not too much :-). + * [swm] Write a "null" frame manager that implements the same look and feel + for all ports. - Genera's frame manager will inherit from this. - * [swm] Take the keyboard gesture stuff code from ILA CLIM, but make it more - cons-efficient. + * [swm] Implement the keyboard gesture stuff, modelled after ILA CLIM. + - Flush the EXTENDED-CHAR type at the same time. * [swm] Stream defprotocols: be sure that all of the sheet and medium protocol functions are explicitly defined with DEFOPERATION so that the stream - trampolines are properly created. + trampolines are properly created. + - TEXT-STYLE-xxx in TEXT-STYLE.LISP + - SHEET-xxx in GADGET-OUTPUT.LISP + - MEDIUM-DRAW-xxx in STREAM-DEFPROTOCOLS.LISP + - WINDOW-xxx in STREAM-DEFPROTOCOLS.LISP * Temporary-medium sheets. - [swm] Medium accessors on a sheet with no medium? * [swm] Implement compatibility code for CLIM 1.0's :LAYOUT language. - * [swm] Should we divide the drawing protocol into a medium and a port layer, or - should it be a single layer as Bill suggests? + * [swm] Should we divide the drawing protocol into a medium and a port layer, + or should it be a single layer as Bill suggests? * [swm] Spiff up the code for defining new graphics operators. - DEFINE-GRAPHICS-OPERATOR is like DEFGENERIC. - DEFINE-GRAPHICS-METHOD is like DEFMETHOD. - DEFINE-GRAPHICS-RECORDING. - What of this goes into the spec? - * [swm] Figure out what things are part of the frame manager protocol and which are - part of the port protocol. + * [swm] Figure out what things are part of the frame manager protocol and + which are part of the port protocol. - PORT-MENU-CHOOSE should really be FRAME-MANAGER-MENU-CHOOSE. - Ditto, PORT-DIALOG-VIEW. + * [swm] Figure out which things are part of the medium protocol and which are + part of the port protocol. + - Should we divide the drawing protocol into a medium and a port layer, or + should it be a single layer as Bill suggests? (That is, do we need to + flush PORT-DRAW-xxx?) + - Ditto, COPY-AREA. + * [swm] Figure out what things are part of the graft ("console"? "display"?) + protocol and which are part of the port protocol. * [swm] Figure out how views really interact with frame managers and dialogs. - Indirect views. + * [swm] Reinstate clipping regions + - For output records * [swm] Implement more of DRAW-DESIGN for composites. - Create a table that describes what works and what doesn't, for each port. - * [swm] Figure out which WINDOW-xxx functions from CLIM 1.0 make sense. It's OK to - change the names to correspond to newthink. - - WINDOW-VIEWPORT + * [swm] Figure out which WINDOW-xxx functions from CLIM 1.0 make sense. It's + OK to change the names to correspond to newthink. + - WINDOW-VIEWPORT => PANE-VIEWPORT-REGION - WINDOW-VIEWPORT-POSITION* and WINDOW-SET-VIEWPORT-POSITION*. - WINDOW-INSIDE-xxx and WINDOW-SET-INSIDE-xxx. @@ -48,22 +68,35 @@ - Go through CLIM 1.0 to make sure we didn't miss anything. - Go through ILA CLIM with a fine-tooth comb. * [swm] Flush all of the DRAW-xxx-INTERNAL junk. - * [swm ] Find all the #+Silica/#-Silica stuff. + * [swm] Do we use PORT-WRITE-CHAR-1 and PORT-WRITE-STRING-1 anywhere? + * [swm] Find all the #+Silica/#-Silica stuff. - Make sure that the #+Silica branch really does the right thing. - Flush the #-Silica branch. * [swm] Must we really convert all of the code to lowercase? Do it if we must. % Bugs to fix - * [swm] No output-recording for draw-text*. Hence the compass menu is - broken. + * [swm] No output-recording for DRAW-TEXT*. Hence the compass menu is broken. + * [swm] Missing graphics operators, to be taken from CLIM 1.0. + - DRAW-ARROW[*] + - DRAW-OVAL[*] + - Spiff up DRAW-POINTS[*] and DRAW-LINES[*] + * [swm] Rectangles and bboxes don't do region arithmetic with each other. + - STANDARD-BOUNDING-RECTANGLE should inherit from STANDARD-RECTANGLE. + - All region classes should have slots of type COORDINATE, but be sure that + the constructors do the necessary coercions. + * Cursors are just plain buggy. + - [swm] Make the Genera port use native cursors when possible. % Performance * [swm] Simplify transformation classes so that there is a single class of transformation. Special-case +IDENTITY-TRANSFORMATION+. * [swm] Make use of volatile transformations. - Be careful never to modify +IDENTITY-TRANSFORMATION+. - * [swm] Make use of volatile rectangular regions. + * [swm] Make use of volatile rectangular regions for sheets. * [swm] Reinstate sheet region and transformation caches (as in ILA CLIM). + * [swm] Use resourced events to save consing. + - This means events are volatile, so we need COPY-EVENT in the API. + - Keep a speedy resource of 10 or so of each kind of event. * [swm] (deftype coordinate () ...) - Flush all inappropriate FIXNUM declarations from the code and replace them with the new COORDINATE declaration. @@ -128,19 +161,21 @@ - What else? - -r% ********************************************* CER THINGS +%% ********************************************* CER things % Silica back-ends * [cer,jdi] Xt - Motif - OpenLook - % Holes to fill in - * [cer] input-protocol and the handle-event problem - * [cer] Why does INPUT-PROTOCOL-MIXIN define an input buffer? What's wrong with the + * [cer] INPUT-PROTOCOL and the HANDLE-EVENT problem + - Why does INPUT-PROTOCOL-MIXIN define an input buffer? What's wrong with the sheet event queue? + - What we really need to do is maintain a separate input buffer for the stream, + then STREAM-READ-GESTURE should loop doing HANDLE-EVENT until something gets + inserted into the stream's input buffer. When there is something in input + buffer, STREAM-READ-GESTURE should then process it. * [cer] Define cursor protocol * [cer] Rename DEFSYS package to CLIM-DEFSYS. * Sheet protocol. @@ -150,8 +185,8 @@ r% ********************************************* CER THINGS * [cer] Multiple layouts need to allow different size reqs for the sheets. * [cer] The code for switching layouts needs to be cleaned up. * [cer] Protocol to compute to the WM the desired geometry of the frame. - * [cer] When the viewport is resized in might need to be moved, for example, if it - becomes big enough to display the entire window: in the ALLOCATE-SPACE for + * [cer] When the viewport is resized in might need to be moved, for example, if + it becomes big enough to display the entire window: in the ALLOCATE-SPACE for viewport. * [cer] Pointer documentation panes and other pane types, * [cer] Gadget enable/disable protocol. @@ -164,44 +199,56 @@ r% ********************************************* CER THINGS windows where we want. % Bugs to fix - * [cer] What's the problem with radio-boxes and move-cursor-after. The alternative - definitions almost work except for exit-buttons. I think the bounding - rectangle of gadget output records is computed incorrectly and that it - works because the update-gadget-position is broken to match. - * [cer] why? #<standard-method stream-read-char-no-hang (motif-top-level-sheet) @ #x1b18eee> - * [cer] When default-text-margin slot yet bound. Drawing on a unexposed window - can cause problems. + * [cer] What's the problem with radio-boxes and move-cursor-after. The + alternative definitions almost work except for exit-buttons. I think the + bounding rectangle of gadget output records is computed incorrectly and that + it works because the UPDATE-GADGET-POSITION is broken to match. + * [cer] why? #<standard-method STREAM-READ-CHAR-NO-HANG (motif-top-level-sheet) @ #x1b18eee> + * [cer] When default-text-margin slot yet bound, drawing on a unexposed window + can cause problems. + * [cer] command parser uses the variable stream, + others. + * [cer] perhaps max widths ending up smaller than widths! + * [cer] :fill in box panes?? + * [cer] why do we need a pane when we read commands? -%%%% ******************************************* JDI THINGS +%% ******************************************* JDI things % Holes to fill in * [jdi] Design and implement a colormap scheme + - Poll the CLIM@BBN.COM mailing list to see what the requirements are. + -%%% **************************************** UNASSIGNED THINGS +%% **************************************** UNASSIGNED things % Silica back-ends - * [??] Postscript + * [???] PostScript + +% Cleanups + * Make the CLIM-LISP package conform exactly to the exports in X3J13. % Holes to fill in + * Implement pixmap mediums. Check out the use of MEDIUM-TYPE in ILA CLIM. + * Verify that :MENU-BAR fully subsumes ILA CLIM's :MENU-GROUP. * [all] Layout for gadgets within ACCEPTING-VALUES. * [all] ACCEPTING-VALUES :OWN-WINDOW architecture that allows integration with toolkit dialogs. * [all] Implement clean interface to THROW-HIGHLIGHTED-PRESENTATION. - SWM claims that it is already clean. Why do SWM and CER disagree? - * [all] Interprocess communication, i.e., one process to another to execute a frame - command. + * [all] Interprocess communication, i.e., one process to another to execute a + frame command. * Temporary-medium sheets. - - [all] Temporary medium need to have their state decached. This looks - like it should be a method on deallocate-medium since the medium - is not degrafted. Just not associated with a window. This does - not seem nice: engraft,degraft, deallocate? + - Medium accessors on a sheet with no medium? + - [all] Temporary medium need to have their state decached. This looks like + it should be a method on deallocate-medium since the medium is not + degrafted. Just not associated with a window. This does not seem nice: + engraft, degraft, deallocate? * Sheet protocol. - [all] Where do event queues come from? - [all] Repaint protocol: who clears the area and sets the clipping region when doing the repaint? - - [all] What is the precise value returned by EVENT-SHEET? Does the EVENT-SHEET - accessor return the sheet that the event was dispatched to? We - had to do this for correct distribution of keyboard events. + - [all] What is the precise value returned by EVENT-SHEET? Does the + EVENT-SHEET accessor return the sheet that the event was dispatched to? + We had to do this for correct distribution of keyboard events. * Event protocol: - Consider design of DISTRIBUTE-EVENT. - [all] Timestamp. @@ -209,15 +256,16 @@ r% ********************************************* CER THINGS * [all] Should we do "stream relative" coordinates (as opposed to the current "parent relative" scheme) for output records? It solves some problems, but introduces others. + * silica::shift-code is undefined in the gesture code. % Final spec conformance checking -% Final Testing and bug fixing + +% Final testing and bug fixing % Performance * [all] Meet CLIM 1.0 performance goals. * [all] Surpass CLIM 1.0 performance goals. - * Add port-level caches for inks. - + * Add port-level (graft-level? medium-level?) caches for inks. % User Guide. @@ -226,3 +274,4 @@ r% ********************************************* CER THINGS % Franz specific stuff. % [todo: /vapor/usr/tech/cer/todo/franz-clim.todo] + diff --git a/silica/mirror.lisp b/silica/mirror.lisp index e53442bd353b531d8af0f1a7ef1b9574306dec99..9e0ca13477c1c9b578585d10195e256584f79257 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.8 92/02/24 13:04:51 cer Exp $ +;; $fiHeader: mirror.lisp,v 1.9 92/03/04 16:19:49 cer Exp Locker: cer $ (in-package :silica) @@ -263,8 +263,13 @@ (sc-y (/ (- mirror-bottom mirror-top) (- bottom top)))) (when (or (/= sc-x 1.0) - (/= sc-y 1.0)) - (warn "Mirror scaling ~S, ~S" (list tr-x tr-y sc-x sc-y) sheet)) + (/= sc-y 1.0) + (not (zerop tr-x)) + (not (zerop tr-y))) + (warn "Mirror scaling ~S,~S,~S,~S" + (list tr-x tr-y sc-x sc-y) sheet + (multiple-value-list (mirror-inside-edges* port sheet)) + (sheet-region sheet))) (setf (sheet-native-transformation sheet) ;;--- Inline the composition to save some consing (compose-transformations diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 2a2ee248ab1460760b99c780ba2af0846f1e3b6b..b2e34ebf9e6f241644a88b4a1c71d438092ba579 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.11 92/02/26 10:23:49 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.12 92/03/04 16:22:38 cer Exp Locker: cer $ (in-package :clim-user) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 24749771b46ab37f76f070b5909a31ec9ee41a05..0e52ee40cf509b45e3f80db7667ac79d2383cbb4 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.12 92/02/26 10:23:24 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.13 92/03/04 16:20:36 cer Exp Locker: cer $ (in-package :xm-silica) @@ -105,7 +105,7 @@ (sheet motif-label-pane)) (with-accessors ((label gadget-label)) sheet (values 'tk::xm-label - (and label (list :label-string))))) + (and label (list :label-string label))))) ;;; Push button diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index a396ac5aef5144e74417b91f1bfc31a156bf0bdd..0ea475efb5ca3eaf1094942d106bb30e900468fb 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.8 92/02/26 10:23:28 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.9 92/03/04 16:20:46 cer Exp Locker: cer $ (in-package :xm-silica) @@ -484,10 +484,11 @@ (/= target-top ny) (/= w nw) (/= h nh)) - (warn "Geo set fail, ~S, ~S,~S" - sheet - (list target-left target-top w h) - (list nx ny nw nh)))))) + (let ((*error-output* excl:*initial-terminal-io*)) + (warn "Geo set fail, ~S, ~S,~S" + sheet + (list target-left target-top w h) + (list nx ny nw nh))))))) (defmethod process-next-event (port &key wait-function timeout) (tk::process-one-event (port-context port) diff --git a/tk/resources.lisp b/tk/resources.lisp index 7e600e0af21f00339c49cba9898f0cf1956134ca..036f56eda372765ef73c1d31fc7ccd515ea8a171 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.7 92/02/05 21:45:06 cer Exp $ +;; $fiHeader: resources.lisp,v 1.8 92/02/24 13:03:48 cer Exp Locker: cer $ (in-package :tk) @@ -232,10 +232,10 @@ (ash value -16)) (defmethod convert-resource-in ((parent t) (type (eql 'horizontal-position)) value) - (ash value -16)) + (convert-16bit-resource-in value)) (defmethod convert-resource-in ((parent t) (type (eql 'vertical-position)) value) - (ash value -16)) + (convert-16bit-resource-in value)) (defmethod convert-resource-out ((parent t) (type (eql 'pixel)) value) (etypecase value @@ -331,8 +331,16 @@ (defmethod convert-resource-out ((parent t) (type (eql 'position)) value) value) -(defmethod convert-resource-in ((parent t) (type (eql 'position)) value) - (ash value -16)) +(defmethod convert-resource-in ((parent t) (type (eql 'position)) + value) + (convert-16bit-resource-in value)) + +(defun convert-16bit-resource-in (value) + (let ((x (ash value -16))) + ;; 16bit signed value! + (if (>= x (ash 1 15)) + (- x (ash 1 16)) + x))) (defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value) value)