From c4fd42d62f3ace2df8f5b2a5d421d1df822fc180 Mon Sep 17 00:00:00 2001 From: colin <colin> Date: Tue, 7 Dec 1993 05:34:43 +0000 Subject: [PATCH] see changelog from colin: Mon Dec 6 21:30:54 PST 1993 --- ChangeLog.n | 58 ++++++++++++++++++ Makefile.defs | 17 +++--- Makefile.generic | 16 ++--- clim/accept-values.lisp | 3 +- clim/accept.lisp | 26 ++++---- clim/frames.lisp | 35 ++++++----- clim/gadget-output.lisp | 10 ++- clim/standard-types.lisp | 117 ++++++++++++++++++------------------ clim/stream-class-defs.lisp | 9 ++- demo/ico.lisp | 3 +- silica/layout.lisp | 39 ++++++------ silica/mirror.lisp | 8 ++- tk-silica/ol-gadgets.lisp | 45 +++++++------- tk-silica/ol-silica.lisp | 22 ++++++- tk-silica/xm-frames.lisp | 4 +- tk-silica/xm-gadgets.lisp | 29 +++++---- tk-silica/xm-silica.lisp | 15 ++--- tk-silica/xt-pixmaps.lisp | 13 ++-- tk-silica/xt-silica.lisp | 33 ++++++---- tk/event.lisp | 27 +++------ utils/packages.lisp | 3 +- 21 files changed, 311 insertions(+), 221 deletions(-) diff --git a/ChangeLog.n b/ChangeLog.n index 4fa260fb..5bba7943 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,61 @@ +from colin: Mon Dec 6 21:30:54 PST 1993 + +Makefile.defs, Makefile.generic + got rid of DUMP-CLIM - no longer necessary + +Makefile.generic fixed bug in rule for climxm.fasl + +clim/accept.lisp fixed :activation-gestures and :delimiter gestures + for accept-1 and accept-from-string + +clim/frames.lisp made resizable frames resize when layout changes + added note-frame-layout-changed + +clim/gadget-output.lisp fixed accepting of multi-line string in + accept-values-string-field-changed-callback + +clim/standard-types.lisp + completeley rewrote accept of expressions - this + fixes a bunch of longstanding bugs + +clim/stream-class-defs.lisp + standard-sequence-output-history now the + default instead of coordinate-sorted-set + +silica/layout.lisp simplified resize-sheet (basic-sheet t t) + +silica/mirror.lisp removed bogus sheet-native-transformation method on + basic-sheet + +tk/event.lisp, tk-silica/ol-silica.lisp, tk-silica/xt-silica.lisp + fixed bug with event type preferencing causing + problems for motif dnd + +tk-silica/ol-gadgets.lisp + hacked ol scroll panes again so that + scroll-bars vertical works properly + +tk-silica/xm-frames.lisp + changed note-frame-current-layout to + note-frame-layout + +tk-silica/xm-gadgets.lisp + bug fix in motif scroller panes + +tk-silica/xm-silica.lisp + named xm-cursor widget - aides debugging + +tk-silica/xt-pixmap.lisp + changed all calls to sheet-native-transformation to + calls to sheet-device-transformation + +tk-silica/xt-silica.lisp + simplified find-shell-parent + added clim keysym for XK_End + +utils/packages.lisp exported note-frame-layout-changed from clim package + +------------------------------------------------------------ Fri Dec 3 15:28:36 1993 Duane Rettig (duane at clay) (for 4.2.devel.22 merge): diff --git a/Makefile.defs b/Makefile.defs index 38157fb3..113e90f3 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.26 1993/11/18 18:43:56 cer Exp $ +# $fiHeader: Makefile.defs,v 1.27 1993/11/23 19:58:26 cer Exp $ # # Makefile.defs for CLIM 2.0 # @@ -65,13 +65,12 @@ SAFETY = 1 DEBUG = 2 COMPILE_PRINT=nil -# Where to dump all clim images -DUMP-CLIM = $(TMP)/clim.temp_`whoami` -# Where images are then move to (can be same as DUMP-CLIM) -CLIM = ./slim -CLIMOL= $(CLIM) -CLIMXM= $(CLIM) +# where to dump the CLIM images +CLIM-SMALL = ./slim-small +CLIM = ./slim +CLIMOL = $(CLIM) +CLIMXM = $(CLIM) CFLAGS = -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD LDFLAGS= @@ -79,8 +78,6 @@ OLDSPACE = 15000000 NEWSPACE = 5000000 PREMALLOCS = '-m 401408' -CLIM-SMALL = ./slim-small - PUBDIRS = sys utils silica clim demo test genera clx pre-silica postscript compatibility DIRS0 = tk tk-silica misc cloe climtoys hpgl DIRS = $(PUBDIRS) xlib $(DIRS0) @@ -561,7 +558,7 @@ make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \ RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \ LOAD_XREF_INFO=${LOAD_XREF_INFO} \ RECORD_XREF_INFO=${RECORD_XREF_INFO} CL=${CL} \ - CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} DUMP-CLIM=${DUMP-CLIM} \ + CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} \ COMPILE_PRINT=${COMPILE_PRINT} TMP=${TMP} -f ${Makefile} CLIM1COMPAT= compatibility/packages.fasl compatibility/clim1-compatibility.fasl diff --git a/Makefile.generic b/Makefile.generic index e78d53d3..91913c2b 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.generic,v 1.20 1993/09/17 06:34:09 duane Exp $ +# $fiHeader: Makefile.generic,v 1.23 1993/11/24 03:56:46 duane Exp $ # # Makefile.generic for CLIM 2.0 # @@ -87,7 +87,7 @@ climgg.fasl : $(GENERIC-GADGETS) ls -lt climgg.fasl -climxm.fasl : $(MOTIF-OBJS) $(XLIB-CLIM-OBJS) +climxm.fasl : $(MOTIF-OBJS) $(CAT) $(MOTIF-OBJS) > $(TMP)/clim.fasl_`whoami` $(MV) $(TMP)/clim.fasl_`whoami` climxm.fasl ls -lt climxm.fasl >> Clim-sizes.n @@ -151,9 +151,9 @@ clim-xm: FORCE $(MOTIF_OBJS) (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \ (load \"misc/dev-load-1.lisp\") \ (load-it 'motif-clim) \ - (setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \ + (setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error - $(MV) $(DUMP-CLIM) $(CLIMXM) + $(MV) $(TMP)/clim.temp_`whoami` $(CLIMXM) ls -lLt $(CLIMXM) >> Clim-sizes.n size $(CLIMXM) >> Clim-sizes.n ls -lLt $(CLIMXM) @@ -167,9 +167,9 @@ clim-ol: FORCE $(OPENLOOK_OBJS) (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (load \"misc/dev-load-1.lisp\") \ (load-it 'openlook-clim) \ - (setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \ + (setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error - $(MV) $(DUMP-CLIM) $(CLIMOL) + $(MV) $(TMP)/clim.temp_`whoami` $(CLIMOL) ls -lLt $(CLIMOL) >> Clim-sizes.n size $(CLIMOL) >> Clim-sizes.n ls -lLt $(CLIMOL) @@ -178,9 +178,9 @@ clim-ol: FORCE $(OPENLOOK_OBJS) clim-small: FORCE $(ECHO) " \ (load \"misc/load-xm.lisp\") \ - (setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \ + (setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error - $(MV) $(DUMP-CLIM) $(CLIM-SMALL) + $(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL) ls -lt $(CLIM-SMALL) >> Clim-sizes.n size $(CLIM-SMALL) >> Clim-sizes.n ls -lt $(CLIM-SMALL) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 03a04704..d27e9d28 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.72 1993/11/18 18:44:04 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.73 1993/11/23 19:58:34 cer Exp $ (in-package :clim-internals) @@ -335,6 +335,7 @@ ;; So the continuation can run with the proper value of *APPLICATION-FRAME* (defvar *avv-calling-frame*) + (defun invoke-accepting-values (stream continuation &key frame-class command-table own-window background diff --git a/clim/accept.lisp b/clim/accept.lisp index bf1850ad..279da209 100644 --- a/clim/accept.lisp +++ b/clim/accept.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept.lisp,v 1.24 1993/06/02 18:40:25 cer Exp $ +;; $fiHeader: accept.lisp,v 1.25 1993/07/27 01:38:16 colin Exp $ (in-package :clim-internals) @@ -180,12 +180,14 @@ (let ((start-position (stream-scan-pointer stream))) (with-input-context (type) (object presentation-type nil options) - (with-activation-gestures ((or activation-gestures - additional-activation-gestures - *standard-activation-gestures*) + (with-activation-gestures ((if activation-gestures-p + activation-gestures + (or additional-activation-gestures + *standard-activation-gestures*)) :override activation-gestures-p) - (with-delimiter-gestures ((or delimiter-gestures - additional-delimiter-gestures) + (with-delimiter-gestures ((if delimiter-gestures-p + delimiter-gestures + additional-delimiter-gestures) :override delimiter-gestures-p) (handler-bind ((parse-error @@ -333,12 +335,14 @@ (let ((index start)) (multiple-value-bind (the-object the-type) (with-input-from-string (stream string :start start :end end :index index) - (with-activation-gestures ((or activation-gestures - additional-activation-gestures - *standard-activation-gestures*) + (with-activation-gestures ((if activation-gestures-p + activation-gestures + (or additional-activation-gestures + *standard-activation-gestures*)) :override activation-gestures-p) - (with-delimiter-gestures ((or delimiter-gestures - additional-delimiter-gestures) + (with-delimiter-gestures ((if delimiter-gestures-p + delimiter-gestures + additional-delimiter-gestures) :override delimiter-gestures-p) (handler-bind ((parse-error diff --git a/clim/frames.lisp b/clim/frames.lisp index 944ecf90..4a0bfae6 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.74 1993/09/22 21:21:08 cer Exp $ +;; $fiHeader: frames.lisp,v 1.75 1993/11/18 18:44:17 cer Exp $ (in-package :clim-internals) @@ -570,15 +570,18 @@ (setf (sheet-enabled-p sheets) nil) (sheet-adopt-child (frame-top-level-sheet frame) sheets) (multiple-value-call #'layout-frame - frame (bounding-rectangle-size (frame-top-level-sheet frame))) + frame + (if (frame-resizable frame) + (values) + (bounding-rectangle-size (frame-top-level-sheet frame)))) ;;--- Don't throw, just recompute stream bindings in a principled way (setf (sheet-enabled-p sheets) t)) - (note-frame-current-layout-changed (frame-manager frame) frame) + (note-frame-layout-changed (frame-manager frame) frame) (handler-case (throw 'layout-changed nil) (error () nil)))) -(defmethod note-frame-current-layout-changed ((frame-manager standard-frame-manager) (frame t)) +(defmethod note-frame-layout-changed ((frame-manager standard-frame-manager) (frame t)) nil) (defun adjust-layout-requirements (frame layout) @@ -705,10 +708,10 @@ (error "Cannot enable a disowned frame ~S" frame)) (destructuring-bind (&key left top width height &allow-other-keys) (frame-geometry frame) - (ecase (frame-state frame) - (:enabled) - ((:disabled :disowned) - (let ((old-state (frame-state frame))) + (let ((old-state (frame-state frame))) + (ecase old-state + (:enabled) + ((:disabled :disowned) (setf (frame-state frame) :enabled) ;; If this is a new frame then if the user specified a width ;; then we should be using that @@ -717,18 +720,18 @@ (multiple-value-bind (width height) (ecase old-state (:disowned - (if (and width height) - (values width height) - (values))) + (if (and width height) + (values width height) + (values))) (:disabled - (bounding-rectangle-size - (frame-top-level-sheet frame)))) + (bounding-rectangle-size + (frame-top-level-sheet frame)))) (layout-frame frame width height) (when (and left top) (move-sheet (frame-top-level-sheet frame) left top)) - (note-frame-enabled (frame-manager frame) frame)))) - (:shrunk - (note-frame-deiconified (frame-manager frame) frame))))) + (note-frame-enabled (frame-manager frame) frame))) + (:shrunk + (note-frame-deiconified (frame-manager frame) frame)))))) (defmethod shrink-frame ((frame standard-application-frame)) (note-frame-iconified (frame-manager frame) frame)) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 8769d844..11d1cdfc 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.54 1993/10/25 16:15:26 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.55 1993/11/18 18:44:20 cer Exp $ (in-package :clim-internals) @@ -700,8 +700,12 @@ (accept-values-query-valid-p query (accept-values-query-presentation query))) (handler-case - (multiple-value-bind (object type index) - (accept-from-string (accept-values-query-type query) new-value) + (multiple-value-bind (object type index) + ;; we specify :activation-gestures nil so that we can + ;; accept multi-line strings in text-editors (cim) + (accept-from-string (accept-values-query-type query) + new-value + :activation-gestures nil) (declare (ignore type)) (assert (= index (length new-value))) object) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 2eac19ed..687e15cf 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.29 1993/05/25 20:41:05 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.30 1993/09/17 19:05:26 cer Exp $ (in-package :clim-internals) @@ -1463,10 +1463,11 @@ (when (input-editing-stream-p stream) (rescan-if-necessary stream)) (multiple-value-bind (expression index) - (read-from-string string nil string) - (when (eq expression string) - (simple-parse-error "The input ~S is not a complete Lisp expression." - (evacuate-temporary-string string))) + (handler-case + (read-from-string string) + (error () + (simple-parse-error "The input ~S is not a complete Lisp expression." + (evacuate-temporary-string string)))) ;; Too bad READ-FROM-STRING doesn't take a :JUNK-ALLOWED argument. ;; Simulate what it would do (unless (>= index (length string)) @@ -1513,57 +1514,57 @@ (#\" . #\") (#\| . #\|))) - ;;; Ignore issues like comments for now. (defun read-recursive (stream input-buffer desired-delimiter &key auto-activate) - (unless auto-activate - (setq desired-delimiter nil)) - (loop - (with-input-context ('expression) - (object type) - (let ((char (read-char stream (not auto-activate) :eof)) - (other-delimiter nil)) - (cond ((eq char :eof) - ;;-- what is the right thing? - (return)) - ((and (activation-gesture-p char) (not desired-delimiter)) - (unread-char char stream) - (return)) - ((and (delimiter-gesture-p char) (not desired-delimiter) - auto-activate) - (beep stream)) - ((and (delimiter-gesture-p char) (not desired-delimiter) - (not auto-activate)) - (unread-char char stream) - (return)) - ((not (or (ordinary-char-p char) - (diacritic-char-p char))) - (beep stream)) - ((and (zerop (fill-pointer input-buffer)) ;ignore leading space - (whitespace-char-p char))) - ((char-equal char #\\) ;check for quoting character - (vector-push-extend char input-buffer) - (let ((char (read-char stream))) - (vector-push-extend char input-buffer))) - (t - (when (activation-gesture-p char) - ;; I guess it wasn't really an activation gesture... - (unless (stream-rescanning-p stream) - (replace-input stream (string char)))) - (vector-push-extend char input-buffer) - (cond ((and desired-delimiter - (char-equal char desired-delimiter)) - (return)) - ((setq other-delimiter (cdr (assoc char *char-associations*))) - (read-recursive stream input-buffer other-delimiter - :auto-activate auto-activate) - (unless desired-delimiter (return))) - ((and (whitespace-char-p char) (not desired-delimiter) - auto-activate) - (unread-char char stream) - (return)) - (t nil))))) - (t + (let ((top-level (not desired-delimiter))) + (loop + (with-input-context ('expression) + (object type) + (let ((char (read-char stream nil :eof))) + (cond ((eq char :eof) + (return)) + + ;; ignore leading space + ((and (zerop (fill-pointer input-buffer)) + (whitespace-char-p char))) + + ;; terminate with white space when at top level with auto-activate + ((and top-level + auto-activate + (whitespace-char-p char)) + (unread-char char stream) + (return)) + + ;; ALWAYS terminate with delimiter or activation gesture + ((or (activation-gesture-p char) + (delimiter-gesture-p char)) + (unread-char char stream) + (return)) + + ((not (or (ordinary-char-p char) + (diacritic-char-p char))) + (beep stream)) + + ((char-equal char #\\) ;check for quoting character + (vector-push-extend char input-buffer) + (let ((escaped-char (read-char stream nil))) + (when escaped-char + (vector-push-extend escaped-char input-buffer)))) + + (t + (vector-push-extend char input-buffer) + + (if (and desired-delimiter + (char-equal char desired-delimiter)) + (return) + (let ((other-delimiter (cdr (assoc char *char-associations*)))) + (when other-delimiter + (read-recursive stream input-buffer other-delimiter + :auto-activate auto-activate) + (when (and top-level + auto-activate) + (return)))))))) + (t ;; Put this thing into the input editor's buffer (when (input-editing-stream-p stream) (presentation-replace-input stream object type +textual-view+)) @@ -1571,9 +1572,11 @@ (let ((n (length *read-recursive-objects*))) (setq *read-recursive-objects* (nconc *read-recursive-objects* (list object))) (doseq (char (format nil " #.(~S ~D ~S) " - 'nth n '*read-recursive-objects*)) - (vector-push-extend char input-buffer))) - (unless desired-delimiter (return)))))) + 'nth n '*read-recursive-objects*)) + (vector-push-extend char input-buffer))) + (when (and top-level + auto-activate) + (return))))))) (defun print-recursive (object stream &key (make-presentation t) diff --git a/clim/stream-class-defs.lisp b/clim/stream-class-defs.lisp index f8e4b4d8..5dce0163 100644 --- a/clim/stream-class-defs.lisp +++ b/clim/stream-class-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: stream-class-defs.lisp,v 1.12 93/01/21 14:58:17 cer Exp $ +;; $fiHeader: stream-class-defs.lisp,v 1.13 1993/07/27 01:41:10 colin Exp $ (in-package :clim-internals) @@ -76,7 +76,12 @@ :initarg :excl-recording-p)) (:default-initargs :draw-p t :record-p t ;!!! - :output-record (make-instance 'standard-tree-output-history))) + :output-record + ;; this used to be standard-tree-output-history + ;; but because of longstanding bugs in + ;; coordinate sorted sets, we should avoid this + ;; for the default (cim 11/30/93) + (make-instance 'standard-sequence-output-history))) ;; For any window-specific output recording methods diff --git a/demo/ico.lisp b/demo/ico.lisp index bf6330e6..c55c9cf8 100644 --- a/demo/ico.lisp +++ b/demo/ico.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ico.lisp,v 1.19 1993/09/17 00:20:37 colin Exp $ +;; $fiHeader: ico.lisp,v 1.21 1993/11/24 03:56:55 duane Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -353,7 +353,6 @@ (clim-utils:with-collection (dotimes (i nv) (clim-utils:collect (list (make-ico-point 0 0) 0)))))) -#-allegro (defparameter v2-fill (make-array (* nv 2) :displaced-to v2)) (defparameter drawn (make-array (list nv nv) :initial-element nil)) diff --git a/silica/layout.lisp b/silica/layout.lisp index da96c04e..dd1fd824 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: layout.lisp,v 1.31 1993/06/02 18:41:53 cer Exp $ +;; $fiHeader: layout.lisp,v 1.32 1993/06/21 20:51:19 cer Exp $ (in-package :silica) @@ -145,25 +145,24 @@ (unless (and (> width 0) (> height 0)) (error "Trying to resize sheet ~S to be too small (~D x ~D)" sheet width height)) - (when (or width height) - (with-bounding-rectangle* (left top right bottom) sheet - (let ((owidth (- right left)) - (oheight (- bottom top))) - (if (or (and width (/= owidth width)) - (and height (/= oheight height)) - #+Allegro - (mirror-needs-resizing-p sheet width height)) - ;; It should be safe to modify the sheet's region, since - ;; each sheet gets a fresh region when it is created - (let ((region (sheet-region sheet))) - (setf (slot-value region 'left) left - (slot-value region 'top) top - (slot-value region 'right) (if width (+ left width) right) - (slot-value region 'bottom) (if height (+ top height) bottom)) - (note-sheet-region-changed sheet)) - ;;--- Do this so that we relayout the rest of tree. - ;;--- I guess we do not want to do this always but ... - (allocate-space sheet owidth oheight)))))) + (with-bounding-rectangle* (left top right bottom) sheet + (let ((owidth (- right left)) + (oheight (- bottom top))) + (if (or (/= owidth width) + (/= oheight height) + #+Allegro + (mirror-needs-resizing-p sheet width height)) + ;; It should be safe to modify the sheet's region, since + ;; each sheet gets a fresh region when it is created + (let ((region (sheet-region sheet))) + (setf (slot-value region 'left) left + (slot-value region 'top) top + (slot-value region 'right) (+ left width) + (slot-value region 'bottom) (+ top height)) + (note-sheet-region-changed sheet)) + ;;--- Do this so that we relayout the rest of tree. + ;;--- I guess we do not want to do this always but ... + (allocate-space sheet owidth oheight))))) ;;;-- This sucks but it seems to get round the problem of the mirror ;;;-- geometry being completely wrong after the layout has been changed diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 5cd552dd..5c8e9ad6 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: mirror.lisp,v 1.32 1993/07/27 01:50:57 colin Exp $ +;; $fiHeader: mirror.lisp,v 1.33 1993/09/17 19:06:18 cer Exp $ (in-package :silica) @@ -41,7 +41,11 @@ ;;; Native transformation +;;--- I'm sure that this is wrong so I'm commented it out - if nothing +;;breaks in six months time then remove it (cim 11/1/93) + ;;--- This should be cached so that it doesn't cons... +#+ignore (defmethod sheet-native-transformation ((sheet basic-sheet)) (compose-transformations (sheet-transformation sheet) @@ -68,7 +72,7 @@ (defmethod sheet-device-transformation :around ((sheet mirrored-sheet-mixin)) (if (sheet-direct-mirror sheet) (sheet-native-transformation sheet) - (call-next-method))) + (call-next-method))) ;;; Native region diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index efde038c..64b76200 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.62 1993/10/26 03:22:43 colin Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.63 1993/11/18 18:45:32 cer Exp $ (in-package :xm-silica) @@ -1412,28 +1412,28 @@ sheet)))) -;;--- this is almost identical to the motif code +;;--- this is identical to the motif code (defmethod initialize-instance :after ((sp openlook-scrolling-window) - &key scroll-bars contents frame-manager frame) - #-bad-hack (declare (ignore scroll-bars)) + &key scroll-bars contents frame-manager frame) (if (setf (scroller-pane-gadget-supplies-scrolling-p sp) - (gadget-supplies-scrolling-p contents)) + (gadget-supplies-scrolling-p contents)) (sheet-adopt-child sp contents) (with-look-and-feel-realization (frame-manager frame) - (let ((sb (make-pane 'scroll-bar - :enabled (and (member scroll-bars '(:both t dynamic :vertical)) - t) - :orientation :vertical :id :vertical :client sp))) - (setf (scroller-pane-vertical-scroll-bar sp) sb) - (sheet-adopt-child sp sb)) - (let ((sb (make-pane 'scroll-bar - :enabled (and (member scroll-bars '(t :both :dynamic :horizontal)) - t) - :orientation :horizontal :id :horizontal :client sp))) - (setf (scroller-pane-horizontal-scroll-bar sp) sb) - (sheet-adopt-child sp sb)) - (sheet-adopt-child sp (setf (slot-value sp 'viewport) (make-pane 'viewport :scroller-pane sp))) + (when (member scroll-bars '(t :both :dynamic :vertical)) + (let ((sb (make-pane 'scroll-bar + :orientation :vertical :id :vertical + :client sp))) + (setf (scroller-pane-vertical-scroll-bar sp) sb) + (sheet-adopt-child sp sb))) + (when (member scroll-bars '(t :both :dynamic :horizontal)) + (let ((sb (make-pane 'scroll-bar + :orientation :horizontal :id :horizontal + :client sp))) + (setf (scroller-pane-horizontal-scroll-bar sp) sb) + (sheet-adopt-child sp sb))) + (sheet-adopt-child sp (setf (slot-value sp 'viewport) + (make-pane 'viewport :scroller-pane sp))) (sheet-adopt-child (slot-value sp 'viewport) contents)))) (defmethod realize-widget-mirror ((port openlook-port) (parent-sheet openlook-scrolling-window) @@ -1476,7 +1476,7 @@ ;;--- bigger than this. But atleast its a start ;;-- We check to see which scrollbars we have - (let* ((fudge 7) ; This was from trial and + (let* ((fudge 8) ; This was from trial and ; error but at least 4 (1point) is from ; the contents border (spacing (+ fudge 0) #+ignore (tk::get-values (sheet-mirror fr) :spacing)) @@ -1518,7 +1518,7 @@ (multiple-value-bind (swidth sheight) (tk::get-values (sheet-direct-mirror scrolling-window) :width :height) - (let* ((fudge 7) + (let* ((fudge 8) (vsbp (let ((sb (scroller-pane-vertical-scroll-bar scrolling-window))) (and sb (sheet-enabled-p sb)))) @@ -1557,9 +1557,8 @@ ,(and (member scroll-bars '(t :both :dynamic :horizontal)) t))) `(:h-auto-scroll nil - :v-auto-scroll nil - :compute-geometries ,*scrolling-window-geometry-function-address* - ))))) + :v-auto-scroll nil + :compute-geometries ,*scrolling-window-geometry-function-address*))))) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 0f407d27..c1caa86f 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.21 1993/07/27 01:55:11 colin Exp $ +;; $fiHeader: ol-silica.lisp,v 1.22 1993/09/17 19:07:04 cer Exp $ (in-package :xm-silica) @@ -110,3 +110,23 @@ (defun ol-get-focus-widget (widget) (tk::intern-widget (tk::ol_get_current_focus_widget widget))) + +(defmethod process-an-event ((port ol-port) mask reason) + (with-slots (context) port + ;; Because of a feature in the OLIT toolkit we need to + ;; give preference to events rather than timer events + + #+debug + (when (logtest mask tk::*xt-im-xevent*) + (let ((event (x11:make-xevent))) + (unless (zerop (tk::xt_app_peek_event context event)) + (print (tk::event-type event) excl:*initial-terminal-io*)))) + + (tk::process-one-event context + (if (logtest mask tk::*xt-im-xevent*) + tk::*xt-im-xevent* + mask) + reason))) + + + diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index a57b925b..f5f180e9 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.64 1993/10/26 03:22:47 colin Exp $ +;; $fiHeader: xm-frames.lisp,v 1.65 1993/11/18 18:45:35 cer Exp $ (in-package :xm-silica) @@ -50,7 +50,7 @@ ;;-- Conversely querygeoetry will return bogus results otherwise. (frobulate-menubars frame)) -(defmethod clim-internals::note-frame-current-layout-changed ((frame-manager motif-frame-manager) (frame t)) +(defmethod note-frame-layout-changed ((frame-manager motif-frame-manager) (frame t)) (frobulate-menubars frame)) (defun frobulate-menubars (frame) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index d5178105..a5d822e0 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.84 1993/10/26 03:22:51 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.85 1993/11/18 18:45:37 cer Exp $ (in-package :xm-silica) @@ -1678,26 +1678,25 @@ (defmethod initialize-instance :after ((sp motif-scroller-pane) &key scroll-bars contents - frame-manager frame) + frame-manager frame) (if (setf (scroller-pane-gadget-supplies-scrolling-p sp) (gadget-supplies-scrolling-p contents)) (sheet-adopt-child sp contents) (with-look-and-feel-realization (frame-manager frame) (when (member scroll-bars '(t :both :dynamic :vertical)) - (let ((sb (make-pane 'scroll-bar - :orientation :vertical :id :vertical - :client sp))) - (setf (scroller-pane-vertical-scroll-bar sp) sb) - (sheet-adopt-child sp sb))) + (let ((sb (make-pane 'scroll-bar + :orientation :vertical :id :vertical + :client sp))) + (setf (scroller-pane-vertical-scroll-bar sp) sb) + (sheet-adopt-child sp sb))) (when (member scroll-bars '(t :both :dynamic :horizontal)) - (let ((sb (make-pane 'scroll-bar - :orientation :horizontal :id :horizontal - :client sp))) - (setf (scroller-pane-horizontal-scroll-bar sp) sb) - (sheet-adopt-child sp sb))) - (sheet-adopt-child sp (setf (slot-value sp 'viewport) - (make-pane 'viewport - :scroller-pane sp))) + (let ((sb (make-pane 'scroll-bar + :orientation :horizontal :id :horizontal + :client sp))) + (setf (scroller-pane-horizontal-scroll-bar sp) sb) + (sheet-adopt-child sp sb))) + (sheet-adopt-child sp (setf (slot-value sp 'viewport) + (make-pane 'viewport :scroller-pane sp))) (sheet-adopt-child (slot-value sp 'viewport) contents)))) (defmethod gadget-supplies-scrolling-p ((sheet t)) nil) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 3723c1e5..fbb8cf61 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.40 1993/11/18 18:45:40 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.41 1993/11/23 19:59:07 cer Exp $ (in-package :xm-silica) @@ -139,12 +139,13 @@ (widget (sheet-mirror sheet))) (when cursor (let ((input-widget (make-instance 'tk::xm-my-drawing-area - :parent widget - :background (tk::get-values widget - :background) - :width 1 - :height 1 - :managed (cursor-active cursor)))) + :name :xm-cursor + :parent widget + :background (tk::get-values widget + :background) + :width 1 + :height 1 + :managed (cursor-active cursor)))) (with-slots (clim-internals::plist) cursor (setf (getf clim-internals::plist :input-widget) input-widget) (tk::add-callback input-widget diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp index eb9d5dd2..34c8cf65 100644 --- a/tk-silica/xt-pixmaps.lisp +++ b/tk-silica/xt-pixmaps.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-pixmaps.lisp,v 1.17 1993/07/27 01:55:53 colin Exp $ +;; $fiHeader: xt-pixmaps.lisp,v 1.18 1993/11/18 18:45:45 cer Exp $ (in-package :xm-silica) @@ -67,9 +67,8 @@ ((from-medium xt-medium) from-x from-y width height (to-medium xt-medium) to-x to-y &optional (function boole-1)) - ;;--- Shouldn't this be the sheet-device-transformation???? - (let ((from-transform (sheet-native-transformation (medium-sheet from-medium))) - (to-transform (sheet-native-transformation (medium-sheet to-medium)))) + (let ((from-transform (sheet-device-transformation (medium-sheet from-medium))) + (to-transform (sheet-device-transformation (medium-sheet to-medium)))) (convert-to-device-coordinates from-transform from-x from-y) (convert-to-device-coordinates to-transform to-x to-y) (convert-to-device-distances from-transform width height) @@ -116,7 +115,7 @@ (allocate-event 'window-repaint-event :native-region (make-bounding-rectangle minx miny maxx maxy) :region (untransform-region - (sheet-native-transformation sheet) + (sheet-device-transformation sheet) (make-bounding-rectangle minx miny maxx maxy)) :sheet sheet)))) (setq event (tk::get-event-matching-sequence-and-types @@ -131,7 +130,7 @@ (to-medium xt-medium) to-x to-y &optional (function boole-1)) ;;-- What about the graphics exposure event problem - (let ((transform (sheet-native-transformation (medium-sheet to-medium)))) + (let ((transform (sheet-device-transformation (medium-sheet to-medium)))) (convert-to-device-coordinates transform to-x to-y) (convert-to-device-distances transform width height) (fix-coordinates from-x from-y) @@ -149,7 +148,7 @@ (pixmap xt-pixmap) to-x to-y &optional (function boole-1)) ;;-- What about the graphics exposure event problem - (let ((transform (sheet-native-transformation (medium-sheet from-medium)))) + (let ((transform (sheet-device-transformation (medium-sheet from-medium)))) (convert-to-device-coordinates transform from-x from-y) (convert-to-device-distances transform width height) (fix-coordinates to-x to-y) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index f9ea2fef..30047b45 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.91 1993/10/26 03:22:58 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.92 1993/11/18 18:45:48 cer Exp $ (in-package :xm-silica) @@ -665,7 +665,10 @@ (sheet-mirror-for-parenting ma)))) (defmethod sheet-mirror-for-parenting ((sheet basic-sheet)) - ;; There might be a situation where a sheet is mirrored by a whil + ;; There might be a situation where a sheet is mirrored by a tree of + ;; children. Here you would want the mirror for parenting to be a leaf + ;; rather than the root of the tree. For the moment a sheet is only + ;; mirrored by one widget so the following is ok (sheet-mirror sheet)) (defmethod find-shell-of-calling-frame ((sheet basic-sheet)) @@ -679,16 +682,11 @@ (sheet-shell cf)))) (defmethod find-shell-parent ((port xt-port) sheet) - (or - (and - ;;--- hack alert - ;;**** Not needed any more [clim2bug462] - ;; (popup-frame-p sheet) - (let ((shell (find-shell-of-calling-frame sheet))) - (and shell - (eq (xt::widget-display shell) (port-display port)) - shell))) - (port-application-shell port))) + (let ((shell (find-shell-of-calling-frame sheet))) + (if (and shell + (eq (xt::widget-display shell) (port-display port))) + shell + (port-application-shell port)))) (defmethod find-shell-class-and-initargs ((port xt-port) (sheet t)) (values 'top-level-shell @@ -864,7 +862,11 @@ (tk::wait-for-event context :wait-function wait-function :timeout 0)) - (tk::process-one-event context mask reason)))))) + (process-an-event port mask reason)))))) + +(defmethod process-an-event ((port xt-port) mask reason) + (with-slots (context) port + (tk::process-one-event context mask reason))) (defmethod port-glyph-for-character ((port xt-port) character text-style @@ -1077,7 +1079,12 @@ ;; Other useful characters (define-xt-keysym (keysym 255 #x6a) :help) + +;; we have two keysyms for :end - XK_End and XK_R13 (which is marked +;; end on certain sun keyboards) + (define-xt-keysym (keysym 255 #xde) :end) +(define-xt-keysym (keysym 255 #x57) :end) (define-xt-keysym (keysym 255 #x68) :complete) ; Not on my keyboard (define-xt-keysym (keysym 255 #x69) :abort) ; Not on my keyboard diff --git a/tk/event.lisp b/tk/event.lisp index 7aa7dcb8..22cc2507 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.22 1993/11/18 18:45:25 cer Exp $ +;; $fiHeader: event.lisp,v 1.23 1993/11/23 19:58:55 cer Exp $ (in-package :tk) @@ -55,19 +55,17 @@ (let* ((mask 0) (fds (mapcar #'(lambda (display) (x11::display-fd display)) (application-context-displays context))) - result (reason nil)) (declare (fixnum mask)) (flet ((wait-function (fd) (declare (ignore fd)) (let ((*inside-event-wait-function* fds)) - (setq result - (catch *inside-event-wait-function* - (or (plusp (setq mask (xt_app_pending context))) - (and wait-function - (funcall wait-function) - (setq reason :wait)))))))) + (catch *inside-event-wait-function* + (or (plusp (setq mask (xt_app_pending context))) + (and wait-function + (funcall wait-function) + (setq reason :wait))))))) (let* ((interval (xt_app_interval_next_timer context)) (new-timeout (if (plusp interval) @@ -86,18 +84,7 @@ (defun process-one-event (context mask reason) (cond ((plusp mask) - - #+debug - (when (logtest mask *xt-im-xevent*) - (let ((event (x11:make-xevent))) - (unless (zerop (xt_app_peek_event context event)) - (print (event-type event) excl:*initial-terminal-io*)))) - - (xt_app_process_event - context - ;; Because of a feature in the OLIT toolkit we need to - ;; give preference to events rather than timer events - (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask)) + (xt_app_process_event context mask) t) (reason :wait-function) (t :timeout))) diff --git a/utils/packages.lisp b/utils/packages.lisp index 324bc822..475326a8 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.60 1993/09/22 18:26:58 layer Exp $ +;; $fiHeader: packages.lisp,v 1.61 1993/11/18 18:45:55 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2741,6 +2741,7 @@ note-frame-disabled note-frame-enabled note-frame-iconified + note-frame-layout-changed notify-user pane-frame pane-name -- GitLab