diff --git a/Makefile b/Makefile index 579b8d2f2c94c72f17f5e3b4e090c16c779e10f0..b02c657c69702d35cd102d6b8bad9c343659ec93 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,9 @@ -# $fiHeader: Makefile,v 1.44 92/08/21 16:34:13 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.45 92/09/08 10:35:20 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # -CL = /usr/tech/cer/cl/src/dcl +#CL = /usr/tech/cer/cl/src/dcl +CL = /net/vapor/scm2/4.2.beta/src/dcl-stable PWD = /usr/tech/cer/stuff/clim-2.0 DUMP-CL = $(CL) CLOPTS = -qq @@ -73,6 +74,7 @@ OPENWINHOME=/usr/openwin-3.0 DEBUGLIB= MOTIFLIB=/x11/R4/sun4-lib/libXm$(DEBUGLIB).a +MOTIFLIB_d=/x11/R4/sun4-lib/libXm_d.a XLIB= /x11/R4/sun4-lib/libX11$(DEBUGLIB).a XTLIB=/x11/R4/sun4-lib/libXt$(DEBUGLIB).a XLIBS= $(XTLIB) $(XLIB) @@ -80,6 +82,7 @@ XLIBS= $(XTLIB) $(XLIB) OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2 OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a LIBXOL=$(OLCOPYLIB)/libXol.a +LIBXOL_d=$(OLCOPYLIB)/libXol.a # This has to be kept consistent with xlib.lisp UNDEFS=misc/undefinedsymbols @@ -94,11 +97,14 @@ XM_UNDEFS=misc/undefinedsymbols.motif OL_UNDEFS=misc/undefinedsymbols.olit CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl climps.fasl -CLIMOBJS= clim-motif.o clim-olit.o stub-xt.o stub-x.o xlibsupport.o MyDrawingA.o \ +CLIMOBJS= clim-motif_d.o clim-olit_d.o clim-motif.o clim-olit.o stub-xt.o stub-x.o \ + xlibsupport.o MyDrawingA.o \ olsupport.o xtsupport.o # These are linked into the distribution -FCLIMOBJS= `pwd`/clim-motif.o `pwd`/clim-olit.o `pwd`/stub-xt.o `pwd`/stub-x.o \ +FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-olit_d.o \ + `pwd`/clim-motif.o `pwd`/clim-olit.o \ + `pwd`/stub-xt.o `pwd`/stub-x.o \ `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o `pwd`/xtsupport.o # These are built into xm-dcl and ol-dcl. @@ -223,6 +229,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/basic-translators.fasl \ clim/frames.fasl \ clim/default-frame.fasl \ + clim/activities.fasl \ clim/noting-progress.fasl \ clim/menus.fasl \ clim/accept-values.fasl \ @@ -487,6 +494,9 @@ compile-xm: $(CLIMOBJS) FORCE (setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \ (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \ + (setq sys::*libxt-pathname* \"$(XTLIB)\") \ + (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \ (load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch echo CLIM-XM compiled!!!! @@ -496,6 +506,9 @@ compile-ol: $(CLIMOBJS) FORCE (setf excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \ (setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \ (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ + (setq sys::*libxt-pathname* \"$(XTLIB)\") \ + (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \ @@ -549,9 +562,12 @@ tk/xm-defs.fasl : tk/xm-defs.lisp # Building -clim-xm: FORCE +clim-xm: FORCE $(CLIMOBJS) # -$(RM) $(CLIM) $(ECHO) " \ + (setq sys::*libxt-pathname* \"$(XTLIB)\") \ + (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \ (load \"misc/dev-load-xm.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) @@ -563,6 +579,9 @@ clim-xm: FORCE clim-ol: FORCE # -$(RM) $(CLIM) $(ECHO) " \ + (setq sys::*libxt-pathname* \"$(XTLIB)\") \ + (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (load \"misc/dev-load-ol.lisp\") \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) @@ -585,15 +604,26 @@ clim-small: FORCE train : FORCE $(TRAIN_TEXT) +BENCHMARK_FILE=nil + +benchmark: + $(ECHO) "\ + (load \"tk-silica/test-clim.lisp\") \ + (clim-user::benchmark-clim $(BENCHMARK_FILE)) \ +" | $(CLIM) $(CLOPTS) -batch + echo-train: -$(ECHO) "$(TRAIN_LISP)" # Misc +cleanobjs: + rm -f $(CLIMOBJS) stub-motif.o stub-olit.o + clean: find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \ - $(CLIMOBJS) slim slim-small +l $(CLIMOBJS) slim slim-small cheapclean: @@ -663,6 +693,13 @@ clim-motif.o : stub-motif.o clim-olit.o : stub-olit.o ld -r -o clim-olit.o stub-olit.o $(LIBXOL) +clim-motif_d.o : stub-motif.o + ld -r -o clim-motif_d.o stub-motif.o $(MOTIFLIB_d) + +clim-olit_d.o : stub-olit.o + ld -r -o clim-olit_d.o stub-olit.o $(LIBXOL_d) + + stub-motif.c : $(XT_UNDEFS) $(XM_UNDEFS) misc/make-stub-file misc/make-stub-file "void ___lisp_load_motif_stub ()" $(XT_UNDEFS) $(XM_UNDEFS) > stub-motif.c diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 75134b52c3d7f1595d289e313d9887311cf8a75a..0fc07489b017b0f5c9716d201c12df31aa9ca852 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.32 92/09/08 10:34:36 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.33 92/09/08 15:17:23 cer Exp Locker: cer $ (in-package :clim-internals) @@ -1198,7 +1198,11 @@ :documentation documentation :resynchronize resynchronize))) (make-pane 'push-button - :label prompt + :label (if (stringp prompt) + stream + ;;--- Perhaps we should create a pixmap + (with-output-to-string (stream) + (funcall prompt stream))) :id record :client client :activate-callback #'(lambda (button) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index b76754beb286252342e7c3e1fa0d7c6fc94080be..f894964ecb37b7818181cabb1c5461b4e1ca42a5 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.28 92/09/08 10:34:41 cer Exp Locker: cer $ +;; $fiHeader: db-stream.lisp,v 1.29 92/09/08 15:17:39 cer Exp Locker: cer $ (in-package :clim-internals) @@ -321,10 +321,10 @@ ,pane))) (when label (setq pane `(vertically () - ,pane - (make-pane 'label-pane + (make-pane 'label-pane :label ,label - :max-width +fill+)))) + :max-width +fill+) + ,pane))) `(let (,stream) (values (outlining (:thickness 1) diff --git a/clim/frames.lisp b/clim/frames.lisp index 188dbabb2e4f2c5ad894dbf61e0119cb44fb723b..b383764e90c4f1e7f129c1988532923df47f46c5 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.39 92/09/08 10:34:45 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $ (in-package :clim-internals) @@ -54,7 +54,9 @@ :reader frame-resizable) (layout :initarg :layouts :reader frame-layouts) (top-level-process :initform nil) - (command-queue :initform (make-locking-queue) :reader frame-command-queue)) + (command-queue :initform (make-locking-queue) :reader + frame-command-queue) + (input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer)) (:default-initargs :pointer-documentation nil :layouts nil :resize-frame nil @@ -625,6 +627,8 @@ (destructuring-bind (&key left top width height &allow-other-keys) (frame-geometry frame) (ecase (frame-state frame) + (:shrunk + (note-frame-deiconified (frame-manager frame) frame)) (:enabled) ((:disabled :disowned) (let ((old (frame-state frame))) @@ -647,6 +651,9 @@ (move-sheet (frame-top-level-sheet frame) left top)) (note-frame-enabled (frame-manager frame) frame))))))) +(defmethod iconify-frame ((frame standard-application-frame)) + (note-frame-iconified (frame-manager frame) frame)) + (defmethod destroy-frame ((frame standard-application-frame)) (when (eq (frame-state frame) :enabled) (disable-frame frame)) @@ -1035,14 +1042,17 @@ (synchronous-command-event-command condition))))) ) ;eval-when +(defvar *reading-frame-command* nil) + (defmethod read-frame-command :around ((frame standard-application-frame) &key) (let* ((command (queue-pop (frame-command-queue frame)))) (or command (handler-bind ((synchronous-command-event - #'(lambda (c) - (return-from read-frame-command - (synchronous-command-event-command c))))) - (call-next-method))))) + #'(lambda (c) + (return-from read-frame-command + (synchronous-command-event-command c))))) + (let ((*reading-frame-command* t)) + (call-next-method)))))) ;;--- Actually this should be named command-event @@ -1347,4 +1357,10 @@ right right-presentation right-context))) +(defmethod raise-frame ((frame standard-application-frame)) + (raise-sheet (frame-top-level-sheet frame))) + +(defmethod bury-frame ((frame standard-application-frame)) + (bury-sheet (frame-top-level-sheet frame))) + diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index f7b6449aad53856d6e16db8fd291955e53ffeccb..53ce15f64b4ce8ee4180b6ccdf220cfc979c0724 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.26 92/09/08 10:34:47 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.27 92/09/08 15:17:46 cer Exp Locker: cer $ (in-package :clim-internals) @@ -371,23 +371,20 @@ #'(lambda (element) (let* ((value (funcall value-key element)) (button - (make-pane 'toggle-button - - :label - - (let ((name (funcall name-key element))) - (if (eq printer #'write-token) - name - (pixmap-from-menu-item stream name printer nil))) - :indicator-type (getf toggle-options :indicator-type :some-of) - :value (and default-supplied-p - (member value default - :test test - ;;--- Should the value-key be used? - :key value-key) - t) - :id value - toggle-options))) + (apply #'make-pane 'toggle-button + :label (let ((name (funcall name-key element))) + (if (eq printer #'write-token) + name + (pixmap-from-menu-item stream name printer nil))) + :indicator-type (getf toggle-options :indicator-type :some-of) + :value (and default-supplied-p + (member value default + :test test + ;;--- Should the value-key be used? + :key value-key) + t) + :id value + toggle-options))) button)) sequence)) (check-box (apply #'make-pane 'check-box diff --git a/clim/gestures.lisp b/clim/gestures.lisp index 70490d9530980719b8b11cdf609bc3619cfda4b0..ff11a9287669ead9d17599b6d822b930c4583b40 100644 --- a/clim/gestures.lisp +++ b/clim/gestures.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gestures.lisp,v 1.11 92/08/18 17:24:57 cer Exp $ +;; $fiHeader: gestures.lisp,v 1.12 92/09/08 15:17:48 cer Exp Locker: cer $ (in-package :clim-internals) @@ -265,15 +265,15 @@ (multiple-value-bind (keysym modifier-state) (if modifier-state (values gesture-spec modifier-state) - (parse-gesture-spec gesture-spec)) + (parse-gesture-spec gesture-spec)) (with-stack-list (key keysym modifier-state) (let ((table (port-canonical-gesture-specs port))) (when table (multiple-value-bind (value found-p) (gethash key table) (if found-p value - (setf (gethash (evacuate-list key) table) - (call-next-method port keysym modifier-state))))))))) + (setf (gethash (evacuate-list key) table) + (call-next-method port keysym modifier-state))))))))) ;; Needed for (sigh) string streams. Hardly ever used... (defmethod port-canonicalize-gesture-spec diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index c87933d55ac618616f1e8cb1d05f2b9ccb940aa8..94deacda38802bd9886a53aaf9ed85cc1e3621ac 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-defs.lisp,v 1.12 92/07/27 11:02:30 cer Exp $ +;; $fiHeader: input-defs.lisp,v 1.13 92/08/18 17:25:05 cer Exp Locker: cer $ (in-package :clim-internals) @@ -27,6 +27,9 @@ (button-state :accessor pointer-button-state :type fixnum :initform 0) (position-changed :accessor pointer-position-changed) + ;; In case the pointer's cursor needs to be managed more directly... + (cursor :initform nil :reader pointer-cursor) + ;;-- Dunno what all this are for. (cursor-pattern :accessor pointer-cursor-pattern) (cursor-width :accessor pointer-cursor-width) (cursor-height :accessor pointer-cursor-height) @@ -40,6 +43,10 @@ (progn (declaim (notinline pointer-sheet (setf pointer-sheet)))) +(defmethod (setf pointer-cursor) (cursor (pointer standard-pointer)) + (port-set-pointer-cursor (port pointer) pointer cursor) + (setf (slot-value pointer 'cursor) cursor)) + (defmethod pointer-position ((pointer standard-pointer)) (with-slots (x-position y-position) pointer (values x-position y-position))) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 084b36d62dd0065e5b8f5e6c58c27dd59d88a0fc..d80e0ebf1ff6c434870e6eb5004dadbf7b91ddff 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.23 92/08/19 18:04:53 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.24 92/09/08 15:17:57 cer Exp Locker: cer $ (in-package :clim-internals) @@ -369,9 +369,13 @@ :numeric-argument (or *accelerator-numeric-argument* 1))) ((member gesture *abort-gestures* :test #'keyboard-event-matches-gesture-name-p) - (let ((cursor (slot-value stream 'text-cursor))) - (when (and cursor - (cursor-active cursor)) + (let* ((frame (pane-frame stream)) + (stream (if (typep stream 'interactor-pane) + stream + (and frame + (find-frame-pane-of-type frame 'interactor-pane)))) + (cursor (and stream (stream-text-cursor stream)))) + (when (and cursor (cursor-active cursor)) (write-string "[Abort]" stream) (force-output stream))) (error 'abort-gesture :event gesture)))) @@ -407,6 +411,9 @@ (return-from stream-read-char gesture)) ;;--- Probably wrong. It prevents the input editor from ever seeing ;;--- mouse clicks, for example. + (when (and (typep gesture 'key-press-event) + (characterp (keyboard-event-character gesture))) + (return-from stream-read-char (slot-value gesture 'character))) (beep stream)))) (defmethod stream-unread-char ((stream input-protocol-mixin) character) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 5909bbe7d74f14b2adba8117411c2b64f80eb22c..e00a00db0e8e18c7ad6c2d3a36795e9fea6cbb21 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: output-protocol.lisp,v 1.21 92/09/08 15:18:07 cer Exp Locker: cer $ +;; $fiHeader: output-protocol.lisp,v 1.22 92/09/09 11:44:44 cer Exp Locker: cer $ (in-package :clim-internals) @@ -289,25 +289,19 @@ (defmethod stream-start-line-p ((output-stream output-protocol-mixin)) (zerop (slot-value output-stream 'cursor-x))) -#+Allegro (defmethod stream-line-column ((output-stream output-protocol-mixin)) (multiple-value-bind (origin-x origin-y space-width) - (port-glyph-for-character (port output-stream) #\space + (port-glyph-for-character (port output-stream) #\Space (medium-merged-text-style output-stream)) (declare (ignore origin-x origin-y)) + ;;--- This is pretty dubious stuff + #-Symbolics (multiple-value-bind (column remainder) (floor (slot-value output-stream 'cursor-x) space-width) (and (= remainder 0) - column)))) - -;;--- This version returns non-integers and makes allegro unhappy. -#-Allegro -(defmethod stream-line-column ((output-stream output-protocol-mixin)) - (multiple-value-bind (origin-x origin-y space-width) - (port-glyph-for-character (port output-stream) #\Space - (medium-merged-text-style output-stream)) - (declare (ignore origin-x origin-y)) - ;; Better to return a rational number than NIL + column)) + #+Symbolics + ;; Better to return a rational number than NIL. (/ (slot-value output-stream 'cursor-x) space-width))) (defmethod stream-advance-to-column ((output-stream output-protocol-mixin) column) diff --git a/clim/presentations.lisp b/clim/presentations.lisp index c3d53d2f6b7707ef0797f172dce3d9f7ebfaa06b..82738e669ff129c53646ddbfce8bda889a88caa0 100644 --- a/clim/presentations.lisp +++ b/clim/presentations.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: presentations.lisp,v 1.14 92/08/19 10:24:03 cer Exp $ +;; $fiHeader: presentations.lisp,v 1.15 92/09/08 15:18:19 cer Exp Locker: cer $ (in-package :clim-internals) @@ -140,6 +140,7 @@ (setf (presentation-object null-presentation) null-presentation) null-presentation)) + (defun window-cohorts-p (window-one window-two) ;; The best test for whether or not two windows care about each ;; other's mouse motion (for now) is whether they share an IO buffer. diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 83abbc531d1b976e3743d0891b175a915bc45189..46b978a85a7323fadc6722cd590f2c2023d6ebd6 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.12 92/08/21 16:33:59 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.13 92/09/08 15:18:32 cer Exp Locker: cer $ (in-package :clim-internals) @@ -359,7 +359,7 @@ :inherit-from t ;enforce CL definition :history t :options ((default-type nil) - (default-version :newest) + (default-version #+allegro :unspecific #-allegro :newest) (merge-default t))) ;;; PATHNAME is supposed to be a built-in-class, but since it's missing in Genera, diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp index b374d3325362ca2985fc004de39b24cbf6fb800b..6593f196e899004640da0b432810474bd048a041 100644 --- a/clim/table-formatting.lisp +++ b/clim/table-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: table-formatting.lisp,v 1.9 92/08/18 17:25:39 cer Exp Locker: cer $ +;; $fiHeader: table-formatting.lisp,v 1.10 92/08/19 18:05:04 cer Exp Locker: cer $ (in-package :clim-internals) diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index f555e38dbe134d69a65015b4681b8b75e89c0553..084a540b2a872f73d34fb31c8b9fd4b870434683 100644 --- a/clim/text-recording.lisp +++ b/clim/text-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-recording.lisp,v 1.10 92/08/18 17:25:43 cer Exp $ +;; $fiHeader: text-recording.lisp,v 1.11 92/09/08 15:18:38 cer Exp Locker: cer $ (in-package :clim-internals) @@ -29,7 +29,7 @@ (defclass standard-text-output-record (output-record-element-mixin text-displayed-output-record) - ((string :initarg :string) + ((string :initarg :string :reader text-displayed-output-record-string) (wrapped-p :initform nil :initarg :wrapped-p) (ink :initarg :ink) (clipping-region :initarg :clipping-region))) @@ -55,6 +55,8 @@ :ink ink :string string :clipping-region clipping-region :wrapped-p wrapped-p :initial-style style :current-style style :baseline baseline) + + (defmethod print-object ((object standard-text-output-record) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~S /x ~A:~A y ~A:~A/" diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp index f4e2af7779eab355fb5ff1b1069bab6e50232a27..3ec05552ee96f826b266a653734d1242081748c3 100644 --- a/clx/clx-mirror.lisp +++ b/clx/clx-mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-mirror.lisp,v 1.11 92/08/18 17:54:05 cer Exp $ +;; $fiHeader: clx-mirror.lisp,v 1.12 92/09/08 15:17:14 cer Exp Locker: cer $ (in-package :clx-clim) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index 1b59199563340c037a00fd1cf7d54c8086eda515..f169a622ce24a412bddfc30fe7ff5b5a03c76d9e 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-port.lisp,v 1.12 92/07/27 11:02:02 cer Exp $ +;; $fiHeader: clx-port.lisp,v 1.13 92/08/18 17:24:27 cer Exp Locker: cer $ (in-package :clx-clim) @@ -505,33 +505,35 @@ (defvar *clx-cursor-type-alist* - '((:default 132) - (:vertical-scroll 116) - (:scroll-up 114) - (:scroll-down 106) - (:horizontal-scroll 108) - (:scroll-left 110) - (:scroll-right 112) - (:busy 150) - (:upper-left 134) - (:upper-right 136) - (:lower-left 12) - (:lower-right 14) - (:vertical-thumb 112) - (:horizontal-thumb 114) - (:button 132) - (:prompt 92) - (:move 52) - (:position 34))) - -(defmethod install-port-cursor ((port clx-port) sheet cursor) - (unless (eq cursor (port-cursor port)) + '((:default 132) + (:vertical-scroll 116) + (:scroll-up 114) + (:scroll-down 106) + (:horizontal-scroll 108) + (:scroll-left 110) + (:scroll-right 112) + (:busy 150) + (:upper-left 134) + (:upper-right 136) + (:lower-left 12) + (:lower-right 14) + (:vertical-thumb 112) + (:horizontal-thumb 114) + (:button 132) + (:prompt 92) + (:move 52) + (:position 34))) + +;; In X Windows, cursors are associated with a particular window, so +;; we are depending on the fact that the CLX port is not deeply mirrored +;; to get the behavior that we can "globally" change the pointer cursor. +(defmethod port-set-pointer-cursor ((port clx-port) pointer cursor) + (unless (eq (pointer-cursor pointer) cursor) (with-slots (display) port - (setf (port-cursor port) cursor) - (setf (xlib:window-cursor (sheet-mirror sheet)) + (setf (xlib:window-cursor (sheet-mirror (pointer-sheet pointer))) (realize-cursor port cursor)) - (xlib:display-force-output display)) - cursor)) + (xlib:display-force-output display))) + cursor) (defmethod realize-cursor :around ((port clx-port) cursor) (with-slots (cursor-cache) port @@ -555,6 +557,7 @@ :foreground (xlib:make-color :red 0.0 :green 0.0 :blue 0.0) :background (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)))) + ;;--- We need something like PORT-SET-POINTER-POSITION (defmethod set-cursor-location ((port clx-port) sheet x y) (xlib:warp-pointer (sheet-mirror sheet) diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp index ae3065612513cdbcf86b7614286491d756966dcc..3263b3b975c92e9e132b010321e75c9de8fdac98 100644 --- a/demo/bitmap-editor.lisp +++ b/demo/bitmap-editor.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: bitmap-editor.lisp,v 1.1 92/09/08 10:39:09 cer Exp Locker: cer $ (in-package :clim-demo) @@ -46,32 +46,37 @@ (flet ((display-color (object stream) (with-room-for-graphics (stream) (draw-rectangle* stream 0 0 30 10 :ink object)))) - (setf current-color - (position - (accept `((completion ,colors) - :name-key ,#'identity - :printer ,#'display-color) - :view '(clim-internals::radio-box-view :orientation - :vertical :toggle-button-options (:indicator-type nil)) - :stream stream - :default (nth current-color colors) - :prompt "Colors") - colors)) - (terpri stream) - (accept-values-command-button (stream) - "Add Color" - (add-color-to-palette frame)) - (terpri stream) - (accept-values-command-button (stream) - "Edit Color" - (replace-current-color frame)) - (terpri stream) - (accept-values-command-button (stream) - "Delete Color" - (delete-current-color frame))))) + (formatting-item-list (stream :n-columns 2) + (formatting-cell (stream) + (setf current-color + (position + (accept `((completion ,colors) + :name-key ,#'identity + :printer ,#'display-color) + :view '(clim-internals::radio-box-view + :orientation :vertical + :toggle-button-options (:indicator-type nil)) + :stream stream + :default (nth current-color colors) + :prompt "Colors") + colors))) + (formatting-cell (stream) + (formatting-item-list (stream :n-columns 1) + (formatting-cell (stream) + (accept-values-command-button (stream) + "Add Color" + (add-color-to-palette frame))) + (formatting-cell (stream) + (accept-values-command-button (stream) + "Edit Color" + (replace-current-color frame))) + (formatting-cell (stream) + (accept-values-command-button (stream) + "Delete Color" + (delete-current-color frame))))))))) (defun replace-current-color (frame) - ;;--- Exercise for the read + ;;--- Exercise for the reader ) (defun delete-current-color (frame) @@ -190,3 +195,28 @@ (erase-output-record presentation stream) (display-cell frame stream i j) (display-pattern frame))))) + + +(defvar *bitmap-editors* nil) + +(defun do-bitmap-editor (&key (port (find-port)) (force nil)) + (let* ((framem (find-frame-manager :port port)) + (frame + (let* ((entry (assoc port *bitmap-editors*)) + (frame (cdr entry))) + (when (or force (null frame)) + (setq frame (make-application-frame 'bitmap-editor + :frame-manager framem))) + (if entry + (setf (cdr entry) frame) + (push (cons port frame) *bitmap-editors*)) + frame))) + (run-frame-top-level frame))) + +(define-demo "Bitmap Editor" do-bitmap-editor) + + + + + + diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index f326db47e0847867f0f1eacb7c11e07021972604..9fb62a7ca1828caf1459df74b7cde5c94e3d777f 100644 --- a/demo/cad-demo.lisp +++ b/demo/cad-demo.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cad-demo.lisp,v 1.15 92/08/18 17:26:16 cer Exp Locker: cer $ +;; $fiHeader: cad-demo.lisp,v 1.16 92/09/08 10:35:11 cer Exp Locker: cer $ (in-package :clim-demo) @@ -536,9 +536,7 @@ (design-area :application)) (:pointer-documentation t) (:layouts - (default design-area)) - (:top-level - (default-frame-top-level :partial-command-parser cad-demo-partial-command-parser))) + (default design-area))) (defmethod initialize-instance :around ((cd cad-demo) &key) (call-next-method) @@ -547,15 +545,6 @@ (setf (stream-output-history dp) cd) (setf (stream-recording-p dp) nil))) -(defun cad-demo-partial-command-parser (partial-command command-table stream start-location) - (let ((name (command-name partial-command))) - (if (eq name 'com-create-component) - (accept-values-command-parser - name command-table (frame-top-level-sheet *application-frame*) partial-command - :own-window t) - (menu-read-remaining-arguments-for-partial-command - partial-command command-table stream start-location)))) - (defmethod bounding-rectangle* ((cd cad-demo)) (let ((left 0) (top 0) @@ -797,32 +786,21 @@ ;;; Commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#+++ignore ;---why doesn't this work? -(define-cad-demo-command (com-create-component :menu "Create") - ((type `(member-alist ,*component-types*) - :prompt "Component type") - (position 'cad-position - :prompt "Position")) - (let ((object (make-instance type :x (car position) :y (cdr position)))) - (add-new-object *application-frame* object) - (draw-self object (get-frame-pane *application-frame* 'design-area)))) - -#---ignore +;;;--- A good exercise for the reader would be to use a partial +;;;--- command parser to read the type and position as the arguments. +;;; cos we currently have to do it in the command body. + (define-cad-demo-command (com-create-component :menu "Create" :keystroke #\C) - ;; The substrate doesn't yet support popping up the menu for the first arg... - #+ignore ((type `((menu-alist ,*component-types*))) - (position 'cad-position)) - #-ignore () - ;; ... so we do it in the command body. - (let* ((window (get-frame-pane *application-frame* 'design-area)) - (type (menu-choose *component-types* - :associated-window (window-root window) - :cache t :unique-id 'component-types))) - (when type - (let* ((position (accept 'cad-position :stream window :prompt nil)) - (object (make-instance type :x (car position) :y (cdr position)))) - (add-new-object *application-frame* object) - (draw-self object window))))) + () + (let* ((window (get-frame-pane *application-frame* 'design-area)) + (type (menu-choose *component-types* + :associated-window (window-root window) + :cache t :unique-id 'component-types))) + (when type + (let* ((position (accept 'cad-position :stream window :prompt nil)) + (object (make-instance type :x (car position) :y (cdr position)))) + (add-new-object *application-frame* object) + (draw-self object window))))) ;;; Takes two operands, an input terminal and an output terminal ;;; --- This needs to propagate value changes down the line, or diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp index 0834c4affa9b725b38628dee5899a6c6bfa81984..efd3cca41cda8293a2c8ee5d3b39940e5cf6c308 100644 --- a/demo/graphics-editor.lisp +++ b/demo/graphics-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-editor.lisp,v 1.6 92/09/08 10:35:15 cer Exp Locker: cer $ +;; $fiHeader: graphics-editor.lisp,v 1.7 92/09/08 15:19:01 cer Exp Locker: cer $ (in-package :clim-graphics-editor) @@ -554,6 +554,7 @@ (define-command (com-quit :command-table graphics-editor-file-commands :keystroke (:x :meta) + :name "Quit" :menu t) () (frame-exit *application-frame*)) @@ -569,7 +570,7 @@ (defvar *graphics-editors* nil) -(defun do-graphics-editor (&key (port (find-port)) (force t)) +(defun do-graphics-editor (&key (port (find-port)) (force nil)) (let* ((framem (find-frame-manager :port port)) (frame (let* ((entry (assoc port *graphics-editors*)) diff --git a/demo/ico.lisp b/demo/ico.lisp index 69825e48cf069a0924a3d3a398c697468eb58733..75a813b8e2fe8659985c7a3b7f6fc5c799d4c773 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.4 92/07/27 11:03:31 cer Exp Locker: cer $ +;; $fiHeader: ico.lisp,v 1.5 92/08/18 17:26:20 cer Exp Locker: cer $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -40,23 +40,25 @@ (defmethod display-options-pane ((frame ico-frame) pane &key max-width max-height) (declare (ignore max-width max-height)) - (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame - (setf ico-time-p (accept 'boolean - :default ico-time-p - :stream pane - :prompt "Time")) - (terpri pane) - (let ((x (append (and draw-faces '(:faces)) - (and draw-edges '(:edges))))) - (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose")) - (terpri pane) - (setf draw-edges (and (member :edges x) t) - draw-faces (and (member :faces x) t))) - (setf ico-line-style (accept '(member :thin :thick) - :default ico-line-style - :stream pane - :prompt "Line Style")) - (terpri pane))) + (formatting-item-list (pane :n-rows 1) + (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame + (formatting-cell (pane) + (setf ico-time-p (accept 'boolean + :default ico-time-p + :stream pane + :prompt "Time"))) + (formatting-cell (pane) + (let ((x (append (and draw-faces '(:faces)) + (and draw-edges '(:edges))))) + (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose")) + (setf draw-edges (and (member :edges x) t) + draw-faces (and (member :faces x) t)))) + (formatting-cell (pane) + (setf ico-line-style (accept '(member :thin :thick) + :default ico-line-style + :stream pane + :prompt "Line Style")))))) + (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) () (with-application-frame (frame) diff --git a/demo/plot.lisp b/demo/plot.lisp index 65a5a072fdae53a4cd87d537f3e88f85815817dc..14245d2dc940f83624d5a439aa62e7c6774dc9d8 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- +>;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;; ;; -[]- @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.6 92/08/18 17:26:23 cer Exp Locker: cer $ +;; $fiHeader: plot.lisp,v 1.7 92/09/08 10:35:16 cer Exp $ (in-package :clim-demo) @@ -52,16 +52,35 @@ ;; We should make presentations of these types (define-presentation-type graph-plot ()) + (define-presentation-type graph-region ()) +(define-presentation-method accept ((type graph-region) stream (view textual-view) &key) + (let ((ltrb (accept `((sequence-enumerated + ((sequence-enumerated real real) :echo-space nil) + ((sequence-enumerated real real) :echo-space nil)) + :separator #\: :echo-space nil) + :prompt nil :stream stream))) + (destructuring-bind ((left top) (right bottom)) ltrb + (make-rectangle* left top right bottom)))) + +(define-presentation-method present (region (type graph-region) stream (view textual-view) &key) + (with-bounding-rectangle* (left top right bottom) region + (present `((,left ,top) (,right ,bottom)) + `((sequence-enumerated + ((sequence-enumerated real real) :echo-space nil) + ((sequence-enumerated real real) :echo-space nil)) + :separator #\: :echo-space nil) + :stream stream))) + (define-presentation-method presentation-typep (object (type graph-region)) - (typep object 'standard-rectangle)) + (rectanglep object)) (define-command-table plot-command-table) (define-presentation-translator select-graph-region (graph-plot graph-region plot-command-table :gesture :select) - (x y window) + (x y window) (let ((nx x) (ny y) (ox x) @@ -72,22 +91,49 @@ :filled nil :ink +flipping-ink+))) (declare (dynamic-extent #'draw-it)) (draw-it) - (tracking-pointer (window) - (:pointer-motion (x y) - (draw-it) - (setq nx x ny y) - (draw-it)) - (:pointer-button-press (x y) - (draw-it) - (setq nx x ny y) - (return (make-rectangle* ox oy nx ny)))))))) + (clim-utils:letf-globally (((sheet-pointer-cursor window) (sheet-pointer-cursor window))) + (tracking-pointer (window) + (:pointer-motion (x y) + (draw-it) + (setq nx x ny y) + (draw-it) + (setf (sheet-pointer-cursor window) + (if (< nx ox) + (if (< ny oy) + :upper-left + :lower-left) + (if (< ny oy) + :upper-right + :lower-right)))) + (:pointer-button-press (x y) + (draw-it) + (setq nx x ny y) + (return (make-rectangle* ox oy nx ny))))))))) ;; Define a presentation translator from a graph-plot to a graph-region. ;; In that way we trivially write a command that will zoom into a ;; particular region of the graph. -(define-presentation-type graph-point ()) -(define-presentation-type graph-line ()) +(define-presentation-type plot-point ()) + +(define-presentation-method accept ((type plot-point) stream (view textual-view) &key) + (values (accept `((sequence-enumerated real real) :echo-space nil) + :prompt nil :stream stream))) + +(define-presentation-method present (point (type plot-point) stream (view textual-view) &key) + (present point `((sequence-enumerated real real) :echo-space nil) + :stream stream)) + +(define-presentation-method presentation-typep (object (type plot-point)) + (and (listp object) + (= (length object) 2) + (every #'realp object))) + +(define-presentation-type graph-point () + :inherit-from 'plot-point) + +(define-presentation-type graph-line () + :inherit-from 'integer) (define-presentation-type graph-axis ()) @@ -427,7 +473,8 @@ (y-labels :initform (copy-list '("Mexico City" "Tokyo" "New York")))) (:command-table (plot-demo :inherit-from (plot-command-table accept-values-pane))) (:panes - (graph-window :application + (graph-window :application + :label "Plot" :display-function 'display-graph :incremental-redisplay t :end-of-line-action :allow @@ -435,6 +482,7 @@ :scroll-bars :both :width :compute :height :compute) (data-window :application + :label "Data" :display-function 'display-data :incremental-redisplay t :end-of-line-action :allow @@ -442,6 +490,7 @@ :scroll-bars :both :width :compute :height :compute) (options :accept-values + :label "Options" :scroll-bars :both :display-function `(accept-values-pane-displayer :resynchronize-every-pass t @@ -487,9 +536,13 @@ (defmethod frame-standard-output ((fr plot-demo)) (get-frame-pane fr 'command)) -(define-presentation-type data-point ()) -(define-presentation-type x-label ()) -(define-presentation-type y-label ()) +(define-presentation-type data-point () + :inherit-from 'plot-point) + +(define-presentation-type x-label () + :inherit-from 'integer) +(define-presentation-type y-label () + :inherit-from 'integer) (defmethod display-data ((frame plot-demo) stream &key &allow-other-keys) (updating-output (stream) @@ -544,14 +597,6 @@ (with-output-as-presentation (stream n 'number) (format stream "~2D" n))))))))))))))) -(define-plot-demo-command (com-edit-x-label :name t :menu t) - ((i 'x-label :gesture :select)) - (with-application-frame (frame) - (setf (nth i (slot-value frame 'x-labels)) - (accept 'string - :default (nth i (slot-value frame 'x-labels)))))) - - #+allegro (define-plot-demo-command (com-print-graph :name t :menu t) ((printer '(member :lw :lw2 :lw3) @@ -562,8 +607,59 @@ (with-output-to-postscript-stream (stream pipe :multi-page t) (display-graph *application-frame* stream)))) +(define-plot-demo-command (com-edit-x-label :name t :menu t) + ((i 'x-label :gesture :select)) + (with-application-frame (frame) + (setf (nth i (slot-value frame 'x-labels)) + (accept 'string + :default (nth i (slot-value frame 'x-labels)))))) +(define-presentation-action drag-it-translator + (blank-area command plot-command-table + :documentation "Drag" + :gesture :describe) + (window) + (let (ox oy + ;;--- We use this sheet because its a stable reference sheet. + ;;--- We cannot use the window because its native transformation + ;;--- changes as we go and than causes confusion + (sheet (frame-top-level-sheet (pane-frame window)))) + (multiple-value-bind (minx miny maxx maxy) (viewport-range window) + (clim-utils:letf-globally (((sheet-pointer-cursor sheet) :move)) + (tracking-pointer (sheet :multiple-window t) + (:pointer-motion (x y) + (multiple-value-bind (vx vy) (window-viewport-position window) + (when ox + (window-set-viewport-position + window + (min maxx (max minx (+ vx (- x ox)))) ; +/- + (min maxy (max miny (+ vy (- y oy)))))) ; +/- + (setq ox x oy y))) + (:pointer-button-press (x y) + (when ox + (multiple-value-bind (vx vy) (window-viewport-position window) + (window-set-viewport-position + window + (min maxx (max minx (+ vx (- x ox)))) + (min maxy (max miny (+ vy (- y oy)))))) + (return nil)))))))) + +(defun viewport-range (window) + (multiple-value-bind (vwidth vheight) + (bounding-rectangle-size (pane-viewport-region window)) + (with-bounding-rectangle* (left top right bottom) + (silica::viewport-contents-extent (pane-viewport window)) + (let ((cwidth (- right left)) + (cheight (- bottom top))) + (values left + top + (+ left (max 0 (- cwidth vwidth))) + (+ top (max 0 (- cheight vheight)))))))) + + + + (define-plot-demo-command (com-edit-y-label :name t :menu t) ((i 'y-label :gesture :select)) (with-application-frame (frame) @@ -672,3 +768,5 @@ (run-frame-top-level frame))) (define-demo "Plotting Demo" do-plot-demo) + + diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index 9af5425f606bc716b56c658c9922401c8ad89ef0..c6b7288ab613f675caee1fc3c104b16f857daf3d 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: puzzle.lisp,v 1.13 92/08/21 16:34:11 cer Exp $ +;; $fiHeader: puzzle.lisp,v 1.14 92/09/08 15:19:06 cer Exp Locker: cer $ (in-package :clim-demo) diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp index 22bdcc3f1505d6ee0c8b2287ee8f93f0bfb71892..2cb8e2b0e73ba301fb89ba747acdfe8de9e1d910 100644 --- a/demo/sysdcl.lisp +++ b/demo/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.15 92/08/18 17:26:25 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.16 92/09/08 10:35:18 cer Exp Locker: cer $ (in-package #-ansi-90 :user #+ansi-90 :common-lisp-user) @@ -35,6 +35,7 @@ ("browser" :load-before-compile ("demo-driver" "packages")) #+Allegro ("process-browser" :load-before-compile ("demo-driver" "packages")) + ("demo-activity" :load-before-compile ("demo-driver" "packages")) ("bitmap-editor" :load-before-compile ("demo-driver" "packages")) ("demo-prefill" :features (or Genera Cloe-Runtime))) diff --git a/misc/compile-ol.lisp b/misc/compile-ol.lisp deleted file mode 100644 index 4c31aedde561de5d4d70b9cde86f3ff27884b5be..0000000000000000000000000000000000000000 --- a/misc/compile-ol.lisp +++ /dev/null @@ -1,30 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; -[]- -;; -;; 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 Supplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: compile-ol.lisp,v 1.1 92/03/24 19:45:41 cer Exp $ - -(in-package :user) - -(pushnew :clim-openlook *features*) - -(load "misc/compile-1") -(compile-it 'openlook-clim) diff --git a/misc/compile-xm.lisp b/misc/compile-xm.lisp deleted file mode 100644 index bc7fe918fe006f99d81e17889743baf70684aedc..0000000000000000000000000000000000000000 --- a/misc/compile-xm.lisp +++ /dev/null @@ -1,30 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; -[]- -;; -;; 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 Supplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: compile-xm.lisp,v 1.7 92/03/24 19:38:31 cer Exp $ - -(in-package :user) - -(pushnew :clim-motif *features*) - -(load "misc/compile-1") -(compile-it 'motif-clim) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index bf31aee6e346631c8cb2ae83b6dd458ddf53096b..8bc560d9d768d64fc77b269789bc5acbb7f02a2a 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.11 92/09/08 10:35:25 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.12 92/09/08 15:19:10 cer Exp Locker: cer $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -83,7 +83,7 @@ #-ignore (clim-defsys::load-system 'clim-demo))) - + #+:allegro-v4.1 (when (probe-file "/scm/4.1/sparc/src/code/") (let ((sys::*require-search-list* (cons (make-pathname :directory "/scm/4.1/sparc/src/code/" @@ -98,4 +98,5 @@ (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/")) (tenuring - (load "misc/clos-preload.fasl" :if-does-not-exist nil))) + (ignore-errors + (load "misc/clos-preload.fasl" :if-does-not-exist nil)))) diff --git a/misc/dev-load-ol.lisp b/misc/dev-load-ol.lisp deleted file mode 100644 index 3876e0973be76e65cba07eca5ddd59b2dcd36321..0000000000000000000000000000000000000000 --- a/misc/dev-load-ol.lisp +++ /dev/null @@ -1,28 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; -[]- -;; -;; 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 Supplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: dev-load-ol.lisp,v 1.2 92/05/07 13:13:48 cer Exp $ - -(pushnew :clim-openlook *features*) - -(load "misc/dev-load-1") -(load-it 'openlook-clim) diff --git a/misc/dev-load-xm.lisp b/misc/dev-load-xm.lisp deleted file mode 100644 index 156ea7cabec8fcb701b1267f70cbf6e9645a33e4..0000000000000000000000000000000000000000 --- a/misc/dev-load-xm.lisp +++ /dev/null @@ -1,28 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; -[]- -;; -;; 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 Supplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: dev-load-xm.lisp,v 1.7 92/05/07 13:13:49 cer Exp $ - -(pushnew :clim-motif *features*) - -(load "misc/dev-load-1") -(load-it 'motif-clim) diff --git a/silica/classes.lisp b/silica/classes.lisp index bcddbd31e101aac6bcbc9b900754fd12b44d3bf7..fd39cfe7df23a5a923dbbcdec6483bb1ab08382c 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: classes.lisp,v 1.16 92/08/19 18:04:12 cer Exp $ +;; $fiHeader: classes.lisp,v 1.17 92/09/08 15:16:29 cer Exp Locker: cer $ (in-package :silica) @@ -32,7 +32,6 @@ (medium-cache :initform nil :accessor port-medium-cache) (color-cache :initform (make-hash-table) :reader port-color-cache) (pointer :initform nil) - (cursor :initform nil :accessor port-cursor) (mapping-table :initform (make-hash-table :test #'equal)) (mapping-cache :initform (cons nil nil)) ;one entry cache (undefined-text-style :initform *undefined-text-style* @@ -56,13 +55,15 @@ ;;--- Make a SHEET protocol class, and call this BASIC-SHEET (defclass sheet () - ((port :initform nil :reader port) - (graft :initform nil :reader graft) - (parent :initform nil - :accessor sheet-parent) - (region :initarg :region :initform (make-bounding-rectangle 0 0 100 100) - :accessor sheet-region) - (enabledp :initform nil :accessor sheet-enabled-p))) + ((port :initform nil :reader port) + (graft :initform nil :reader graft) + (parent :initform nil + :accessor sheet-parent) + (region :initarg :region :initform (make-bounding-rectangle 0 0 100 100) + :accessor sheet-region) + (enabledp :initform nil :accessor sheet-enabled-p) + ;;-- Is this the best place + (cursor :initform nil :reader sheet-pointer-cursor))) (define-protocol-class medium ()) @@ -214,4 +215,4 @@ (deftype lock-keysym () '(member :caps-lock :shift-lock :mode-lock)) (deftype modifier-keysym () - '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym lock-keysym)) + '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym)) diff --git a/silica/event.lisp b/silica/event.lisp index c3f9318bd9ef854febd4319d6ac95ec11ceaf40a..ea0c40689d306c226e7d1b4ab0c91c61dbf8d68b 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: event.lisp,v 1.20 92/08/18 17:23:36 cer Exp $ +;; $fiHeader: event.lisp,v 1.21 92/09/08 15:16:38 cer Exp Locker: cer $ (in-package :silica) @@ -156,6 +156,13 @@ ;;; Crossing events + +;; Note that exit events on the parent are generated when the pointer goes +;; from a parent to a child, and that enter events on the parent are generated +;; when the pointer goes back from the child to the parent again. If these +;; events are not interesting, the user should ignore all pointer-enter and +;; exit events that have a kind of :inferior. +;; ;; We have fun here to generate enter/exit events for unmirrored sheets ;; Three cases: ;; 1. Mouse motion event: @@ -187,6 +194,165 @@ ;; We should probably exit from intermediate descendents. ;; Sheet- x,y,z --> Child ;; 4. Share a common ancestor: exit from all of the sheets. + + +;; +;; There is a lot of unnecessary hair in this code because a sheet's +;; region is not always correct in the current implementation! +;; + + +#-jdi-version +(defun generate-crossing-events (port event) + (declare (optimize (speed 3))) + (let* ((mirrored-sheet (event-sheet event)) + (toplevel-sheet mirrored-sheet) + (x (pointer-event-native-x event)) + (y (pointer-event-native-y event)) + (modifiers (event-modifier-state event)) + (pointer (pointer-event-pointer event)) + (ancestors-of-mirrored-sheet + (do ((sheets nil) + (sheet (sheet-parent mirrored-sheet) (sheet-parent sheet))) + ((graftp sheet) sheets) + (push sheet sheets)))) + (macrolet ((generate-enter-event (sheet kind) + `(let ((sheet ,sheet)) + (dispatch-event + sheet + (allocate-event 'pointer-enter-event + :sheet sheet + :x x :y y + :kind ,kind + :modifier-state modifiers + :pointer pointer)))) + (generate-exit-event (sheet kind) + `(let ((sheet ,sheet)) + (dispatch-event + sheet + (allocate-event 'pointer-exit-event + :sheet sheet + :x x :y y + :kind ,kind + :modifier-state modifiers + :pointer pointer))))) + + ;; If we got an event for some mirrored child, go back to the top level + ;; sheet. + (unless (graftp (sheet-parent mirrored-sheet)) + (let ((new-x x) + (new-y y)) + (dolist (sheet (cons mirrored-sheet (reverse ancestors-of-mirrored-sheet))) + (when (graftp (sheet-parent sheet)) + (setq x new-x + y new-y + toplevel-sheet sheet) + (return)) + (multiple-value-setq (new-x new-y) + (map-sheet-position-to-parent sheet new-x new-y))))) + + (let* ((v (port-trace-thing port)) + (exitted-a-window + (and (typep event 'pointer-exit-event) + (not (eq (pointer-boundary-event-kind event) :inferior)))) + (entered-from-child + (and (typep event 'pointer-enter-event) + (eq (pointer-boundary-event-kind event) :inferior))) + (exitted-top-level-window + (and exitted-a-window + (eq toplevel-sheet mirrored-sheet)))) +#| + (format excl:*initial-terminal-io* + "Inside g-c-e, top-sheet: ~s, mir-sheet: ~s,~% port-trace: " + toplevel-sheet mirrored-sheet) + (dotimes (i (fill-pointer v)) + (format excl:*initial-terminal-io* " ~s~%" (aref v i))) + (format excl:*initial-terminal-io* "~%event: ~s~%" event) +|# + (when (or (not exitted-a-window) + exitted-top-level-window) + #+Genera (declare (sys:array-register v)) + ;; Pop up the stack of sheets + (unless (zerop (fill-pointer v)) + (let ((m (if (and (not exitted-top-level-window) + (eq (aref v 0) toplevel-sheet)) + (let ((new-x x) + (new-y y) + (mirrored-sheet-in-trace + (position mirrored-sheet v :test #'eq)) + sheet) + (if (and mirrored-sheet-in-trace + (> mirrored-sheet-in-trace 1)) + (do ((i 1 (1+ i))) + ((> i mirrored-sheet-in-trace)) + (multiple-value-setq (new-x new-y) + (map-sheet-position-to-child + (aref v i) new-x new-y)))) + (do ((i (if mirrored-sheet-in-trace + (1+ mirrored-sheet-in-trace) 0) (1+ i))) + ((>= i (fill-pointer v)) (fill-pointer v)) + (setq sheet (aref v i)) + (unless (zerop i) + (multiple-value-setq (new-x new-y) + (map-sheet-position-to-child sheet new-x new-y))) + (when (or (and (not mirrored-sheet-in-trace) + (not (member sheet ancestors-of-mirrored-sheet))) + (not (sheet-enabled-p sheet)) + (not (region-contains-position-p + (sheet-region sheet) new-x new-y))) + (return i)))) + 0))) + (do ((i (1- (fill-pointer v)) (1- i))) + ((< i m)) + (generate-exit-event (aref v i) :ancestor) + (unless (zerop i) + (generate-enter-event (aref v (1- i)) :inferior))) + (setf (fill-pointer v) m)))) + (when (and (not exitted-a-window) + (not entered-from-child) + (region-contains-position-p (sheet-region toplevel-sheet) x y)) + ;; If its empty initialize it with the toplevel sheet. + (when (zerop (fill-pointer v)) + (vector-push-extend toplevel-sheet v) + (generate-enter-event toplevel-sheet :ancestor)) + ;; Now add all sheets between the last sheet on the trace + ;; and the mirrored sheet. + (unless (find mirrored-sheet v :test #'eq) + (let ((last-sheet (aref v (1- (fill-pointer v)))) + (sheets nil)) + (do ((sheet mirrored-sheet (sheet-parent sheet))) + ((or (eq sheet last-sheet) + (when (graftp sheet) + (setq sheets nil) + t))) + (push sheet sheets)) + (dolist (sheet sheets) + (generate-exit-event (aref v (1- (fill-pointer v))) :inferior) + (generate-enter-event sheet :ancestor) + (vector-push-extend sheet v)))) + ;; We have to get the sheets into the correct coordinate space + (loop for i from 1 below (fill-pointer v) + do (multiple-value-setq (x y) + (map-sheet-position-to-child (aref v i) x y))) + ;; Finally add progeny of mirrored-sheet. + (let ((new-x x) + (new-y y) + (sheet (aref v (1- (fill-pointer v)))) + child) + (loop + (unless (typep sheet 'sheet-parent-mixin) + (return nil)) + (setq child (child-containing-position sheet new-x new-y)) + (unless child + (return nil)) + (generate-exit-event sheet :inferior) + (generate-enter-event child :ancestor) + (multiple-value-setq (new-x new-y) + (map-sheet-position-to-child child new-x new-y)) + (setq sheet child) + (vector-push-extend child v)))))))) + +#+pre-jdi-version (defun generate-crossing-events (port event) (declare (optimize (speed 3))) (let* ((mirrored-sheet (event-sheet event)) @@ -305,6 +471,7 @@ (map-sheet-position-to-child child new-x new-y)) (setq sheet child) (vector-push-extend child v)))))))) +>>>>>>> 1.21 ;;; Event distribution @@ -343,7 +510,7 @@ (y (pointer-event-native-y event)) (modifiers (event-modifier-state event)) (pointer (pointer-event-pointer event))) - ;; Dispatch event to the innermost sheet + ;; dispatch event to the innermost sheet (let ((sheet (let ((v (port-trace-thing port))) (and (not (zerop (fill-pointer v))) (aref v (1- (fill-pointer v))))))) @@ -356,29 +523,29 @@ (pointer-y-position pointer) ty (pointer-native-x-position pointer) x (pointer-native-y-position pointer) y) - (typecase event - (pointer-button-event + (typecase event + (pointer-button-event (dispatch-event - sheet - (allocate-event event-type - :sheet sheet - :native-x x :native-y y - :x tx :y ty - :modifier-state modifiers - :button (pointer-event-button event) - :pointer pointer))) - (pointer-motion-event + sheet + (allocate-event event-type + :sheet sheet + :native-x x :native-y y + :x tx :y ty + :modifier-state modifiers + :button (pointer-event-button event) + :pointer pointer))) + (pointer-motion-event (dispatch-event - sheet - (allocate-event event-type - :sheet sheet - :native-x x :native-y y - :x tx :y ty - :modifier-state modifiers - :pointer pointer))) - ;; Pointer exit and enter events are handled - ;; by GENERATE-CROSSING-EVENTS. - ))))) + sheet + (allocate-event event-type + :sheet sheet + :native-x x :native-y y + :x tx :y ty + :modifier-state modifiers + :pointer pointer))) + ;; Pointer exit and enter events are handled + ;; by generate-crossing-events. + ))))) (deallocate-event event)) @@ -533,10 +700,13 @@ (setf (slot-value copy name) (slot-value event name))))) copy)) -#|| + + +#| ;; Debugging help + (defmethod print-object ((event pointer-boundary-event) stream) - (print-unreadable-object (event stream :type t :identity *print-escape*) + (print-unreadable-object (event stream :type t :identity nil) (let ((comma nil)) (when (slot-boundp event 'sheet) (let ((sheet (event-sheet event))) @@ -547,4 +717,28 @@ (if comma (write-string ", " stream)) (format stream "kind ~s" (pointer-boundary-event-kind event)))))) -||# + +(defmethod print-object ((event pointer-motion-event) stream) + (print-unreadable-object (event stream :type t :identity nil) + (let ((comma nil)) + (when (slot-boundp event 'sheet) + (let ((sheet (event-sheet event))) + (format stream "~:[~;mirrored ~]sheet ~s" + (sheet-direct-mirror sheet) sheet)) + (setq comma t)) + (when (slot-boundp event 'x) + (if comma + (write-string ", " stream)) + (format stream "x: ~d, y: ~d" + (pointer-event-x event) (pointer-event-y event)) + (setq comma t)) + (when (slot-boundp event 'native-x) + (if comma + (write-string ", " stream)) + (format stream "nx: ~d, ny: ~d" + (pointer-event-native-x event) (pointer-event-native-y event)) + )))) + + +|# + diff --git a/silica/framem.lisp b/silica/framem.lisp index cb1a7341420746f8b6d1e42cef54831fd3884bf6..38553560a438e596edcd908a728f083854c7e147 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: framem.lisp,v 1.13 92/08/18 17:23:38 cer Exp $ +;; $fiHeader: framem.lisp,v 1.14 92/09/08 15:16:40 cer Exp Locker: cer $ (in-package :silica) @@ -76,7 +76,9 @@ (let* ((top-pane (frame-panes frame)) (sheet (with-look-and-feel-realization (framem frame) (make-pane 'top-level-sheet + :event-queue (clim-internals::frame-input-buffer frame) :user-specified-position-p (frame-user-specified-position-p frame) + :user-specified-size-p (frame-user-specified-size-p frame) :region (multiple-value-bind (width height) (bounding-rectangle-size top-pane) @@ -86,6 +88,8 @@ (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) + + (defmethod adopt-frame :after ((framem standard-frame-manager) frame) (setf (frame-manager-frames framem) (nconc (frame-manager-frames framem) (list frame)))) @@ -177,3 +181,9 @@ (declare (ignore realizer type)) (declare (non-dynamic-extent options)) options) + +(defmethod note-frame-iconified ((framem standard-frame-manager) frame) + (setf (frame-state frame) :shrunk)) + +(defmethod note-frame-deiconified ((framem standard-frame-manager) frame) + (setf (frame-state frame) :enabled)) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 65d444d3620fd222dba864e18710dc8cc0e3f8e6..64a1a6d343538888a9627e0eb3406215fac55385 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: mirror.lisp,v 1.24 92/08/18 17:23:51 cer Exp $ +;; $fiHeader: mirror.lisp,v 1.25 92/09/08 15:16:47 cer Exp Locker: cer $ (in-package :silica) @@ -149,8 +149,6 @@ ;; Returns the regions mirror in the mirror coordinate space (defgeneric mirror-region (port sheet)) -(defgeneric mirror-region* (port sheet)) -(defgeneric mirror-inside-region* (port sheet)) (defgeneric mirror-native-edges* (port sheet)) (defgeneric mirror-inside-edges* (port sheet)) (defgeneric set-sheet-mirror-edges* (port sheet left top right bottom)) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 3b0bed89325f2067dc285a9320d5ea6fc8ffbbde..f6240f362504a66631f6db45a7f00fce4d78a7db 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sheet.lisp,v 1.24 92/08/18 17:23:55 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.25 92/09/08 15:16:51 cer Exp Locker: cer $ (in-package :silica) @@ -141,16 +141,20 @@ (let ((parent (sheet-parent sheet))) (when parent (setf (sheet-children parent) - (nconc (delete sheet (sheet-children parent)) (list sheet))))) + (nconc (delete sheet (sheet-children parent) :test #'eq) + (list sheet))))) (when (sheet-direct-mirror sheet) (bury-mirror (port sheet) sheet))) +;; This could be optimized if we can guarantee that the ordering of +;; sheet-children is always kept up to date wrt the actual stacking +;; order. Unfortunately this is quite hard under X11 for top level windows. (defmethod reorder-sheets ((parent sheet) new-ordering) - ;; Error check new ordering + ;; Errorcheck new-ordering. (assert (null (set-exclusive-or new-ordering (sheet-children parent))) - (new-ordering) - "Specified ordering ~S does not contain children of sheet ~S" - new-ordering parent) + (new-ordering) + "Specified ordering ~S does not contain children of sheet ~S" + new-ordering parent) (setf (sheet-children parent) new-ordering) (let ((port (port parent))) (dolist (child (reverse new-ordering)) @@ -449,3 +453,34 @@ (defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) &key enabled) (setf (sheet-enabled-p sheet) enabled)) + + + + + + + +(defmethod (setf sheet-pointer-cursor) (cursor (sheet sheet)) + (port-set-sheet-pointer-cursor (port sheet) sheet cursor) + (setf (slot-value sheet 'cursor) cursor)) + +(defmacro with-pointer-grabbed ((sheet &rest options) &body body) + `(flet ((with-pointer-grabbed-body () ,@body)) + (declare (dynamic-extent #'with-pointer-grabbed-body)) + (invoke-with-pointer-grabbed ,sheet #'with-pointer-grabbed-body ,@options))) + +(defun invoke-with-pointer-grabbed (sheet continuation &rest options) + (apply #'port-invoke-with-pointer-grabbed (port sheet) sheet continuation options)) + +(defmethod port-invoke-with-pointer-grabbed ((port port) (sheet sheet) continuation &key) + (declare (ignore options)) + (funcall continuation)) + +(defmethod (setf sheet-grabbed-pointer-cursor) (cursor (sheet sheet)) + (port-set-sheet-grabbed-pointer-cursor (port sheet) + sheet + cursor)) + +(defmethod port-set-sheet-grabbed-pointer-cursor ((port port) (sheet sheet) cursor) + (declare (ignore cursor)) + nil) diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp index e04ec4aff1b799c9f734a3850bd3247baf140102..32252984b2b6e0544c2702c54aac2eb828b301ba 100644 --- a/sys/defsystem.lisp +++ b/sys/defsystem.lisp @@ -27,7 +27,7 @@ ;;; ;;;----------------------------------------------------------- -;; $fiHeader: defsystem.lisp,v 1.12 92/07/01 15:47:14 cer Exp $ +;; $fiHeader: defsystem.lisp,v 1.13 92/08/18 17:25:50 cer Exp Locker: cer $ ;; Add a feature for ANSI-adhering Lisps. So far, only Apple's ;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1. @@ -1081,7 +1081,7 @@ pathname fields are evaluated." (proclaim '(special *loaded-systems* *loaded-modules* *compiled-systems* *compiled-modules* *tracep*))) -#-(and ANSI-90 (not Allegro) (not Cloe)) +#+(or (not ANSI-90) (and Allegro (not (version>= 4 2))) Cloe) (#+Allegro excl::without-package-locks #-Allegro progn (defun translate-logical-pathname (path) path) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 2ae020be5033c878bf6a5b8f32cf5a9f06e33d62..809a7c09d15e5ff25a06071c16de3ec92c39da7e 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.24 92/09/08 10:34:59 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.25 92/09/08 15:18:42 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -295,6 +295,8 @@ ("frames" :load-before-compile ("clim-defs" "command-processor")) ("default-frame" + :load-before-compile ("frames")) + ("activities" :load-before-compile ("frames")) ("db-menu" :load-before-compile ("frames")) diff --git a/test/simple-test.lisp b/test/simple-test.lisp index b813cad854faabc676b3c08bb59f2a3ca686f348..2f2ab59816a348e81f0c358663e6bf4def37c9d4 100644 --- a/test/simple-test.lisp +++ b/test/simple-test.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: clim-user; Base: 10; Lowercase: Yes -*- ;; ;; -[]- ;; @@ -20,12 +20,22 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: simple-test.lisp,v 1.6 92/03/04 16:22:37 cer Exp Locker: cer $ +;; $fiHeader: simple-test.lisp,v 1.7 92/07/20 16:00:48 cer Exp $ -(in-package :silica) +(defpackage :clim-user (:use :clim-silica)) -(defclass even-simpler (simple-sheet) ()) +(in-package :clim-user) + +(defclass simple-test-sheet (silica::permanent-medium-sheet-output-mixin + silica::sheet-multiple-child-mixin + silica::sheet-transformation-mixin + silica::standard-repainting-mixin + silica::immediate-sheet-input-mixin + sheet) + ()) + +(defclass even-simpler (simple-test-sheet) ()) (defun simple-test () (let* ((port (find-port)) @@ -35,7 +45,7 @@ :region (make-bounding-rectangle 0 0 300 300)))) (dotimes (i 5) (dotimes (j 5) - (let ((s (make-instance 'simple-sheet + (let ((s (make-instance 'simple-test-sheet :parent sheet :region (make-bounding-rectangle 0 0 60 60) :transformation @@ -50,7 +60,7 @@ (setf (sheet-enabled-p sheet) t) sheet)) -(defmethod handle-event ((sheet simple-sheet) (event pointer-enter-event)) +(defmethod handle-event ((sheet simple-test-sheet) (event pointer-enter-event)) (outline-sheet sheet) (setf (port-keyboard-input-focus (port sheet)) sheet)) @@ -62,18 +72,18 @@ :filled nil :ink +flipping-ink+))) -(defmethod handle-event ((sheet simple-sheet) (event pointer-exit-event)) +(defmethod handle-event ((sheet simple-test-sheet) (event pointer-exit-event)) (outline-sheet sheet)) -(defmethod handle-event ((sheet simple-sheet) (event pointer-button-event)) +(defmethod handle-event ((sheet simple-test-sheet) (event pointer-button-event)) (multiple-value-call #'draw-rectangle* sheet (bounding-rectangle* sheet) :ink +flipping-ink+)) -(defmethod handle-event ((sheet simple-sheet) (event keyboard-event)) +(defmethod handle-event ((sheet simple-test-sheet) (event keyboard-event)) (draw-line* sheet -200 -200 200 200 :ink +flipping-ink+ :line-thickness 10)) @@ -85,3 +95,11 @@ (bounding-rectangle* sheet) :filled t :ink +red+)) + +(defmethod repaint-sheet ((sheet standard-sheet) (region t)) + ) + +(defmethod repaint-sheet ((sheet simple-test-sheet) (region t)) + ) + + diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 3229f55f18555129b67a1270f5ab9e1cd4a2ec36..d85cc816902fa0b05e31ba491d8ce536bf597541 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.33 92/09/08 15:18:44 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.34 92/09/09 11:44:49 cer Exp Locker: cer $ (in-package :clim-user) @@ -668,14 +668,22 @@ people, shall not perish from the earth. (draw-text* stream "Some fox jumped over something" 200 200 :towards-x 400 :towards-y 200)) (with-output-as-presentation (stream 2 'form) - (draw-text* stream "Some fox jumped over something" 200 200 - :towards-x 200 :towards-y 400)) + (with-text-style (stream '(nil :italic :larger)) + (draw-text* stream "Some fox jumped over something" 200 200 + :towards-x 200 :towards-y 400))) (with-output-as-presentation (stream 3 'form) - (draw-text* stream "Some fox jumped over something" 200 200 - :towards-x 0 :towards-y 200)) + (with-text-style (stream '(nil :bold :huge)) + (draw-text* stream "Some fox jumped over something" 200 200 + :towards-x 0 :towards-y 200))) (with-output-as-presentation (stream 4 'form) - (draw-text* stream "Some fox jumped over something" 200 200 - :towards-x 200 :towards-y 0)))) + (with-text-style (stream '(nil :bold :small)) + (draw-text* stream "Some fox jumped over something" 200 200 + :towards-x 200 :towards-y 0))) + (do ((x 300 (+ x 20))) + ((> x 1000)) + (with-output-as-presentation (stream 4 'form) + (draw-text* stream "Dont be silly in the City." x 200 + :towards-x x :towards-y 0))))) (defparameter *named-colors* '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+ @@ -1100,7 +1108,12 @@ people, shall not perish from the earth. "Draw a graph showing part of the CLOS class hierarchy" (format-graph-from-roots (mapcar #'find-class '(clos:metaobject clos:dependee-mixin)) - #'(lambda (o s) (format s "~A" (clos::class-name o))) + #'(lambda (o s) + (let ((text (format nil "~A" (clos::class-name o)))) + (multiple-value-bind (width height) (text-size s text) + (with-new-output-record (s) + (draw-rectangle* s 0 0 width height :filled t :ink +red+) + (draw-text* s text 0 0 :align-x :left :align-y :top))))) #'clos::class-direct-subclasses :stream stream :merge-duplicates t)) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index f3dfdfd49a418ae227142ca61e36ab8dfa90126c..506c6e76c2a830f3316d72a3bbb2bfe3a5bf3d91 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.23 92/08/18 17:26:32 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.24 92/09/08 15:19:13 cer Exp Locker: cer $ (in-package :xm-silica) @@ -158,7 +158,7 @@ ;;; top level sheet -(defclass openlook-top-level-sheet (top-level-sheet) ()) +(defclass openlook-top-level-sheet (xt-top-level-sheet) ()) (defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-top-level-sheet) @@ -275,45 +275,101 @@ ;; submenus then it creates one with a menu of its own (let ((mirror (call-next-method))) - (labels ((make-menu-for-command-table (command-table parent top) - (map-over-command-table-menu-items - #'(lambda (menu keystroke item) - (declare (ignore keystroke)) - (let ((type (command-menu-item-type item))) - (case type - (:divider - (unless top - (make-instance 'xt::static-text - :parent parent - :managed nil - :string " "))) - (:function - ;;--- Do this sometime - ) - (:menu - (let* ((mb (make-instance 'tk::menu-button - :parent parent - :label menu))) - (make-menu-for-command-table - (find-command-table (second item)) - (tk::get-values mb :menu-pane) - nil))) - (t - (let ((button - (make-instance 'tk::oblong-button - :label menu - :managed t - :parent parent))) - (set-button-accelerator-from-keystroke button keystroke) + (labels ((update-menu-item-sensitivity (widget frame commands) + (declare (ignore widget)) + (dolist (cbs commands) + (tk::set-sensitive (second cbs) + (command-enabled + (car (second (car cbs))) + frame)))) + + + (make-command-for-command-table-1 (mb item) + (let* ((menu-pane (tk::get-values mb :menu-pane)) + (ct (find-command-table (second item))) + (tick (slot-value ct 'clim-internals::menu-tick)) + (commands-and-buttons + (make-menu-for-command-table + ct + menu-pane + nil))) + + (when commands-and-buttons + ;; We might have add-callbacks for a different set + ;; of children which are now destroyed + (let ((shell (do ((widget menu-pane (tk::widget-parent widget))) + ((typep widget 'tk::shell) + widget) + (assert widget)))) + + (setf (tk::widget-create-popup-child-proc shell) + #'(lambda (shell) + (declare (ignore shell)) + (let ((children + (tk::widget-children menu-pane))) + (when (or (null children) + (/= tick + (setq tick + (slot-value ct 'clim-internals::menu-tick)))) + (mapc #'tk::destroy-widget children) + (make-command-for-command-table-1 mb item))))) + + (tk::remove-all-callbacks shell :popup-callback) + (tk::add-callback shell :popup-callback + #'update-menu-item-sensitivity + (pane-frame sheet) + commands-and-buttons))) + + (set-button-mnemonic + sheet mb (getf + (command-menu-item-options item) :mnemonic)))) + + (make-menu-for-command-table (command-table parent top) + (let ((commands-and-buttons nil)) + (map-over-command-table-menu-items + #'(lambda (menu keystroke item) + (let ((type (command-menu-item-type item))) + (case type + (:divider + (unless top + (make-instance 'xt::static-text + :parent parent + :managed nil + :string " "))) + (:function + ;;--- Do this sometime + ) + (:menu + (make-command-for-command-table-1 + (make-instance 'tk::menu-button + :parent parent + :label menu) + item)) + + (t + (let ((button + (make-instance 'tk::oblong-button + :label menu + :managed t + :parent parent))) + (set-button-accelerator-from-keystroke + sheet button keystroke) - (tk::add-callback - button - :select - 'command-button-callback-ol - (slot-value sheet 'silica::frame) - command-table - item)))))) - command-table))) + (set-button-mnemonic + sheet + button (getf (command-menu-item-options item) :mnemonic)) + + (push (list item button) commands-and-buttons) + + (tk::add-callback + button + :select + 'command-button-callback-ol + (slot-value sheet 'silica::frame) + command-table + item)))))) + command-table) + commands-and-buttons))) (make-menu-for-command-table (menu-bar-command-table sheet) mirror @@ -412,7 +468,8 @@ (nv (gadget openlook-text-field) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror gadget) - (setf (text-editor-text (openlook-text-field-edit-widget gadget)) nv))) + (with-no-value-changed-callbacks + (setf (text-editor-text (openlook-text-field-edit-widget gadget)) nv)))) ;;--- We need to implement the activate callback stuff so that when ;;--- the user hits return we invoke the callback. I guess we need to @@ -441,7 +498,8 @@ (nv (gadget openlook-value-pane) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror gadget) - (tk::set-values (sheet-mirror gadget) :value nv))) + (with-no-value-changed-callbacks + (tk::set-values (sheet-mirror gadget) :value nv)))) ;;; @@ -456,14 +514,19 @@ (call-next-method) (with-accessors ((alignment gadget-alignment) (label gadget-label)) sheet - (when label - (unless (getf initargs :label) - (setf (getf initargs :label) label))) - (unless (getf initargs :label-justify) - (setf (getf initargs :label-justify) - (ecase alignment - (:center :left) - ((:left :right) alignment))))) + (typecase label + (string + (unless (getf initargs :label) + (setf (getf initargs :label) label)) + (unless (getf initargs :label-justify) + (setf (getf initargs :label-justify) + (ecase alignment + (:center :left) + ((:left :right) alignment))))) + (xt::pixmap + (unless (getf initargs :label-image) + (setf (getf initargs :label-image) (tk::image-from-pixmap label) + (getf initargs :label-type) :image))))) (values class initargs))) (defmethod (setf gadget-label) :after (nv (sheet openlook-labelled-gadget)) @@ -481,7 +544,6 @@ (defclass openlook-toggle-button (toggle-button openlook-labelled-gadget - openlook-value-pane xt-leaf-pane) ()) @@ -524,7 +586,8 @@ (nv (gadget openlook-toggle-button) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror gadget) - (tk::set-values (sheet-mirror gadget) :set nv))) + (with-no-value-changed-callbacks + (tk::set-values (sheet-mirror gadget) :set nv)))) @@ -555,8 +618,6 @@ (defclass openlook-radio-box (openlook-geometry-manager mirrored-sheet-mixin - #+ignore ;;-- Need to decide - openlook-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin radio-box @@ -570,7 +631,12 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-radio-box)) - (values 'xt::exclusives nil)) + (with-accessors ((orientation gadget-orientation)) sheet + (values 'xt::exclusives + (list :layout-type + (ecase orientation + (:horizontal :fixedrows) + (:vertical :fixedcols)))))) (defmethod value-changed-callback :around ((v gadget) (client openlook-radio-box) @@ -586,22 +652,35 @@ (defmethod compose-space ((rb openlook-radio-box) &key width height) (declare (ignore width height)) - (let ((w 0) - (h 0)) - (dolist (child (tk::widget-children (sheet-direct-mirror rb))) + (compose-space-for-radio/check-box rb)) + +(defun compose-space-for-radio/check-box (rb &optional (spacing 0)) + (let ((sum-w 0) + (max-w 0) + (max-h 0) + (sum-h 0) + (children (tk::widget-children (sheet-direct-mirror rb)))) + (dolist (child children) (multiple-value-bind (ignore-x igore-y width height) (xt::widget-best-geometry child) - (maxf h height) - (incf w width))) - (make-space-requirement :width w :height h))) + (declare (ignore ignore-x igore-y)) + (maxf max-h height) + (incf sum-w width) + (incf sum-h height) + (maxf max-w width))) + (case (gadget-orientation rb) + (:horizontal (make-space-requirement + :width (+ sum-w (* spacing (1- (length children)))) + :height max-h)) + (:vertical (make-space-requirement + :width max-w + :height (+ sum-h (* spacing (1- (length children))))))))) ;;; (defclass openlook-check-box (openlook-geometry-manager mirrored-sheet-mixin - #+Dunno ;;--- what do do about tihs - openlook-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin check-box @@ -616,7 +695,12 @@ (parent t) (sheet openlook-check-box)) - (values 'xt::nonexclusives nil)) + (with-accessors ((orientation gadget-orientation)) sheet + (values 'xt::nonexclusives + (list :layout-type + (ecase orientation + (:horizontal :fixedrows) + (:vertical :fixedcols)))))) (defmethod value-changed-callback :around ((v gadget) (client openlook-check-box) @@ -634,22 +718,7 @@ (defmethod compose-space ((cb openlook-check-box) &key width height) (declare (ignore width height)) - ;;-- This is a dreadful hack that attempts to second guess that - ;;--- stupid tookit. - (let ((twidth 0) - (theight 0) - (children (tk::widget-children (sheet-direct-mirror cb)))) - (dolist (child children) - (multiple-value-bind - (x y width height borderwidth - care-x care-y care-width care-height care-borderwidth) - (tk::widget-best-geometry child) - (declare (ignore x y borderwidth care-x care-y - care-width care-height care-borderwidth)) - (maxf theight height) - (incf twidth width))) - (make-space-requirement :width (+ twidth (* (1- (length children)) 15)) - :height theight))) + (compose-space-for-radio/check-box cb 15)) ;; @@ -663,13 +732,6 @@ slider) ()) -(defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-slider) (widget t)) - (break "fix me") - (tk::add-callback widget - :drag-callback - 'queue-drag-event - sheet)) - (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-slider)) @@ -703,7 +765,8 @@ (defmethod (setf gadget-value) :after (nv (slider openlook-slider) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror slider) - (set-slider-value slider nv))) + (with-no-value-changed-callbacks + (set-slider-value slider nv)))) (defun compute-slider-value (sheet) (let ((widget (sheet-direct-mirror sheet))) @@ -732,6 +795,9 @@ (defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-slider) (widget t)) + ;;--- Do we need to do this? + #+ignore + (tk::add-callback widget :drag-callback 'queue-drag-event sheet) (tk::add-callback widget :slider-moved 'slider-changed-callback-1 sheet)) (defmethod slider-changed-callback-1 ((widget t) (sheet openlook-slider)) @@ -784,9 +850,6 @@ (let ((widget (sheet-direct-mirror te))) (setf (text-editor-text widget) nv))) -(defmethod (setf text-editor-text) (nv (widget tk::text-edit)) - (setf (text-editor-text widget) nv)) - (defmethod (setf text-editor-text) (nv (widget tk::text-edit)) (assert (not (zerop (tk::ol_text_edit_clear_buffer widget)))) (assert (not (zerop (tk::ol_text_edit_insert widget nv (length nv)))))) @@ -834,7 +897,8 @@ (nv (gadget openlook-text-editor) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror gadget) - (setf (text-editor-text gadget) nv))) + (with-no-value-changed-callbacks + (setf (text-editor-text gadget) nv)))) (defmethod gadget-supplies-scrolling-p ((contents openlook-text-editor)) @@ -1230,4 +1294,29 @@ (let ((item (find nv items :test test :key value-key))) (assert item) (let ((button (find item (option-menu-buttons sheet) :key #'second))) - (tk::set-values button :default t))))) + (with-no-value-changed-callbacks + (tk::set-values button :default t)))))) + +(defmethod set-button-accelerator-from-keystroke ((menubar openlook-menu-bar) button keystroke) + (when keystroke + (record-accelerator menubar keystroke) + (let ((accel (format nil "<~A>" (car keystroke))) + (accel-text (format nil "~A" (car keystroke)))) + (dolist (modifier (cdr keystroke)) + (setq accel-text + (concatenate 'string + (case modifier (:control "Ctrl+") (:meta "Alt+") (t "")) + accel-text)) + (setq accel + (concatenate 'string + (case modifier (:control "c") (:meta "a") (t "")) + accel))) + (tk::set-values button + :accelerator accel + :accelerator-text accel-text)))) + +(defmethod discard-accelerator-event-p ((port openlook-port) event) + ;;-- There are a whole bunch of other keysyms that need to be ignored. + ;;-- Perhaps in OLIT there is a way of getting the actual keysym. + ;;-- Perhaps we need a way of representing them in the clim world + (call-next-method)) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index a9a073256890a309e6bbfc11c94be251d1edc72a..6f93a3e0a2eeb18cdad8fdcdd6cdd3cf6623dda4 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.12 92/07/20 16:01:50 cer Exp $ +;; $fiHeader: ol-silica.lisp,v 1.13 92/08/18 17:54:24 cer Exp $ (in-package :xm-silica) @@ -72,6 +72,8 @@ (defclass openlook-geometry-manager (xt-geometry-manager) ()) +;;--- This looks kinda like to motif-port method. + (defmethod find-shell-class-and-initargs ((port openlook-port) sheet) (declare (ignore port)) (cond ( ;;--- hack alert @@ -89,7 +91,7 @@ (popup parent)) (defmethod disable-xt-mirror ((parent xt::transient-shell) (mirror t)) - (tk::popdown parent)) + (popdown parent)) (defmethod destroy-mirror ((port openlook-port) (sheet mirrored-sheet-mixin)) ;; Only do this if its the top most widget being destroyed or we are diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 611f2baf9f5a0afd9e5822979a77e560cb4eb1d0..9eaccdc009591a12ce1c9f976ac1b0510c056418 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.28 92/09/08 10:35:27 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.29 92/09/08 15:19:15 cer Exp Locker: cer $ (in-package :xm-silica) @@ -123,9 +123,10 @@ :parent parent :label-string menu :sub-menu-id submenu))) - (declare (ignore cb)) - (let ((mnem (getf (command-menu-item-options item) :mnemonic))) - (when mnem (tk::set-values cb :mnemonic mnem))) + + (set-button-mnemonic sheet + cb (getf (command-menu-item-options item) :mnemonic)) + (let* ((ct (find-command-table (second item))) (tick (slot-value ct 'clim-internals::menu-tick))) (make-menu-for-command-table ct submenu nil) @@ -187,10 +188,12 @@ commands-and-buttons) (set-button-accelerator-from-keystroke + sheet button keystroke) - - (let ((mnem (getf (command-menu-item-options item) :mnemonic))) - (when mnem (tk::set-values button :mnemonic mnem))) + + (set-button-mnemonic + sheet + button (getf (command-menu-item-options item) :mnemonic)) (when (getf (command-menu-item-options item) :documentation) (tk::add-callback diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 110013994bdf1620fc3618df00bba10d57bd406f..0602167248c448b04daf45038c1173ae29fbfef8 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.45 92/09/08 10:35:29 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.46 92/09/08 15:19:16 cer Exp Locker: cer $ (in-package :xm-silica) @@ -69,8 +69,8 @@ (declare (ignore invoke-callback)) (let ((m (sheet-direct-mirror gadget))) (when (and m (not (equal nv (tk::get-values m :value)))) - (let ((*dont-invoke-callbacks* t)) - (tk::set-values m :value nv))))) + (with-no-value-changed-callbacks + (tk::set-values m :value nv))))) ;; Gadgets that have a :label initarg @@ -202,30 +202,6 @@ 'sheet-mirror-event-handler sheet)) -#| - -;; Drawing area -;; Who uses this anyway?????????????? - -;; Noone! - -(defclass motif-drawing-area (standard-sheet-input-mixin - permanent-medium-sheet-output-mixin - xt-leaf-pane) - ()) - -(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) - (parent t) - (sheet motif-drawing-area)) - (values 'tk::xm-my-drawing-area (list :margin-width 0 - :resize-policy :none - :margin-height 0))) - -(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget) - ;; Now does nothing - ) -|# - ;;; range pane mixin (defclass motif-range-pane (motif-value-pane) ()) @@ -254,11 +230,11 @@ (multiple-value-bind (mmin mmax) (tk::get-values mirror :minimum :maximum) - (let ((*dont-invoke-callbacks* t)) - (tk::set-values mirror - :value (fix-coordinate - (compute-symmetric-value - smin smax nv mmin mmax))))))))) + (with-no-value-changed-callbacks + (tk::set-values mirror + :value (fix-coordinate + (compute-symmetric-value + smin smax nv mmin mmax))))))))) ;;; @@ -438,8 +414,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass motif-top-level-sheet (top-level-sheet) ()) +(defclass motif-top-level-sheet (xt-top-level-sheet) + ()) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-top-level-sheet) @@ -612,8 +588,8 @@ (declare (ignore invoke-callback)) (let ((m (sheet-direct-mirror gadget))) (when (and m (not (equal nv (tk::get-values m :set)))) - (let ((*dont-invoke-callbacks* t)) - (tk::set-values m :set nv))))) + (with-no-value-changed-callbacks + (tk::set-values m :set nv))))) #+ignore (defmethod add-sheet-callbacks :after ((port motif-port) @@ -923,10 +899,10 @@ (when (sheet-direct-mirror l) (let ((selected-items (compute-list-pane-selected-items l nv))) - (let ((*dont-invoke-callbacks* t)) - (tk::set-values (sheet-direct-mirror l) - :selected-item-count (length selected-items) - :selected-items selected-items))))) + (with-no-value-changed-callbacks + (tk::set-values (sheet-direct-mirror l) + :selected-item-count (length selected-items) + :selected-items selected-items))))) ;;; Option buttons @@ -973,8 +949,8 @@ (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback) (declare (ignore invoke-callback)) - (let ((*dont-invoke-callbacks* t)) - (set-option-menu-value gadget nv))) + (with-no-value-changed-callbacks + (set-option-menu-value gadget nv))) (defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane)) (prog1 (call-next-method) @@ -1465,3 +1441,29 @@ 'sheet-mirror-event-handler sheet)))) +(defmethod discard-accelerator-event-p ((port motif-port) event) + (or (call-next-method) + ;;-- There are a whole bunch of other keysyms that need to be + ;;-- ignored too but there does not appear to be an easy way + ;;-- of going from the osf name to the keysym that we need to ignore + ;;-- osfMenuBar + (member (keyboard-event-key-name event) '(:f10)))) + + +(defmethod set-button-accelerator-from-keystroke ((menubar motif-menu-bar) button keystroke) + (when keystroke + (record-accelerator menubar keystroke) + (let ((accel (format nil "<Key>~A" (car keystroke))) + (accel-text (format nil "~A" (car keystroke)))) + (dolist (modifier (cdr keystroke)) + (setq accel-text + (concatenate 'string + (case modifier (:control "Ctrl+") (:meta "Alt+") (t "")) + accel-text)) + (setq accel + (concatenate 'string + (case modifier (:control "Ctrl") (:meta "Mod1") (t "")) + accel))) + (tk::set-values button + :accelerator accel + :accelerator-text accel-text)))) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 70002a05d809c2141ff46488ad69b84b6c532d4c..44bdcfe130dbd4b12629620a9eb591faa5784e48 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.16 92/08/21 16:34:32 cer Exp Locker: cer $ +;; $fiHeader: xt-frames.lisp,v 1.17 92/09/08 10:35:32 cer Exp Locker: cer $ (in-package :xm-silica) @@ -81,7 +81,7 @@ :sheet (frame-top-level-sheet frame)))) (defmethod handle-event (sheet (event window-manager-delete-event)) - (frame-exit *application-frame*)) + (frame-exit (pane-frame sheet))) ;;; Menu code @@ -173,3 +173,9 @@ (defmethod frame-manager-default-exit-boxes ((framem xt-frame-manager)) '((:exit) (:abort))) + +(defmethod note-frame-iconified ((framem xt-frame-manager) frame) + (tk::set-values (frame-shell frame) :iconic t)) + +(defmethod note-frame-deiconified ((framem xt-frame-manager) frame) + (tk::set-values (frame-shell frame) :iconic nil)) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index c55c25ecff5338cc811f74f03483ff45fed8a04d..57570be30063dcb15fc11baf97ad28b64a8aaf94 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.18 92/08/18 17:26:38 cer Exp Locker: cer $ +;; $fiHeader: xt-gadgets.lisp,v 1.19 92/09/08 10:35:33 cer Exp Locker: cer $ (in-package :xm-silica) @@ -133,6 +133,11 @@ xt-pane) ()) +(defclass xt-top-level-sheet (top-level-sheet) + ((accelerator-gestures :initform nil))) + +(defmethod sheet-disown-child :after ((sheet xt-top-level-sheet) (child sheet)) + (setf (slot-value sheet 'accelerator-gestures) nil)) ;;--- This isn't really right. Genera and CLX ports have kludges @@ -163,21 +168,29 @@ (process-next-event port))) (mp:process-wait whostate predicate))) +(defun set-button-mnemonic (menubar button mnem) + (when mnem + (record-accelerator menubar (list mnem :meta)) + (tk::set-values button :mnemonic mnem))) + +(defun record-accelerator (menubar gesture) + (let ((sheet (frame-top-level-sheet (pane-frame menubar)))) + (push gesture (slot-value sheet 'accelerator-gestures)))) + +(defmethod distribute-event ((port xt-port) (event keyboard-event)) + (unless (discard-accelerator-event-p port event) + (call-next-method))) + +(defmethod discard-accelerator-event-p ((port xt-port) event) + (let ((frame (pane-frame (event-sheet event)))) + (and frame + (some #'(lambda (gesture) + (clim-internals::keyboard-event-matches-gesture-name-p event gesture port)) + (slot-value (frame-top-level-sheet frame) 'accelerator-gestures))))) + + + + + -(defun set-button-accelerator-from-keystroke (button keystroke) - (when keystroke - (let ((accel (format nil "<Key>~A" (car keystroke))) - (accel-text (format nil "~A" (car keystroke)))) - (dolist (modifier (cdr keystroke)) - (setq accel-text - (concatenate 'string - (case modifier (:control "Ctrl+") (:meta "Alt+") (t "")) - accel-text)) - (setq accel - (concatenate 'string - (case modifier (:control "Ctrl") (:meta "Mod1") (t "")) - accel))) - (tk::set-values button - :accelerator accel - :accelerator-text accel-text)))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index bf0b7877e8e63e65e5fe6bf995ed79f375d48a42..d4bbc53e0e12cc5c312721f43a035edfefeb2c61 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.37 92/09/08 15:19:18 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.38 92/09/09 11:45:00 cer Exp Locker: cer $ (in-package :tk-silica) @@ -117,9 +117,12 @@ (tk::widget-window mirror nil)) (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet) - (with-slots (foreground-gcontext background-gcontext flipping-gcontext color-p + (with-slots (foreground-gcontext background-gcontext + flipping-gcontext color-p + indirect-inks drawable tile-gcontext white-pixel black-pixel clip-mask) medium + (setf indirect-inks nil) (setf clip-mask nil) (setf (medium-sheet medium) sheet) (when (and drawable @@ -155,7 +158,7 @@ (declare (ignore sheet)) (with-slots (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext - drawable) + ink-table drawable) medium (setf drawable nil (medium-sheet medium) nil) @@ -163,9 +166,11 @@ `(when ,gc (tk::free-gcontext ,gc) (setf ,gc nil)))) - ;;-- Do we actually need to do this or cant we save them until - ;;-- the next time around. Also, what about all those gc's in - ;;-- the ink-table etc etc. + (maphash #'(lambda (ink gc) + (declare (ignore ink)) + (tk::free-gcontext gc)) + ink-table) + (clrhash ink-table) (loose-gc foreground-gcontext) (loose-gc background-gcontext) (loose-gc flipping-gcontext) @@ -1174,6 +1179,7 @@ and on color servers, unless using white or black") :height n)) (gc (make-instance 'fast-gcontext :drawable pixmap + :font font :foreground 1 :background 0))) ;; Draw all the characters diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 0459352a835d14dde1cfcc508e92b398d9d91107..0fba2ac32d3bac68b358a43f7f3cd3b8a723bea6 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.43 92/09/08 15:19:22 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.44 92/09/09 11:45:06 cer Exp Locker: cer $ (in-package :xm-silica) @@ -37,7 +37,9 @@ :reader port-event-lock) (rotated-font-cache :initform nil :accessor port-rotated-font-cache) (depth :accessor port-depth) - (visual-class :accessor port-visual-class)) + (visual-class :accessor port-visual-class) + (cursor-font :initform nil) + (cursor-cache :initform nil)) (:default-initargs :allow-loose-text-style-size-mapping t) (:documentation "The port for X intrinsics based ports")) @@ -389,25 +391,47 @@ (:key-press (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-press-event - :sheet sheet - :key-name keysym - :character character - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil))))) + (let ((keysym-shift-mask + (if (typep keysym 'silica::modifier-keysym) + (make-modifier-state + (case keysym + ((:left-shift :right-shift) :shift) + ((:left-control :right-control) :control) + ((:left-meta :right-meta) :meta) + ((:left-super :right-super) :super) + ((:left-hyper :right-hyper) :hyper))) + 0))) + (allocate-event 'key-press-event + :sheet sheet + :key-name keysym + :character character + :modifier-state + (setf (port-modifier-state port) + (logior + (state->modifiers (x11::xkeyevent-state event)) + keysym-shift-mask)))))) (:key-release (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-release-event - :sheet sheet - :key-name keysym - :character character - :modifier-state - (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil))))) + (let ((keysym-shift-mask + (if (typep keysym 'silica::modifier-keysym) + (make-modifier-state + (case keysym + ((:left-shift :right-shift) :shift) + ((:left-control :right-control) :control) + ((:left-meta :right-meta) :meta) + ((:left-super :right-super) :super) + ((:left-hyper :right-hyper) :hyper))) + 0))) + (allocate-event 'key-release-event + :sheet sheet + :key-name keysym + :character character + :modifier-state + (setf (port-modifier-state port) + (logandc2 + (state->modifiers (x11::xkeyevent-state event)) + keysym-shift-mask)))))) (:button-press (let ((button (x-button->silica-button (x11::xbuttonevent-button event))) @@ -515,7 +539,9 @@ ;; This isn't really the right place to do this, but it's better than ;; in ensure-blinker-for-cursor. (let ((window (tk::widget-window widget))) - (setf (xt::window-backing-store window) t)) + (unless (getf (window-property-list window) 'backing-store-on) + (setf (getf (window-property-list window) 'backing-store-on) t + (xt::window-backing-store window) t))) (let* ((minx (x11::xexposeevent-x event)) (miny (x11::xexposeevent-y event)) (width (x11::xexposeevent-width event)) @@ -536,32 +562,57 @@ (defmethod sheet-mirror-input-callback (widget window event sheet) (declare (ignore window)) - (let ((port (port sheet))) - (ecase (tk::event-type event) - (:key-press - (distribute-event - port - (multiple-value-bind (character keysym) - (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-press-event - :sheet sheet - :key-name keysym - :character character - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil)))))) - (:key-release + (let ((port (port sheet)) + (event-key (tk::event-type event))) + (ecase event-key + ((:key-press :key-release) (distribute-event port (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) - (allocate-event 'key-release-event - :sheet sheet - :key-name keysym - :character character - :modifier-state (setf (port-modifier-state port) - (state->modifiers - (x11::xkeyevent-state event) nil)))))) + (let* ((keysym-shift-mask + (if (typep keysym 'silica::modifier-keysym) + (make-modifier-state + (case keysym + ((:left-shift :right-shift) :shift) + ((:left-control :right-control) :control) + ((:left-meta :right-meta) :meta) + ((:left-super :right-super) :super) + ((:left-hyper :right-hyper) :hyper))) + 0)) + (modifier-state + (if (eq event-key :key-press) + (logior (state->modifiers (x11::xkeyevent-state event)) + keysym-shift-mask) + (logandc2 (state->modifiers (x11::xkeyevent-state event)) + keysym-shift-mask))) + ;;-- Canonicalize the only interesting key right here. + ;;-- If we get a key labelled "Return", we canonicalize it + ;;-- into #\Newline. + ;;-- This may be misguided, but it'll almost certainly help us + ;;-- in the short run. + ;;-- This code copied from clx-mirror. + ;;-- This seems to break stuff. + ;;-- It fails because newline is a standard-character + ;;-- and so the event is #\newline which + ;;-- port-canonicalize-gesture does not know what to + ;;-- do with. It returns NIL. In comparision #\return + ;;-- is nonstandard so no one gets confused. + (char (cond #+this-does-not-work + ((and (eq keysym ':return) + (or (zerop modifier-state) + (= modifier-state + (make-modifier-state :shift)))) + #\Newline) + (t character)))) + (setf (port-modifier-state port) modifier-state) + (allocate-event (if (eq event-key :key-press) + 'key-press-event + 'key-release-event) + :sheet sheet + :key-name keysym + :character char + :modifier-state modifier-state))))) (:button-press (let ((button (x-button->silica-button (x11::xbuttonevent-button event))) @@ -675,25 +726,60 @@ `(:allow-shell-resize ,(clim-internals::frame-resizable (pane-frame sheet)) ,@initargs)))) -(defmethod enable-mirror ((port xt-port) sheet) +(defmethod enable-mirror ((port xt-port) (sheet t)) (let ((mirror (sheet-mirror sheet))) (enable-xt-widget (widget-parent mirror) mirror))) -(defmethod enable-xt-widget ((parent t) (mirror t)) +(defmethod enable-xt-widget ((parent t) mirror) (unless (xt::is-managed-p mirror) (manage-child mirror))) +;(defmethod enable-mirror ((port xt-port) (sheet top-level-sheet)) +; (let* ((mirror (sheet-mirror sheet)) +; (parent (widget-parent mirror))) +; (manage-child mirror) +; (xt:realize-widget parent) ; Make sure widget is realized. +; (let ((ussp (slot-value sheet 'silica::user-specified-size-p)) +; (uspp (slot-value sheet 'silica::user-specified-position-p))) +; (unless (and (eq ussp :unspecified) +; (eq uspp :unspecified)) +; (let* ((window (tk::widget-window parent)) +; (display (tk::widget-display parent)) +; (size-hints (x11::xallocsizehints))) +; (tk::with-ref-par ((supplied 0)) +; (when (zerop +; (x11::xgetwmnormalhints display window size-hints supplied)) +; (warn "top-level-sheet had no size hints?!") +; (return-from enable-mirror)) +; (let ((flags (x11::xsizehints-flags size-hints))) +; (if* (and uspp (not (eq uspp :unspecified))) +; then (setf flags (logior flags x11::uspositionhint)) +; elseif (null uspp) +; then (setf flags (logandc2 flags x11::uspositionhint))) +; (if* (and ussp (not (eq ussp :unspecified))) +; then (setf flags (logior flags x11::ussizehint)) +; elseif (null ussp) +; then (setf flags (logandc2 flags x11::ussizehint))) +; (setf (x11::xsizehints-flags size-hints) flags)) +; (x11::xsetwmnormalhints display window size-hints))))) +; (popup parent))) + +;(defmethod enable-xt-widget ((parent top-level-shell) mirror) +; (manage-child mirror) +; (popup (widget-parent mirror))) + (defmethod disable-mirror ((port xt-port) sheet) (declare (ignore port)) (let ((mirror (sheet-mirror sheet))) (when mirror (disable-xt-mirror (widget-parent mirror) mirror)))) -(defmethod disable-xt-mirror ((parent t) (mirror t)) +(defmethod disable-xt-mirror ((parent t) mirror) (tk::unmanage-child mirror)) -(defmethod disable-xt-mirror ((parent top-level-shell) (mirror t)) - (tk::popdown parent)) +(defmethod disable-xt-mirror ((parent top-level-shell) mirror) + (declare (ignore mirror)) + (popdown parent)) (defmethod realize-graft ((port xt-port) graft) ;; Set the width etc etc @@ -797,7 +883,7 @@ (multiple-value-setq (mask reason) (tk::wait-for-event context :wait-function wait-function - :timeout timeout)) + :timeout 0)) (tk::process-one-event context mask reason)))))) @@ -978,6 +1064,8 @@ (define-xt-keysym (keysym 255 008) :backspace) (define-xt-keysym (keysym 009 227) :page) (define-xt-keysym (keysym 255 010) :linefeed) +;;;--- +(define-xt-keysym (keysym 255 010) :newline) (define-xt-keysym (keysym 255 027) :escape) ;; Other useful characters @@ -989,6 +1077,23 @@ (define-xt-keysym (keysym 255 097) :refresh) (define-xt-keysym (keysym 255 011) :clear-input) +;;; + + +;;; Some nonstandard keys + +(define-xt-keysym (keysym 255 #xb3) :f1) +(define-xt-keysym (keysym 255 #xbf) :f2) +(define-xt-keysym (keysym 255 #xc0) :f3) +(define-xt-keysym (keysym 255 #xc1) :f4) +(define-xt-keysym (keysym 255 #xc2) :f5) +(define-xt-keysym (keysym 255 #xc3) :f6) +(define-xt-keysym (keysym 255 #xc4) :f7) +(define-xt-keysym (keysym 255 #xc5) :f8) +(define-xt-keysym (keysym 255 #xc6) :f9) +(define-xt-keysym (keysym 255 #xc7) :f10) + + ;; Finally, the shifts ;; snarfed from translate.cl @@ -1020,6 +1125,7 @@ (define-xt-keysym left-hyper-keysym :left-hyper) (define-xt-keysym right-hyper-keysym :right-hyper) +;;; (defun lookup-character-and-keysym (sheet mirror event) (declare (ignore sheet mirror) (optimize (speed 3) (safety 0))) @@ -1065,11 +1171,11 @@ (values character (xt-keysym->keysym keysym)))) -(defun state->modifiers (x &optional (shift-it t)) +(defun state->modifiers (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (logior - (if (and shift-it (logtest x x11:shiftmask)) +shift-key+ 0) + (if (logtest x x11:shiftmask) +shift-key+ 0) (if (logtest x x11:controlmask) +control-key+ 0) (if (logtest x x11:mod1mask) +meta-key+ 0) (if (logtest x x11:mod2mask) +super-key+ 0) @@ -1178,7 +1284,16 @@ the geometry of the children. Instead the parent has control. ")) ;;--- Surely if a sheet is mirrored then you do not need to ;;--- invalidate any caches below that point nil) - + +#+ignore +(defmethod initialize-mirror :after ((port xt-port) + (parent xt-geometry-manager) + (parent-widget t) + (sheet t) + (widget t)) + ;; A bogus attempt to get the initial sheet-region right. + (sheet-mirror-resized-callback nil nil nil sheet)) + ;; Instead if the geometry of the parent has changed, I guess this ;; suggests that the children have changed shape and that we need to @@ -1228,6 +1343,10 @@ the geometry of the children. Instead the parent has control. ")) (defvar *dont-invoke-callbacks* nil) +(defmacro with-no-value-changed-callbacks (&body body) + `(let ((*dont-invoke-callbacks* t)) + ,@body)) + (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet))) (declare (ignore widget)) (unless *dont-invoke-callbacks* @@ -1266,21 +1385,28 @@ the geometry of the children. Instead the parent has control. ")) (defmethod port-canonicalize-gesture-spec - ((port xt-port) gesture-spec &optional modifier-state) + ((port xt-port) gesture-spec &optional modifier-state) (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (keysym shifts) (if modifier-state (values gesture-spec modifier-state) - (parse-gesture-spec gesture-spec)) + (parse-gesture-spec gesture-spec)) ;; Here, we must take the gesture spec, turn it back into ;; a keycode, then see what the keysyms are for that keycode - (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) - (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) - (keysym->xt-keysym keysym))) + (let ((x-keysym + (if (characterp keysym) + (case keysym + (#\newline (keysym->xt-keysym :newline)) + (#\tab (keysym->xt-keysym :tab)) + (#\rubout (keysym->xt-keysym :rubout)) + (#\return (keysym->xt-keysym :return)) + (t (and (standard-char-p keysym) + (keysym->xt-keysym (xt-keysym->keysym (char-code keysym)))))) + (keysym->xt-keysym keysym))) (x-keycode nil)) (unless x-keysym (return-from port-canonicalize-gesture-spec nil)) - (cons keysym shifts)))) + (cons (xt-keysym->keysym x-keysym) shifts)))) @@ -1300,6 +1426,23 @@ the geometry of the children. Instead the parent has control. ")) (fix-coordinate y))))) + +(defmethod raise-mirror ((port xt-port) sheet) + (x11:xraisewindow (port-display port) (tk::widget-window (sheet-mirror sheet)))) + +(defmethod raise-mirror ((port xt-port) (sheet top-level-sheet)) + ;; Compensate for the top-level-sheet's mirror not being the right window. + (x11:xraisewindow (port-display port) + (tk::widget-window (tk::widget-parent (sheet-mirror sheet))))) + +(defmethod bury-mirror ((port xt-port) sheet) + (x11:xlowerwindow (port-display port) (tk::widget-window (sheet-mirror sheet)))) + +(defmethod bury-mirror ((port xt-port) (sheet top-level-sheet)) + ;; Compensate for the top-level-sheet's mirror not being the right window. + (x11:xlowerwindow (port-display port) + (tk::widget-window (tk::widget-parent (sheet-mirror sheet))))) + (defmethod enable-mirror ((port xt-port) (sheet top-level-sheet)) (let* ((mirror (sheet-mirror sheet)) (parent (widget-parent mirror))) @@ -1333,3 +1476,138 @@ the geometry of the children. Instead the parent has control. ")) (defmethod enable-xt-widget ((parent top-level-shell) (mirror t)) (manage-child mirror) (popup (widget-parent mirror))) + + +(defmethod mirror-visible-p ((port xt-port) sheet) + (let ((mirror (sheet-mirror sheet))) + ;;--- This costs a round trip to the display server. A better + ;;--- scheme would be to have the map/unmap-notify set a flag + ;;--- that we could simply read here, as in CLIM 1.1 + ;;--- What does unviewable mean? + (not (eq (tk::window-map-state (tk::widget-window mirror)) :unmapped)))) + +;;;---- Cursor stuff + +(defvar *clx-cursor-type-alist* + '((:default 132) + (:vertical-scroll 116) + (:scroll-up 114) + (:scroll-down 106) + (:horizontal-scroll 108) + (:scroll-left 110) + (:scroll-right 112) + (:busy 150) + (:upper-left 134) + (:upper-right 136) + (:lower-left 12) + (:lower-right 14) + (:vertical-thumb 112) + (:horizontal-thumb 114) + (:button 132) + (:prompt 92) + (:move 52) + (:position 34))) + + + +(defmethod port-set-pointer-cursor ((port xt-port) pointer cursor) + (unless (eq (pointer-cursor pointer) cursor) + (let* ((cursor (and cursor (realize-cursor port cursor))) + (widget (sheet-direct-mirror (frame-top-level-sheet + (pane-frame (pointer-sheet pointer))))) + (window (tk::widget-window widget nil))) + (when window + (if cursor + (x11:xdefinecursor + (port-display port) window cursor) + (x11:xundefinecursor + (port-display port) window)) + (port-force-output port))) + cursor)) + + +(defmethod port-set-sheet-pointer-cursor ((port xt-port) sheet cursor) + (unless (eq (silica::sheet-pointer-cursor sheet) cursor) + (let* ((cursor (and cursor (realize-cursor port cursor))) + (widget (sheet-mirror sheet)) + (window (tk::widget-window widget nil))) + (when window + (if cursor + (x11:xdefinecursor + (port-display port) window cursor) + (x11:xundefinecursor + (port-display port) window)) + (port-force-output port)))) + cursor) + +(defmethod realize-cursor :around ((port xt-port) cursor) + (with-slots (cursor-cache) port + (or (getf cursor-cache cursor) + (setf (getf cursor-cache cursor) + (call-next-method))))) + +(defmethod realize-cursor ((port xt-port) (cursor symbol)) + (let ((cursor (or (second (assoc cursor *clx-cursor-type-alist*)) + 132))) + (realize-cursor port cursor))) + +(defmethod realize-cursor ((port xt-port) (cursor number)) + (x11:xcreatefontcursor + (port-display port) + cursor)) + + +(defvar *pointer-grabbed* nil) + + +(defmethod port-invoke-with-pointer-grabbed ((port xt-port) (sheet sheet) continuation + &key + confine-to cursor + (ungrab-on-error t)) + (let ((widget (sheet-mirror sheet))) + (unwind-protect + (progn + (tk::xt_grab_pointer + widget + ;;---- Are these parameters correct???? + 0 ; owner-events + (xt-grabbed-event-mask) + ; Event-mask + x11:grabmodeasync ; pointer-grab-mode + x11:grabmodeasync ; keyboard + (if confine-to widget 0) ; confine to + (if cursor (realize-cursor port cursor) 0) + 0 ; current-time + ) + (handler-bind ((error #'(lambda (condition) + (declare (ignore condition)) + (when ungrab-on-error + (tk::xt_ungrab_pointer + widget 0))))) + (let ((*pointer-grabbed* t)) + (funcall continuation)))) + (tk::xt_ungrab_pointer widget 0)))) + +(defun xt-grabbed-event-mask () + (tk::encode-event-mask '(:enter-window + :leave-window + :pointer-motion-hint + :pointer-motion + :button-motion + :button-press + :button-release + ))) + +(defmethod port-set-sheet-grabbed-pointer-cursor ((port xt-port) + sheet + cursor) + (when *pointer-grabbed* + (x11::xchangeactivepointergrab + (port-display port) + (xt-grabbed-event-mask) ; event-mask + (if cursor (realize-cursor port cursor) 0) + 0 ; time + ))) + + + diff --git a/tk/event.lisp b/tk/event.lisp index c9c3562e55072c4078003ffc37a339f0eecc0276..469c5b0a5de7290feaa06294760ffb64b12bf5fd 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.11 92/08/19 10:23:32 cer Exp $ +;; $fiHeader: event.lisp,v 1.12 92/09/08 15:16:21 cer Exp Locker: cer $ (in-package :tk) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index d4298fa49cae7544d3bde51830f8d536ecf40666..411d9b952722c388430665a22c5cbd0db458f568 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.16 92/08/21 16:33:32 cer Exp Locker: cer $ +;; $fiHeader: load-ol.lisp,v 1.17 92/09/08 10:34:03 cer Exp Locker: cer $ (in-package :user) @@ -28,9 +28,10 @@ (require :climg) (defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") +(defvar sys::*clim-olit-pathname* "clim-olit.o") (x11::load-undefined-symbols-from-library - "clim-olit.o" + sys::*clim-olit-pathname* (x11::symbols-from-file "misc/undefinedsymbols.olit") (list sys::*libxt-pathname* sys::*libx11-pathname*)) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index 38f5f3223cda52edb8db0f0c9a92a8419633a30d..48cc9f7bac5565c0da48f49bba22b249eda84e61 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.19 92/08/19 10:23:34 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.20 92/09/08 10:34:04 cer Exp Locker: cer $ (in-package :user) @@ -28,10 +28,12 @@ (require :climg) ;;;; + (defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a") +(defvar sys::*clim-motif-pathname* "clim-motif.o") (x11::load-undefined-symbols-from-library - "clim-motif.o" + sys::*clim-motif-pathname* (x11::symbols-from-file "misc/undefinedsymbols.motif") (list sys::*libxt-pathname* sys::*libx11-pathname*)) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index 5ddd12c3b72b7acf8534f16c4c80e5216e0f81dc..d5681995981b89c0cebfb9d06ad138452d62e0bb 100644 --- a/tk/pkg.lisp +++ b/tk/pkg.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.11 92/07/27 19:29:16 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.12 92/08/18 17:53:43 cer Exp $ (defpackage :tk ;;-- No we really need @@ -35,6 +35,7 @@ #:get-values #:top-level-shell #:popup + #:popdown #:manage-child #:realize-widget #:card32 @@ -46,5 +47,6 @@ #:int16 #:int8 #:with-server-grabbed + #:window-property-list )) diff --git a/tk/resources.lisp b/tk/resources.lisp index ebb399392cff7c69e89de9ffe38b0377b6e7bcee..ce7ad7825f4bf30dfbafeb7a05b1b756eaa82984 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.30 92/09/08 10:34:05 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.31 92/09/08 15:16:25 cer Exp Locker: cer $ (in-package :tk) @@ -611,3 +611,12 @@ (defmethod convert-resource-in ((parent t) (typep (eql 'key-sym)) value) (cltl1:int-char value)) + + +;; Openlook + +(defmethod convert-resource-out ((parent t) (typep (eql 'char)) value) + (char-int value)) + +(defmethod convert-resource-in ((parent t) (typep (eql 'char)) value) + (cltl1:int-char value)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index c905fac4ef48517ec23d156326ac414c28623370..23c87f1c7a57d25722bfe3525459b938b8ca49c8 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.25 92/09/08 10:34:08 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.26 92/09/09 11:44:28 cer Exp Locker: cer $ (in-package :tk) @@ -48,7 +48,8 @@ (defclass drawable (display-object) ()) -(defclass window (drawable) ()) +(defclass window (drawable) + ((plist :accessor window-property-list :initform nil))) (eval-when (compile load eval) (defconstant *window-set-attributes-bit-mask* @@ -131,6 +132,8 @@ (define-window-reader depth) (define-window-reader map-state decode-window-map-state) +(define-window-accessor cursor nil) + (defun decode-window-map-state (x) (declare (optimize (speed 3) (safety 0))) (ecase x @@ -310,6 +313,9 @@ (object-display colormap) colormap y))) + ;;-- This needs to be handled intelligently + ;;-- Perhaps the colormap code should enable the user to + ;;-- intercept this or we should just resort to some kind of stippling (when (zerop z) (error "Could not allocate color: ~S" x)) (values (x11:xcolor-pixel y) @@ -446,6 +452,7 @@ (defun event-type (event) + (declare (optimize (speed 3) (safety 0))) (elt *event-types* (x11::xevent-type event))) (defun encode-event-mask (mask) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 349849639ccbfdbb8e7cf1a54f5b1373a73d1ece..0144c62168962a25ea973547cb5ec6535688105e 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.10 92/08/19 10:23:37 cer Exp $ +;; $fiHeader: xt-funs.lisp,v 1.11 92/09/08 15:16:27 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -290,6 +290,28 @@ :arguments '(foreign-address fixnum) :arg-checking nil :return-type :void) - +(defforeign 'xt_grab_pointer + :entry-point "_XtGrabPointer" + :call-direct t + :arguments '(foreign-address ; display + foreign-address ; widget + fixnum ; owner + fixnum ; pgrabmode + fixnum ; kgrabmode + foreign-address ; confine to + foreign-address ; cursor + fixnum ; time + ) + :arg-checking nil + :return-type :fixnum) + +(defforeign 'xt_ungrab_pointer + :entry-point "_XtUngrabPointer" + :call-direct t + :arguments '(foreign-address ; display + fixnum ; time + ) + :arg-checking nil + :return-type :fixnum) diff --git a/utils/packages.lisp b/utils/packages.lisp index cbcbcb46e9b0702e247e15a4923f71c5cf10147b..23aeb5dec4588d1be1a30d6b025b006e6bb9b2b7 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.26 92/09/08 10:34:27 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.27 92/09/08 15:17:07 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1853,6 +1853,7 @@ sheet-ancestor-p sheet-child sheet-children + sheet-cursor sheet-delta-transformation sheet-device-region sheet-device-transformation @@ -1861,6 +1862,7 @@ sheet-enabled-children sheet-enabled-p sheet-event-queue + sheet-grabbed-pointer-cursor sheet-grafted-p sheet-identity-transformation-mixin sheet-leaf-mixin @@ -1873,6 +1875,7 @@ sheet-native-transformation sheet-occluding-sheets sheet-parent + sheet-pointer-cursor sheet-region sheet-siblings sheet-single-child-mixin @@ -1925,6 +1928,7 @@ with-drawing-options with-first-quadrant-coordinates with-local-coordinates + with-pointer-grabbed with-rotation with-scaling with-translation @@ -2587,6 +2591,7 @@ application-frame application-frame-p application-pane + bury-frame client-setting command-enabled command-menu-pane @@ -2642,7 +2647,9 @@ note-command-disabled note-command-enabled note-frame-disabled + note-frame-deiconified note-frame-enabled + note-frame-iconified notify-user pane-frame pane-name @@ -2651,6 +2658,7 @@ pointer-documentation-pane position-sheet-carefully position-sheet-near-pointer + raise-frame read-frame-command reconfigure-frame redisplay-frame-pane @@ -3499,12 +3507,16 @@ port-graft-class port-grafts port-invalidate-gesture-specs + port-invoke-with-pointer-grabbed port-mirror->sheet-table port-note-cursor-change port-note-gadget-activated port-note-gadget-deactivated port-process + port-set-pointer-cursor port-set-pointer-position + port-set-sheet-pointer-cursor + port-set-sheet-grabbed-pointer-cursor port-trace-thing port-undefined-text-style process-event-locally