From 3c273fc0787c4e5dfe96222e26ce6dc1d4f9a322 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Fri, 22 May 1992 19:29:39 +0000 Subject: [PATCH] miscfixes --- Makefile | 24 +- clim/accept-values.lisp | 406 +++++++++++++------------ clim/basic-translators.lisp | 4 +- clim/command-processor.lisp | 4 +- clim/command.lisp | 17 +- clim/cursor.lisp | 8 +- clim/db-stream.lisp | 165 +++++------ clim/drag-and-drop.lisp | 5 +- clim/frames.lisp | 323 ++++++++++---------- clim/gadget-output.lisp | 294 +++++++++--------- clim/gestures.lisp | 104 +++++-- clim/graph-formatting.lisp | 15 +- clim/graphics-recording.lisp | 215 ++++++-------- clim/incremental-redisplay.lisp | 6 +- clim/input-editor-commands.lisp | 35 ++- clim/input-protocol.lisp | 138 ++------- clim/interactive-defs.lisp | 21 +- clim/interactive-protocol.lisp | 57 ++-- clim/item-list-manager.lisp | 6 +- clim/menus.lisp | 147 ++------- clim/noting-progress.lisp | 6 + clim/output-protocol.lisp | 232 ++++++--------- clim/pixmap-streams.lisp | 22 +- clim/presentations.lisp | 25 +- clim/ptypes1.lisp | 12 +- clim/ptypes2.lisp | 8 +- clim/recording-protocol.lisp | 109 +------ clim/stream-class-defs.lisp | 23 +- clim/stream-defprotocols.lisp | 100 +------ clim/table-formatting.lisp | 11 +- clim/text-recording.lisp | 210 ++++++------- clim/tracking-pointer.lisp | 99 +++---- clim/view-defs.lisp | 4 +- clim/window-stream.lisp | 140 +-------- clx/clx-frames.lisp | 34 ++- clx/clx-medium.lisp | 159 ++++++---- clx/clx-mirror.lisp | 7 +- clx/clx-port.lisp | 9 +- demo/address-book.lisp | 10 +- demo/cad-demo.lisp | 4 +- demo/demo-driver.lisp | 14 +- demo/graphics-demos.lisp | 19 +- demo/listener.lisp | 33 +-- demo/navfun.lisp | 4 +- demo/puzzle.lisp | 4 +- demo/sysdcl.lisp | 4 +- demo/thinkadot.lisp | 4 +- genera/genera-frames.lisp | 122 +++++++- genera/genera-medium.lisp | 167 +++++++---- genera/genera-mirror.lisp | 8 +- genera/genera-port.lisp | 14 +- instclimol.lisp | 7 +- instclimxm.lisp | 6 +- misc/compile-1.lisp | 10 +- misc/dev-load-1.lisp | 10 +- silica/classes.lisp | 5 +- silica/db-box.lisp | 107 ++++--- silica/db-button.lisp | 106 +++---- silica/db-layout.lisp | 230 +++++++-------- silica/db-scroll.lisp | 327 ++++++++++----------- silica/db-slider.lisp | 40 +-- silica/event.lisp | 91 +++--- silica/framem.lisp | 49 ++- silica/gadgets.lisp | 239 ++++++++------- silica/graphics.lisp | 230 ++++++--------- silica/layout.lisp | 29 +- silica/medium.lisp | 5 +- silica/mirror.lisp | 36 +-- silica/port.lisp | 7 +- silica/protocols.lisp | 4 +- silica/sheet.lisp | 31 +- sys/defsystem.lisp | 42 +-- sys/sysdcl.lisp | 125 +++----- test/chess.lisp | 98 +++--- test/test-suite.lisp | 25 +- test/test.lisp | 474 +++++++++++++++--------------- tk-silica/ol-frames.lisp | 150 +++++++++- tk-silica/ol-gadgets.lisp | 387 +++++++++++++++++++++--- tk-silica/ol-silica.lisp | 53 +++- tk-silica/xm-frames.lisp | 232 +++++++++------ tk-silica/xm-gadgets.lisp | 154 +++++----- tk-silica/xm-menus.lisp | 213 +------------- tk-silica/xm-silica.lisp | 48 +-- tk-silica/xt-frames.lisp | 130 +++++++- tk-silica/xt-gadgets.lisp | 22 +- tk-silica/xt-graphics.lisp | 37 +-- tk-silica/xt-silica.lisp | 164 +++++++---- tk/callbacks.lisp | 3 +- tk/event.lisp | 5 +- tk/font.lisp | 5 +- tk/foreign.lisp | 22 +- tk/gcontext.lisp | 8 +- tk/load-ol.lisp | 12 +- tk/load-xm.lisp | 19 +- tk/make-classes.lisp | 2 +- tk/ol-callbacks.lisp | 17 +- tk/ol-defs.lisp | 5 +- tk/ol-funs.lisp | 8 +- tk/ol-init.lisp | 3 +- tk/resources.lisp | 10 +- tk/widget.lisp | 17 +- tk/xlib.lisp | 28 +- tk/xt-funs.lisp | 2 +- tk/xt-init.lisp | 3 +- utils/autoconstructor.lisp | 6 +- utils/cl-stream-classes.lisp | 3 +- utils/clos.lisp | 6 +- utils/defpackage.lisp | 4 +- utils/defun.lisp | 6 +- utils/excl-verification.lisp | 7 +- utils/lisp-package-fixups.lisp | 13 +- utils/lucid-stream-functions.lisp | 16 +- utils/packages.lisp | 72 +++-- utils/reader.lisp | 4 +- utils/regions.lisp | 6 +- xlib/ffi.lisp | 3 +- xlib/load-xlib.lisp | 9 +- xlib/pkg.lisp | 2 +- xlib/x11-keysyms.lisp | 6 +- 119 files changed, 3932 insertions(+), 3934 deletions(-) diff --git a/Makefile b/Makefile index 316a0d4d..d77e260e 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.28 92/05/13 17:11:04 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.29 92/05/13 17:16:09 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -7,8 +7,9 @@ DUMP-CL = $(CL) CLOPTS = -qq # Training -TRAIN_LISP= (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \ +TRAIN_LISP= (load \"tk-silica/test-clim.lisp\") \ (clim-user::train-clim-2) \ + (compile-file "misc/clos-preload.cl") \ (exit 0) TRAIN_TEXT = \ @@ -36,7 +37,7 @@ NEWSPACE = 5000000 CLIM = ./slim CLIM-SMALL = ./slim-small -PUBDIRS = sys utils silica clim demo test genera clx +PUBDIRS = sys utils silica clim demo test genera clx pre-silica DIRS0 = tk tk-silica misc DIRS = $(PUBDIRS) xlib $(DIRS0) CHEAP_CLEAN = $(PUBDIRS) $(DIRS0) @@ -98,10 +99,8 @@ FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o ` # DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \ xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl \ - tk/xt-defs.fasl tk/xm-defs.fasl + tk/xt-defs.fasl tk/xm-defs.fasl tk/ol-defs.fasl -# This should be in the clim-debug file but it seems a pain to have to compile it up -# tk/ol-defs.fasl # # "Load time objects" -- these go into clim.fasl @@ -194,8 +193,10 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/command-processor.fasl \ clim/basic-translators.fasl \ clim/frames.fasl \ + clim/noting-progress.fasl \ clim/menus.fasl \ clim/accept-values.fasl \ + clim/drag-and-drop.fasl \ clim/item-list-manager.fasl \ clim/pixmap-streams.fasl \ clim/stream-trampolines.fasl @@ -239,6 +240,7 @@ OL-CLIM-OBJS = tk/ol-classes.fasl \ tk/xt-funs.fasl \ tk/ol-funs.fasl \ tk/ol-init.fasl \ + tk/ol-widgets.fasl \ tk/ol-callbacks.fasl \ tk/make-widget.fasl @@ -339,6 +341,16 @@ clim-debug.fasl: $(DEBUG-OBJS) ls -lt clim-debug.fasl >> Clim-sizes.n ls -lt clim-debug.fasl +# We should only run these rules when +# We do this because we because we might have only compiled one port + +tk/xm-defs.fasl : tk/xm-defs.lisp + echo Foo + +tk/ol-defs.fasl : tk/ol-defs.lisp + echo Bar + + # Building clim-xm: FORCE diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index d2d1d530..3e8fbc79 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.19 92/05/06 15:37:34 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.20 92/05/07 13:11:54 cer Exp $ (in-package :clim-internals) @@ -106,10 +106,10 @@ (defmethod find-or-add-query ((stream accept-values-stream) query-identifier ptype prompt default default-supplied-p active-p) (let ((avv-record - #-ignore (slot-value stream 'avv-record) - #+ignore (find-accept-values-record - (or (stream-current-output-record stream) - (stream-output-history stream))))) + #---ignore (slot-value stream 'avv-record) + #+++ignore (find-accept-values-record + (or (stream-current-output-record stream) + (stream-output-history stream))))) (with-slots (query-table) avv-record (multiple-value-bind (query found-p) (gethash query-identifier query-table) @@ -145,7 +145,8 @@ :history ptype :present-p `(accept-values-choice ,query) :query-identifier query)) - ((and found-p (presentation-typep (accept-values-query-value query) ptype)) + ((and found-p + (presentation-typep (accept-values-query-value query) ptype)) ;; The programmer supplied no default, but a previous edit ;; has put something in the query that we now must use as ;; the default. @@ -168,40 +169,55 @@ (setf (gethash query-identifier query-table) query)) query)))) +;;--- These frames should be resourced (define-application-frame accept-values () ((stream :initarg :stream) (exit-button-stream :initarg :exit-button-stream) (continuation :initarg :continuation) - (own-window :initform nil :initarg :own-window) - (own-window-x-position :initform nil :initarg :x-position) - (own-window-y-position :initform nil :initarg :y-position) - (own-window-width :initform nil :initarg :width) - (own-window-height :initform nil :initarg :height) - (own-window-right-margin :initform nil :initarg :right-margin) - (own-window-bottom-margin :initform nil :initarg :bottom-margin) (exit-boxes :initform nil :initarg :exit-boxes) (selected-item :initform nil) ;;--- Do this through RUN-FRAME-TOP-LEVEL? (initially-select-query-identifier :initform nil :initarg :initially-select-query-identifier) (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass) - (check-overlapping :initform t :initarg :check-overlapping)) + (check-overlapping :initform t :initarg :check-overlapping) + (own-window :initform nil :initarg :own-window)) (:top-level (accept-values-top-level)) (:command-definer t)) +;; Ignore extra initargs... +(defmethod initialize-instance :after ((frame accept-values) + &key own-window + x-position y-position width height + right-margin bottom-margin) + (declare (ignore own-window + x-position y-position width height + right-margin bottom-margin))) + +#+what-the-\! +(defmethod frame-top-level-sheet ((frame accept-values)) + (frame-top-level-sheet (frame-calling-frame frame))) + +;;--- These frames should be resourced (define-application-frame accept-values-own-window (accept-values) - () + ((own-window :initarg :own-window) + (own-window-x-position :initform nil :initarg :x-position) + (own-window-y-position :initform nil :initarg :y-position) + (own-window-width :initform nil :initarg :width) + (own-window-height :initform nil :initarg :height) + (own-window-right-margin :initform nil :initarg :right-margin) + (own-window-bottom-margin :initform nil :initarg :bottom-margin)) (:pane - (with-slots (stream own-window exit-button-stream) *application-frame* + (with-slots (stream own-window exit-button-stream) *application-frame* (vertically () (outlining () (scrolling (:scroll-bars :dynamic) (progn (setq stream (make-instance 'accept-values-stream - :stream (setf own-window - (make-pane 'clim-stream-pane - :initial-cursor-visibility nil)))) + :stream (setf own-window + (make-pane 'clim-stream-pane + :initial-cursor-visibility nil)))) own-window))) (outlining () (setf exit-button-stream @@ -215,68 +231,15 @@ ;; So the continuation can run with the proper value of *APPLICATION-FRAME* (defvar *avv-calling-frame*) -#-Silica -(defun invoke-accepting-values (stream continuation - &key frame-class own-window exit-boxes - (initially-select-query-identifier nil) - (resynchronize-every-pass nil) (check-overlapping t) - label x-position y-position width height) - (incf *accept-values-tick*) - (let ((*current-accept-values-tick* *accept-values-tick*) - (the-own-window nil) - (right-margin 10) - (bottom-margin 10)) - (unwind-protect - (progn - (when own-window - (setq the-own-window - (allocate-resource 'menu stream (window-root stream))) - ;;--- make the window big. We shouldn't have to do this. - (multiple-value-bind (width height) - (window-inside-size (slot-value the-own-window 'parent)) - (bounding-rectangle-set-size the-own-window width height)) - (setf (window-label the-own-window) label) - (when (listp own-window) - (setf right-margin - (process-spacing-arg the-own-window (getf own-window :right-margin 10) - 'accepting-values :right-margin)) - (setf bottom-margin - (process-spacing-arg the-own-window (getf own-window :bottom-margin 10) - 'accepting-values :bottom-margin)))) - - (using-resource (avv-stream accept-values-stream (or the-own-window stream)) - ;;--- This should resource the AVV application frame, too - (let ((frame - (make-application-frame 'accept-values - :parent (slot-value avv-stream 'stream) - :frame-class frame-class - :stream avv-stream - :exit-boxes exit-boxes - :continuation continuation - :own-window the-own-window - :x-position x-position - :y-position y-position - :width width :height height - :right-margin right-margin - :bottom-margin bottom-margin - :initially-select-query-identifier - initially-select-query-identifier - :resynchronize-every-pass - resynchronize-every-pass - :check-overlapping check-overlapping))) - (when (frame-top-level-sheet frame) - (window-expose (frame-top-level-sheet frame))) - ;; Run the AVV and return its values - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame))))) - (when (and the-own-window (windowp the-own-window)) - ;; Deallocate menu resources deexposes them for us - (deallocate-resource 'menu the-own-window))))) - -#+Silica +(defmethod frame-manager-default-exit-boxes ((framem standard-frame-manager)) + '((:abort) (:exit))) + (defun invoke-accepting-values (stream continuation - &key frame-class own-window - exit-boxes (resize-frame nil) + &key frame-class own-window + (exit-boxes + (frame-manager-default-exit-boxes + (frame-manager stream))) + (resize-frame t) (initially-select-query-identifier nil) (resynchronize-every-pass nil) (check-overlapping t) label x-position y-position width height) @@ -288,13 +251,11 @@ (if own-window (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) :calling-frame *application-frame* - :parent - *application-frame* + :parent *application-frame* :pretty-name label :continuation continuation :exit-boxes exit-boxes :own-window the-own-window - :pretty-name label :width width :height height :x-position x-position :y-position y-position @@ -303,12 +264,12 @@ :initially-select-query-identifier initially-select-query-identifier :resynchronize-every-pass - resynchronize-every-pass - :resize-frame resize-frame + resynchronize-every-pass :check-overlapping - check-overlapping))) - ;; What do we do about sizing????? - ;; What do we do about positioning???? + check-overlapping + :resize-frame resize-frame))) + ;;--- What do we do about sizing? + ;;--- What do we do about positioning? (let ((*avv-calling-frame* *application-frame*)) (run-frame-top-level frame))) (using-resource (avv-stream accept-values-stream (or the-own-window stream)) @@ -318,11 +279,6 @@ :stream avv-stream :continuation continuation :exit-boxes exit-boxes - :own-window the-own-window - :x-position x-position - :y-position y-position - :right-margin right-margin - :bottom-margin bottom-margin :initially-select-query-identifier initially-select-query-identifier :resynchronize-every-pass @@ -344,48 +300,55 @@ own-window-width own-window-height own-window-right-margin own-window-bottom-margin exit-button-stream) frame - (let ((command-table (frame-command-table frame)) - (original-view (stream-default-view stream)) - (return-values nil) - (initial-query nil) - exit-button-record - avv avv-record) + (let* ((command-table (frame-command-table frame)) + (original-view (stream-default-view stream)) + (return-values nil) + (initial-query nil) + exit-button-record + avv avv-record + (help-window nil) + (*accept-help-displayer* + (if own-window + #'(lambda (function stream &rest args) + (declare (dynamic-extent args)) + (setq help-window (apply #'display-own-window-help + function help-window own-window stream args))) + *accept-help-displayer*))) (letf-globally (((stream-default-view stream) - (port-dialog-view (port stream)))) + (frame-manager-dialog-view (frame-manager frame)))) (labels ((run-continuation (stream avv-record) - (setf (slot-value stream 'avv-record) avv-record) - (setf (slot-value stream 'avv-frame) frame) - (with-output-recording-options (stream :draw nil :record t) - (setq return-values (multiple-value-list - (let ((*application-frame* *avv-calling-frame*)) - (funcall continuation stream)))) - (unless own-window - (display-exit-boxes frame stream - (stream-default-view stream))))) - (run-avv () - (when (and initially-select-query-identifier - (setq initial-query - (find-query avv-record initially-select-query-identifier))) - (com-edit-avv-choice initial-query) - (redisplay avv stream :check-overlapping check-overlapping)) - (loop - (when (frame-resizable frame) - (size-panes-appropriately)) - (let ((command - (let ((command-stream (slot-value stream 'stream))) - ;; While we're reading commands, restore the view - ;; to what it was before we started. - (letf-globally (((stream-default-view command-stream) - original-view)) - (read-command command-table - :stream command-stream - :command-parser 'menu-command-parser - :use-keystrokes t))))) - (if (and command (not (keyboard-event-p command))) - (execute-frame-command frame command) + (setf (slot-value stream 'avv-record) avv-record) + (setf (slot-value stream 'avv-frame) frame) + (with-output-recording-options (stream :draw nil :record t) + (setq return-values (multiple-value-list + (let ((*application-frame* *avv-calling-frame*)) + (funcall continuation stream)))) + (unless own-window + (display-exit-boxes frame stream + (stream-default-view stream))))) + (run-avv () + (when (and initially-select-query-identifier + (setq initial-query + (find-query avv-record initially-select-query-identifier))) + (com-edit-avv-choice initial-query) + (redisplay avv stream :check-overlapping check-overlapping)) + (loop + (let ((command + (let ((command-stream (slot-value stream 'stream))) + ;; While we're reading commands, restore the view + ;; to what it was before we started. + (letf-globally (((stream-default-view command-stream) + original-view)) + (read-command command-table + :stream command-stream + :command-parser 'menu-command-parser + :use-keystrokes t))))) + (if (and command (not (keyboard-event-p command))) + (execute-frame-command frame command) (beep stream))) - (with-defered-gadget-updates - (when (or resynchronize-every-pass (slot-value avv-record 'resynchronize)) + (with-deferred-gadget-updates + (when (or resynchronize-every-pass + (slot-value avv-record 'resynchronize)) ;; When the user has asked to resynchronize every pass, that ;; means we should run the continuation an extra time to see ;; that all visible stuff is up to date. That's all! @@ -393,26 +356,29 @@ (redisplay avv stream :check-overlapping check-overlapping))) (setf (slot-value avv-record 'resynchronize) nil) (when exit-button-record - (redisplay exit-button-record exit-button-stream)) + (redisplay exit-button-record exit-button-stream)) (redisplay avv stream :check-overlapping - check-overlapping)))) + check-overlapping)) + (when (frame-resizable frame) + (size-panes-appropriately)))) (size-panes-appropriately () (changing-space-requirements () - ;; We really want to specify the min/max sizes of - ;; the exit-button pane also - (size-menu-appropriately - exit-button-stream - :size-fn - #'(lambda (pane w h) - (change-space-requirements pane - :width w :min-width w :max-width w - :height h :min-height h :max-height h))) - (size-menu-appropriately own-window - :width own-window-width - :height own-window-height - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin)))) - (declare (dynamic-extent #'run-continuation #'run-avv)) + ;; We really want to specify the min/max sizes of + ;; the exit-button pane also + (size-menu-appropriately exit-button-stream + :size-setter + #'(lambda (pane w h) + (change-space-requirements pane + :width w :min-width w :max-width w + :height h :min-height h :max-height h))) + (when own-window + (size-menu-appropriately own-window + :width own-window-width + :height own-window-height + :right-margin own-window-right-margin + :bottom-margin own-window-bottom-margin))))) + (declare (dynamic-extent #'run-continuation #'run-avv + #'size-panes-appropriately)) (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog") (setq avv (updating-output (stream) @@ -434,11 +400,8 @@ (cond (own-window (size-panes-appropriately) (multiple-value-bind (x y) - #-Silica - (stream-pointer-position-in-window-coordinates - (window-parent own-window)) - #+Silica - (values 500 500) + #+++ignore (pointer-position (port-pointer (port own-window))) + #---ignore (values 100 100) (when (and own-window-x-position own-window-y-position) (setq x own-window-x-position y own-window-y-position)) @@ -455,6 +418,8 @@ (stream-ensure-cursor-visible stream) (replay avv stream) (run-avv))) + (when help-window + (deallocate-resource 'menu help-window)) (unless own-window (move-cursor-beyond-output-record (slot-value stream 'stream) avv)))) (values-list return-values)))))) @@ -476,36 +441,64 @@ :right-margin own-window-right-margin :bottom-margin own-window-bottom-margin))))))) +(defun display-own-window-help (function stream near-window original-stream &rest args) + (declare (values help-window)) + (declare (dynamic-extent args)) + (if stream + (setf (window-visibility stream) nil) + (setq stream (allocate-resource 'menu original-stream (window-root original-stream)))) + (let ((*original-stream* nil) ;--- reset *INPUT-CONTEXT*, too? + (*accept-help-displayer* 'funcall)) + (window-clear stream) + (with-output-recording-options (stream :draw t :record t) + (with-end-of-line-action (stream :allow) + (with-end-of-page-action (stream :allow) + (apply function stream args) + (fresh-line stream) + (with-text-face (stream :italic) + (write-line "Press any key to remove this window" stream))))) + (size-menu-appropriately stream) + (when near-window + (multiple-value-bind (x y) (bounding-rectangle-position near-window) + (position-window-near-carefully stream x y))) + (window-expose stream) + (clear-input stream) + (unwind-protect + (read-gesture :stream stream) + (setf (window-visibility stream) nil))) + stream) + + (define-presentation-type accept-values-exit-box ()) ;;; Applications can create their own AVV class and specialize this method in ;;; order to get different exit boxes. + +(defmethod frame-manager-exit-box-labels ((frame t) (framem standard-frame-manager)) + '( + (:exit "<End> uses these values") + (:abort "<Abort> aborts"))) + (defmethod display-exit-boxes ((frame accept-values) stream (view view)) ;; Do the fresh-line *outside* of the updating-output so that it ;; doesn't get repositioned relatively in the X direction if the ;; previous line gets longer. Maybe there should be some better ;; way of ensuring this. (fresh-line stream) - (with-slots (exit-boxes) frame - (let ((exit (or (second (assoc :exit exit-boxes)) "<End> uses these values")) - (abort (or (second (assoc :abort exit-boxes)) "<Abort> aborts"))) - (updating-output (stream :unique-id stream - :cache-value 'exit-boxes) - (with-output-as-presentation (stream ':abort 'accept-values-exit-box) - #-CCL-2 (write-string abort stream) - ;; Kludge to print the cloverleaf char in MCL. - ;; Needs an accompanying kludge in STREAM-WRITE-CHAR so that - ;; #\CommandMark doesn't get lozenged. - #+CCL-2 (progn - (with-text-style (stream '(:mac-menu :roman :normal)) - (write-char #\CommandMark stream)) - (write-string "-. aborts" stream))) - (write-string ", " stream) - (with-output-as-presentation (stream ':done 'accept-values-exit-box) - (write-string exit stream)))))) + (let ((labels (frame-manager-exit-box-labels frame (frame-manager frame)))) + (updating-output (stream :unique-id stream :cache-value 'exit-boxes) + (with-slots (exit-boxes) frame + (dolist (exit-box exit-boxes) + (let* ((name (if (consp exit-box) (car exit-box) exit-box)) + (label (or (if (consp exit-box) (second exit-box)) + (second (assoc name labels))))) + (with-output-as-presentation (stream name 'accept-values-exit-box) + ;;--- :ccl-2 had some code in here + (write-string label stream)))))))) + ;;--- Get this right -(defmethod frame-pointer-documentation-output ((frame accept-values)) +(defmethod frame-pointer-documentation-output ((frame accept-values-own-window)) nil) @@ -905,8 +898,7 @@ (defun accept-values-pane-displayer (frame pane &key displayer resynchronize-every-pass (check-overlapping t)) - (let* ((stream-and-record (and #-Silica (not *frame-layout-changing-p*) - (gethash pane *pane-to-avv-stream-table*))) + (let* ((stream-and-record (and (gethash pane *pane-to-avv-stream-table*))) (avv-stream (car stream-and-record)) (avv-record (cdr stream-and-record))) (cond (avv-stream @@ -981,8 +973,7 @@ (pane 't)) (funcall (slot-value button 'continuation)) (when (slot-value button 'resynchronize) - (let* ((stream-and-record (and #-Silica (not *frame-layout-changing-p*) - (gethash pane *pane-to-avv-stream-table*))) + (let* ((stream-and-record (and (gethash pane *pane-to-avv-stream-table*))) (avv-stream (car stream-and-record)) (avv-record (cdr stream-and-record))) (when avv-stream @@ -1033,7 +1024,7 @@ :scroll-bars nil :initial-cursor-visibility :off)) -#-silica +#-Silica (defmethod size-frame-pane ((window window-mixin) (frame standard-application-frame) (type (eql :accept-values)) @@ -1068,31 +1059,32 @@ (defmethod display-exit-boxes ((frame accept-values) stream (view gadget-dialog-view)) (fresh-line stream) - (with-slots (exit-boxes) frame - (let ((exit (or (second (assoc :exit exit-boxes)) "<End> uses these values")) - (abort (or (second (assoc :abort exit-boxes)) "<Abort> aborts"))) + (let ((labels (frame-manager-exit-box-labels frame (frame-manager frame)))) + (with-slots (exit-boxes) frame (updating-output (stream :unique-id stream :cache-value 'exit-boxes) - (formatting-item-list (stream :n-columns 2 :initial-spacing nil) - (formatting-cell (stream) - (with-output-as-gadget (stream) - (make-pane 'push-button - :label abort - :client frame :id :abort - :activate-callback - #'(lambda (gadget) - (declare (ignore gadget)) - (com-abort-avv))))) - (formatting-cell (stream) - (with-output-as-gadget (stream) - (make-pane 'push-button - :label exit - :client frame :id :exit - :activate-callback - #'(lambda (gadget) - (declare (ignore gadget)) - (com-exit-avv)))))))))) - + (formatting-item-list (stream :n-columns (length exit-boxes) + :initial-spacing nil) + (dolist (exit-box exit-boxes) + (let* ((name (if (consp exit-box) (car exit-box) exit-box)) + (label (or (if (consp exit-box) (second exit-box)) + (second (assoc name labels))))) + (formatting-cell (stream) + (with-output-as-gadget (stream) + (make-pane 'push-button + :label label + :client frame :id name + :activate-callback + #'invoke-avv-gadget-action)))))))))) + +(defun invoke-avv-gadget-action (gadget) + (let ((id (gadget-id gadget))) + (case id + (:exit (com-exit-avv)) + (:abort (com-abort-avv)) + (t (funcall id))))) + + ;; It's OK that this is only in the ACCEPT-VALUES command table because ;; we're going to execute it manually in the callbacks below (define-command (com-change-query :command-table accept-values) @@ -1102,22 +1094,21 @@ (setf value new-value changed-p t))) -(defmethod accept-values-value-changed-callback (gadget new-value stream query) - (declare (ignore gadget)) +(defmethod accept-values-value-changed-callback ((gadget value-gadget) new-value stream query) (when (accept-values-query-valid-p query (accept-values-query-presentation query)) ;; Only call the callback if the query is still valid (do-avv-command new-value stream query))) -(defun make-accept-values-value-changed-callback (stream query) - ;; We attach a callback function directly now - `(,#'accept-values-value-changed-callback ,stream ,query)) - (defmethod accept-values-value-changed-callback ((gadget radio-box) new-value stream query-id) (call-next-method gadget (gadget-id new-value) stream query-id)) -(defmethod accept-values-value-changed-callback ((gadget silica::check-box) new-value stream query-id) +(defmethod accept-values-value-changed-callback ((gadget check-box) new-value stream query-id) (call-next-method gadget (mapcar #'gadget-id new-value) stream query-id)) +(defun make-accept-values-value-changed-callback (stream query) + ;; We attach a callback function directly now + `(,#'accept-values-value-changed-callback ,stream ,query)) + (defun do-avv-command (new-value client query) (throw-highlighted-presentation (make-instance 'standard-presentation @@ -1170,3 +1161,4 @@ :y 0 :modifiers 0 :button +pointer-left-button+))))))))) + diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index 15532910..d40f99f7 100644 --- a/clim/basic-translators.lisp +++ b/clim/basic-translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: basic-translators.lisp,v 1.4 92/03/04 16:21:08 cer Exp $ +;; $fiHeader: basic-translators.lisp,v 1.5 92/04/15 11:46:06 cer Exp $ (in-package :clim-internals) @@ -185,7 +185,7 @@ (print-possibility possibility stream))))))) (declare (dynamic-extent #'print-possibility #'menu-choose-body)) (with-menu (menu window) - #-Silica (setf (window-label menu) "Menu of completions") + (setf (window-label menu) "Menu of completions") (with-end-of-line-action (menu :allow) (let ((object (menu-choose-from-drawer menu type #'menu-choose-body))) diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index b9fffe54..fcebd6c1 100644 --- a/clim/command-processor.lisp +++ b/clim/command-processor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command-processor.lisp,v 1.6 92/03/24 19:37:45 cer Exp $ +;; $fiHeader: command-processor.lisp,v 1.7 92/04/15 11:46:13 cer Exp $ (in-package :clim-internals) @@ -156,7 +156,7 @@ ;; There must be a value following, no? (funcall delimiter-parser stream :args))) -#+ignore ;this is slow and useless, don't bother +#+++ignore ;this is slow and useless, don't bother (defun build-command (command-name &rest partial-command-args) (declare (dynamic-extent partial-command-args)) (flet ((arg-parser (&rest args) diff --git a/clim/command.lisp b/clim/command.lisp index c21baab1..5e4a0cd3 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.7 92/04/15 11:46:15 cer Exp $ +;; $fiHeader: command.lisp,v 1.8 92/05/07 13:12:02 cer Exp $ (in-package :clim-internals) @@ -532,9 +532,11 @@ (extract-command-menu-item-value item t))) (text-style (getf (command-menu-item-options item) :text-style))) (flet ((body (stream) - (if keystroke - (format stream "~A (~C)" menu keystroke) - (format stream "~A" menu)) + (format stream "~A" menu) + (when keystroke + (write-string "(" stream) + (describe-gesture-spec keystroke :stream stream) + (write-string ")" stream)) (when (eq type ':menu) (write-string " >" stream)))) (declare (dynamic-extent #'body)) @@ -556,10 +558,9 @@ (initial-spacing t) move-cursor) (unless (or max-width max-height) (multiple-value-bind (width height) - #+Silica (bounding-rectangle-size (sheet-region stream)) - #-Silica (window-inside-size stream) - (unless max-width (setf max-width width)) - (unless max-height (setf max-height height)))) + (bounding-rectangle-size (sheet-region stream)) + (unless max-width (setf max-width width)) + (unless max-height (setf max-height height)))) (let ((menu (slot-value (find-command-table command-table) 'menu))) (if (zerop (count-if #'(lambda (x) (not (null (first x)))) menu)) (with-text-face (stream :italic) diff --git a/clim/cursor.lisp b/clim/cursor.lisp index 3367ed7d..f02a517e 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cursor.lisp,v 1.9 92/04/15 11:46:20 cer Exp $ +;; $fiHeader: cursor.lisp,v 1.10 92/05/07 13:12:07 cer Exp $ (in-package :clim-internals) @@ -32,7 +32,7 @@ ;;--- The positions here should be a COORDINATE pair, no? (defclass text-cursor - (cursor #+Silica region) + (cursor region) ;--- why REGION? ((x :initarg :x :type coordinate) (y :initarg :y :type coordinate) (stream :initarg :stream) @@ -224,9 +224,9 @@ (defmethod cursor-visibility ((cursor cursor)) (cursor-active cursor)) -(defmethod (setf cursor-visibility) (nv (cursor cursor)) +(defmethod (setf cursor-visibility) (visibility (cursor cursor)) (setf (cursor-active cursor) - (case nv + (case visibility (:off nil) ((nil) nil) ((t :on) t)))) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index b6bf5a91..e42054eb 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved. ;;; -;; $fiHeader: db-stream.lisp,v 1.16 92/05/07 13:12:08 cer Exp Locker: cer $ +;; $fiHeader: db-stream.lisp,v 1.17 92/05/12 18:24:56 cer Exp Locker: cer $ (in-package :clim-internals) @@ -33,6 +33,8 @@ ;;--- How to keep PANE-BACKGROUND/FOREGROUND in sync with the medium? ;;--- I'm not convinced that including WINDOW-STREAM here is right... +;;--- Note the this allows you to specify default text style, but it +;;--- doesn't pass it along to the medium, so it has no effect. (defclass clim-stream-sheet (window-stream ;includes output recording sheet-permanently-enabled-mixin @@ -101,6 +103,10 @@ :reader pane-display-time :initarg :display-time :initform :command-loop :type (member nil :command-loop t)))) + +(defmethod initialize-instance :after + ((pane clim-stream-pane) &key &allow-other-keys) + (setf (sheet-transformation pane) +identity-transformation+)) (defmethod pane-needs-redisplay ((pane clim-stream-pane)) (with-slots (display-time) pane @@ -111,140 +117,131 @@ (defmethod pane-needs-redisplay ((pane pane)) nil) -(defmethod initialize-instance :after - ((pane clim-stream-pane) &key &allow-other-keys) - (setf (sheet-transformation pane) +identity-transformation+)) - -;;-- Althought the unit options are mostly applicable here I guess -;;-- other classes might want to use it also -;;-- Perhaps we add a compose-space method on pane which does this. -;;-- Perhaps the class hierarchy needs a big sort out - +;;--- Although the unit options are mostly applicable here I guess +;;--- other classes might want to use it also. +;;--- Perhaps we add a COMPOSE-SPACE method on pane which does this. +;;--- Perhaps the class hierarchy needs a big sort out. (defmacro with-space-requirement ((sr &rest vars) &body body) ;; A handy macro that makes it slightly easy to manipulate space requirements (unless vars (setq vars '(sr-width sr-min-width sr-max-width sr-height sr-min-height sr-max-height))) - `(multiple-value-bind - ,vars + `(multiple-value-bind ,vars (space-requirement-components ,sr) (macrolet ((do-with-space-req-components (operator var vars &body body) - `(,operator - ,@(mapcar #'(lambda (a-var) - `(symbol-macrolet ((,var ,a-var)) - ,@body)) - vars))) + `(,operator + ,@(mapcar #'(lambda (a-var) + `(symbol-macrolet ((,var ,a-var)) + ,@body)) + vars))) (make-sr () `,'(make-space-requirement - ,@(mapcan #'list '(:width :min-width :max-width - :height :min-height :max-height) - vars)))) + ,@(mapcan #'list '(:width :min-width :max-width + :height :min-height :max-height) + vars)))) ,@body))) (defmethod compose-space ((pane clim-stream-pane) &key width height) (let ((sr (call-next-method))) (labels ((process-compute-space-requirements () (with-space-requirement (sr) - (when (do-with-space-req-components - or sr-component - (sr-width sr-min-width - sr-max-width sr-height - sr-min-height sr-max-height) - (eq sr-component :compute)) + (when (do-with-space-req-components or + sr-component + (sr-width sr-min-width sr-max-width + sr-height sr-min-height sr-max-height) + (eq sr-component :compute)) (multiple-value-bind (width height) (let ((record - (with-output-to-output-record (pane) - (invoke-pane-redisplay-function - (pane-frame pane) pane - ;;--- Are all pane display functions prepared to - ;;--- ignore these arguments? I think not... - :max-width width - :max-height height)))) + (with-output-to-output-record (pane) + (invoke-pane-redisplay-function + (pane-frame pane) pane + ;;--- Are all pane display functions prepared to + ;;--- ignore these arguments? I think not... + :max-width width + :max-height height)))) (bounding-rectangle-size record)) - (do-with-space-req-components - progn sr-component (sr-width sr-min-width sr-max-width) - (when (eq sr-component :compute) (setq sr-component width))) - (do-with-space-req-components - progn sr-component (sr-height sr-min-height sr-max-height) - (when (eq sr-component :compute) (setq sr-component height)))) + (do-with-space-req-components progn + sr-component (sr-width sr-min-width sr-max-width) + (when (eq sr-component :compute) + (setq sr-component width))) + (do-with-space-req-components progn + sr-component (sr-height sr-min-height sr-max-height) + (when (eq sr-component :compute) + (setq sr-component height)))) (setq sr (make-sr))))) (process-unit-space-requirements () (with-space-requirement (sr) (let ((changed nil)) - (do-with-space-req-components - progn sr-component - (sr-width sr-min-width - sr-max-width sr-height - sr-min-height sr-max-height) - (when (unit-space-requirement-p sr-component) - (setq sr-component - (process-unit-space-requirement pane sr-component) - changed t))) + (do-with-space-req-components progn + sr-component + (sr-width sr-min-width sr-max-width + sr-height sr-min-height sr-max-height) + (when (unit-space-requirement-p sr-component) + (setq sr-component (process-unit-space-requirement pane sr-component) + changed t))) (when changed (setq sr (make-sr)))))) (process-relative-space-requirements () (with-space-requirement (sr) (unless (and (numberp sr-width) (numberp sr-height) - (do-with-space-req-components - and sr-component - ( sr-min-width - sr-max-width - sr-min-height - sr-max-height) - (or (numberp sr-component) - (relative-space-requirement-p - sr-component)))) + (do-with-space-req-components and + sr-component + (sr-min-width sr-max-width + sr-min-height sr-max-height) + (or (numberp sr-component) + (relative-space-requirement-p sr-component)))) (error "Illegal space requirement ~S" sr)) (let ((changed nil)) (when (relative-space-requirement-p sr-min-width) - (setq sr-min-width (- sr-width - (process-unit-space-requirement pane (car sr-min-width))) + (setq sr-min-width (- sr-width (process-unit-space-requirement + pane (car sr-min-width))) changed t)) (when (relative-space-requirement-p sr-max-width) - (setq sr-max-width (+ sr-width - (process-unit-space-requirement pane (car sr-max-width))) + (setq sr-max-width (+ sr-width (process-unit-space-requirement + pane (car sr-max-width))) changed t)) (when (relative-space-requirement-p sr-min-height) - (setq sr-min-height (- sr-height - (process-unit-space-requirement pane (car sr-min-height))) + (setq sr-min-height (- sr-height (process-unit-space-requirement + pane (car sr-min-height))) changed t)) (when (relative-space-requirement-p sr-max-height) - (setq sr-max-height (+ sr-height - (process-unit-space-requirement pane (car sr-max-height))) + (setq sr-max-height (+ sr-height (process-unit-space-requirement + pane (car sr-max-height))) changed t)) (when changed (setq sr (make-sr))))))) + (declare (dynamic-extent #'process-compute-space-requirements + #'process-unit-space-requirements + #'process-relative-space-requirements)) (process-compute-space-requirements) (process-unit-space-requirements) (process-relative-space-requirements) sr))) - (defun relative-space-requirement-p (sr) (and (consp sr) (= (length sr) 2) (or (numberp (second sr)) (unit-space-requirement-p (second sr))))) - (defun unit-space-requirement-p (sr) (and (consp sr) (= (length sr) 2) (member (second sr) '(:line :character :mm :point :pixel)))) (defun process-unit-space-requirement (pane sr) - (destructuring-bind - (number unit) sr + (destructuring-bind (number unit) sr (let ((graft (graft pane))) (ecase unit (:pixel number) - (:mm (* number (/ (silica::graft-pixel-width graft) (silica::graft-mm-width graft)))) + (:mm (* number (/ (silica::graft-pixel-width graft) + (silica::graft-mm-width graft)))) (:point (* number (silica::graft-pixels-per-point graft))) (:character (* number (stream-string-width pane "M"))) (:line (+ (* number (stream-line-height pane)) (* (1- number) (stream-vertical-spacing pane)))))))) -#+ignore +#+++ignore (defmethod note-sheet-grafted :after ((pane clim-stream-pane)) (let ((xform (sheet-transformation pane))) (setq xform (make-scaling-transformation 1 -1)) @@ -254,7 +251,7 @@ ;;; CLIM-STREAM-PANE is a child of the old-style viewport. It shouldn't ;;; get called under the new viewport scheme. -#+ignore +#+++ignore (defmethod allocate-space :after ((pane clim-stream-pane) width height) (declare (ignore width height)) (ecase (graft-origin (graft pane)) @@ -265,10 +262,10 @@ ;; --- stream-panes ALWAYS have to have a parent to manage the ;; viewport clipping, etc. (setq xform (compose-transformations - xform - (make-translation-transformation - 0 (1- (bounding-rectangle-height - (sheet-parent pane)))))) + xform + (make-translation-transformation + 0 (1- (bounding-rectangle-height + (sheet-parent pane)))))) (setf (sheet-transformation pane) xform))))) (defmethod pane-stream ((pane clim-stream-pane)) @@ -277,7 +274,7 @@ 'pane-stream pane)) pane) -#+ignore +#+++ignore (defmethod update-region ((pane clim-stream-pane) width height &key no-repaint &allow-other-keys) (when (pane-scroller pane) @@ -296,13 +293,13 @@ (multiple-value-bind (history-width history-height) (if (stream-current-output-record pane) (bounding-rectangle-size (stream-current-output-record pane)) - (values width height)) + (values width height)) ;; Don't ever shrink down smaller than our contents. (if (and (numberp width) (numberp height)) (apply #'call-next-method pane :width (max width history-width) - :height (max height history-height) keys) - (call-next-method)))) + :height (max height history-height) keys) + (call-next-method)))) (defclass interactor-pane (clim-stream-pane) ()) @@ -387,8 +384,7 @@ (defmethod window-erase-viewport ((stream window-stream)) (with-sheet-medium (medium stream) (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* (or (pane-viewport stream) stream)) + medium (bounding-rectangle* (or (pane-viewport stream) stream)) :ink +background-ink+))) (defmethod window-expose ((stream clim-stream-sheet)) @@ -398,8 +394,8 @@ (defmethod (setf window-label) (label (stream clim-stream-sheet)) nil) -(defmethod (setf window-visibility) (nv (stream clim-stream-sheet)) - (if nv +(defmethod (setf window-visibility) (visibility (stream clim-stream-sheet)) + (if visibility (enable-frame (pane-frame stream)) (disable-frame (pane-frame stream)))) @@ -422,7 +418,6 @@ (defmethod window-set-inside-size ((stream clim-stream-sheet) width height) (change-space-requirements stream :width width :height height :resize-frame t)) - (defun-inline window-parent (window) (sheet-parent window)) diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp index 763850a6..6567b2a1 100644 --- a/clim/drag-and-drop.lisp +++ b/clim/drag-and-drop.lisp @@ -2,6 +2,8 @@ (in-package :clim-internals) +;;; $fiHeader$ + "Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved." @@ -168,7 +170,8 @@ (declare (dynamic-extent #'find-translator)) (macrolet ((feedback (x y state) `(funcall feedback frame from-presentation window - initial-x initial-y ,x ,y ,state)) + + initial-x initial-y ,x ,y ,state)) (highlight (presentation state) `(when ,presentation (funcall highlighting frame ,presentation window diff --git a/clim/frames.lisp b/clim/frames.lisp index 9b5964fc..b3d4691d 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.20 92/05/12 18:24:58 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.21 92/05/13 17:10:54 cer Exp Locker: cer $ (in-package :clim-internals) @@ -14,43 +14,43 @@ ;;--- processes can queue up requests. This queue should be managed ;;--- like other event queues. It can contains "command" events, too. (defclass standard-application-frame (application-frame) - ;;--- Is it right for these to be SHEET accessors?? - ((name :initarg :name :accessor frame-name) - (pretty-name :initarg :pretty-name :accessor frame-pretty-name) - (command-table :initarg :command-table - :initform (find-command-table 'user-command-table) - :accessor frame-command-table) - (disabled-commands :initarg :disabled-commands :initform nil) - ;; One of T, NIL, or a command-table; used by the menu-bar - (menu-bar :initarg :menu-bar :initform nil) - (histories :initform nil) - (frame-manager :reader frame-manager) - (calling-frame :reader frame-calling-frame :initarg :calling-frame) - ;; PANES is the description of all of the named panes, - ;; ALL-PANES is an alist that stores all of the named panes that - ;; have actually been realized so far - (panes :initarg :panes :accessor frame-panes) - (all-panes :initform nil) - (current-panes :initform nil :accessor frame-current-panes) - (initialized-panes :initform nil) - (pane-constructors :initarg :pane-constructors) - (top-level-sheet :accessor frame-top-level-sheet :initform nil) - (state :initform :disowned :accessor frame-state - :type (member :disowned :disabled :enabled :shrunk)) - (top-level :initarg :top-level :accessor frame-top-level) - (current-layout :initarg :default-layout :initform nil - :reader frame-current-layout) - (geometry :initform nil :initarg :geometry :reader frame-geometry) - (icon :initform nil :initarg :icon :reader frame-icon) - (shell :accessor frame-shell) - (pointer-documentation-p :initarg :pointer-documentation - :reader frame-pointer-documentation-p) - (pointer-documentation-pane :initform nil) - (properties :initform nil :initarg :properties - :accessor frame-properties) - (resizable :initarg :resize-frame - :reader frame-resizable) - (layout :initarg :layout :reader frame-layouts)) + ;;--- Is it right for these to be SHEET accessors?? + ((name :initarg :name :accessor frame-name) + (pretty-name :initarg :pretty-name :accessor frame-pretty-name) + (command-table :initarg :command-table + :initform (find-command-table 'user-command-table) + :accessor frame-command-table) + (disabled-commands :initarg :disabled-commands :initform nil) + ;; One of T, NIL, or a command-table; used by the menu-bar + (menu-bar :initarg :menu-bar :initform nil) + (histories :initform nil) + (frame-manager :reader frame-manager) + (calling-frame :reader frame-calling-frame :initarg :calling-frame) + ;; PANES is the description of all of the named panes, + ;; ALL-PANES is an alist that stores all of the named panes that + ;; have actually been realized so far + (panes :initarg :panes :accessor frame-panes) + (all-panes :initform nil) + (current-panes :initform nil :accessor frame-current-panes) + (initialized-panes :initform nil) + (pane-constructors :initarg :pane-constructors) + (top-level-sheet :accessor frame-top-level-sheet :initform nil) + (state :initform :disowned :accessor frame-state + :type (member :disowned :disabled :enabled :shrunk)) + (top-level :initarg :top-level :accessor frame-top-level) + (current-layout :initarg :default-layout :initform nil + :reader frame-current-layout) + (geometry :initform nil :initarg :geometry :reader frame-geometry) + (icon :initform nil :initarg :icon :reader frame-icon) + (shell :accessor frame-shell) + (pointer-documentation-p :initarg :pointer-documentation + :reader frame-pointer-documentation-p) + (pointer-documentation-pane :initform nil) + (properties :initform nil :initarg :properties + :accessor frame-properties) + (resizable :initarg :resize-frame + :reader frame-resizable) + (layout :initarg :layout :reader frame-layouts)) (:default-initargs :pointer-documentation nil :layout nil :resize-frame nil @@ -70,16 +70,13 @@ (defmethod initialize-instance :after ((frame standard-application-frame) &rest args &key frame-manager - geometry - icon + geometry icon (parent frame-manager)) (declare (ignore args)) - (destructuring-bind (&key x y width height) geometry (declare (ignore x y width height))) (destructuring-bind (&key name pixmap clipping-mask) icon (declare (ignore name pixmap clipping-mask))) - (let ((frame-manager (etypecase parent (null (find-frame-manager)) @@ -98,7 +95,7 @@ (eval-when (eval compile load) (defun define-application-frame-1 (name state-variables pane-descriptions - &key top-level layout + &key top-level layouts command-table disabled-commands) (let* ((command-table-name (first command-table))) ;; If we're going to be defining commands for this application frame, @@ -111,7 +108,7 @@ (defmacro define-application-frame (name superclasses slots &rest options) #+Genera (declare (zwei:indentation 1 25 2 3 3 1)) (with-warnings-for-definition name define-application-frame - (let (pane panes layout top-level menu-bar pointer-documentation + (let (pane panes layouts top-level menu-bar pointer-documentation command-definer command-table disabled-commands icon geometry default-initargs) (macrolet ((extract (name keyword default &optional (pair t)) @@ -130,7 +127,7 @@ options (delete entry options))))))))) (extract pane :pane nil) (extract panes :panes nil nil) - (extract layout :layout nil nil) + (extract layouts :layouts nil nil) (extract top-level :top-level '(default-frame-top-level)) (extract menu-bar :menu-bar t) (extract pointer-documentation :pointer-documentation nil) @@ -145,16 +142,16 @@ (check-type slots list) (check-type pane list) (check-type panes list) - (check-type layout list) + (check-type layouts list) (check-type top-level list) (check-type disabled-commands list) (when (and pane panes) (error "The ~S and ~S options cannot be used together" :pane :panes)) - (when (and pane layout) - (error "The ~S and ~S options cannot be used together" :pane :layout)) - (when (or (and panes (null layout)) - (and layout (null panes))) - (error "The ~S and ~S options must be used together" :panes :layout)) + (when (and pane layouts) + (error "The ~S and ~S options cannot be used together" :pane :layouts)) + (when (or (and panes (null layouts)) + (and layouts (null panes))) + (error "The ~S and ~S options must be used together" :panes :layouts)) (when (null superclasses) (setq superclasses '(standard-application-frame))) (when (eq command-definer 't) @@ -167,7 +164,7 @@ (when (eq (first command-table) 't) (setq command-table (list* name (rest command-table)))) #-Silica (warn-if-pane-descriptions-invalid name pane-descriptions) - #-Silica (warn-if-layout-invalid name layout pane-descriptions) + #-Silica (warn-if-layouts-invalid name layouts pane-descriptions) (let ((pane-constructors (cond (panes (compute-pane-constructor-code panes)) @@ -178,7 +175,7 @@ (when ',command-table (setf (compile-time-property ',(first command-table) 'command-table-name) t)) (define-application-frame-1 ',name ',slots ,pane-constructors - :layout ',layout + :layouts ',layouts :top-level ',top-level :command-table ',command-table)) (define-group ,name define-application-frame @@ -191,7 +188,7 @@ ,@(and command-table `(:command-table ',(car command-table))) ,@(and top-level `(:top-level ',top-level)) ,@(and panes `(:pane-constructors ,pane-constructors)) - ,@(and layout `(:default-layout ',(caar layout))) + ,@(and layouts `(:default-layout ',(caar layouts))) ,@(and icon `(:icon (list ,@icon))) ,@(and geometry `(:geometry (list ,@geometry))) ,@default-initargs)) @@ -212,7 +209,7 @@ ;;--- Need to handle DISABLED-COMMANDS properly, ;;--- which entails doing a COPY-LIST (define-application-frame-1 ',name ',slots ,pane-constructors - :layout ',layout + :layouts ',layouts :top-level ',top-level :command-table ',command-table :disabled-commands ',disabled-commands) @@ -220,7 +217,7 @@ (cloe:define-program ,name () :main ,name :debugger-hook cloe-debugger-hook) - ,@(compute-generate-panes-code name pane panes layout))))))) + ,@(compute-generate-panes-code name pane panes layouts))))))) #+Genera (scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name) @@ -331,14 +328,6 @@ `(,name ,panes))) layouts))))))))))) -(defmethod find-or-make-pane-named ((frame standard-application-frame) name) - (with-slots (all-panes pane-constructors) frame - (second (or (assoc name all-panes) - (car (push (list name - (funcall (second (assoc name pane-constructors)) - frame (frame-manager frame))) - all-panes)))))) - (defun compute-pane-constructor-code (panes) `(list ,@(mapcar #'(lambda (pane-spec) (destructuring-bind (name code &rest options) pane-spec @@ -397,7 +386,7 @@ `(make-pane 'text-field ,@options)) (define-pane-type text-editor (&rest options) - `(make-pane 'silicatext-editor ,@options)) + `(make-pane 'text-editor ,@options)) (define-pane-type toggle-button (&rest options) `(make-pane 'toggle-button ,@options)) @@ -414,7 +403,7 @@ (with-slots (all-panes pane-constructors) frame (second (or (assoc name all-panes) (car (push (list name - (funcall (second (assoc name pane-constructors)) + (funcall (second (assoc name pane-constructors)) frame (frame-manager frame))) all-panes)))))) @@ -426,25 +415,25 @@ (let ((sr (compose-space panes))) (setq width (space-requirement-width sr) height (space-requirement-height sr)) - (multiple-value-bind - (gw gh) (bounding-rectangle-size (graft frame)) + ;;--- This looks dubious --SWM + (multiple-value-bind (gw gh) + (bounding-rectangle-size (graft frame)) (minf width (* 0.9 gw)) - (minf height (* 0.9 gh))))) + (minf height (* 0.9 gh))))) ;;--- Don't bother with this if the size didn't change? - (let ((top (or (frame-top-level-sheet frame) panes))) - (if (and (sheet-enabled-p top) + (let ((top-sheet (or (frame-top-level-sheet frame) panes))) + (if (and (sheet-enabled-p top-sheet) (not (frame-resizable frame))) - (multiple-value-call - #'allocate-space - top - (bounding-rectangle-size top)) + (multiple-value-call #'allocate-space + top-sheet (bounding-rectangle-size top-sheet)) (resize-sheet* - top + top-sheet width height)))))) -(defmethod (setf frame-current-layout) (nv (frame standard-application-frame)) - (unless (eq (frame-current-layout frame) nv) - (setf (slot-value frame 'current-layout) nv) + +(defmethod (setf frame-current-layout) (layout (frame standard-application-frame)) + (unless (eq (frame-current-layout frame) layout) + (setf (slot-value frame 'current-layout) layout) ;; First disown all the children (dolist (name-and-pane (slot-value frame 'all-panes)) (let ((sheet (second name-and-pane))) @@ -458,27 +447,32 @@ (sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame)) (let ((layout-space-requirements - (cddr (assoc nv (frame-layouts frame))))) + (cddr (assoc layout (frame-layouts frame))))) (changing-space-requirements (:layout nil) - (flet ((adjust-layout (sheet) - (when (typep sheet 'space-requirement-mixin) - (silica::change-space-requirements-to - sheet (silica::pane-initial-space-requirements sheet))) - (let ((x (and - (panep sheet) - (assoc (pane-name sheet) layout-space-requirements)))) - (when x (apply #'change-space-requirements sheet (cdr x)))))) - (declare (dynamic-extent #'adjust-layout)) - (map-over-sheets #'adjust-layout (frame-top-level-sheet frame))))) - + (flet ((adjust-layout (sheet) + (change-pane-requirements-to-default sheet) + (let ((x (and (panep sheet) + (assoc (pane-name sheet) layout-space-requirements)))) + (when x (apply #'change-space-requirements sheet (cdr x)))))) + (declare (dynamic-extent #'adjust-layout)) + (map-over-sheets #'adjust-layout (frame-top-level-sheet frame))))) (multiple-value-call #'layout-frame frame (bounding-rectangle-size (frame-top-level-sheet frame))) (throw 'layout-changed nil))) - + + +;;-- Should be elsewhere. + +(defmethod change-pane-space-requirements-to-default ((pane t)) + nil) + +(defmethod change-pane-space-requirements-to-default ((pane space-requirement-mixin)) + (silica::change-space-requirements-to pane (silica::pane-initial-space-requirements pane))) + #+CLIM-1-compatibility (define-compatibility-function (set-frame-layout (setf frame-current-layout)) - (frame new-layout) - (setf (frame-current-layout frame) new-layout)) + (frame layout) + (setf (frame-current-layout frame) layout)) (defun make-application-frame (frame-name &rest options &key frame-class @@ -492,19 +486,19 @@ (setq frame-class frame-name)) (when (or x y width height) (when (getf options :geometry) - (error "Cannot specify :geometry and :x,:y,:width or :height at ~ -the same time " options)) + (error "Cannot specify ~S and ~S, S, ~S, or ~S at the same time" + :geometry :x :y :width :height)) (setf (getf options :geometry) - (append (and x `(:x ,x)) - (and y `(:y ,y)) - (and width `(:width ,width)) - (and height `(:height ,height))))) + (append (and x `(:x ,x)) + (and y `(:y ,y)) + (and width `(:width ,width)) + (and height `(:height ,height))))) (with-keywords-removed (options options '(:frame-class :pretty-name :enable :x :y :width :height :save-under)) (let ((frame (apply #'make-instance frame-class :name frame-name - ;;-- Perhaps this should be a default-initarg? + ;;--- Perhaps this should be a default-initarg? :pretty-name (or pretty-name (title-capitalize (string frame-name))) :properties `(:save-under ,save-under) @@ -521,23 +515,23 @@ the same time " options)) (defmethod enable-frame ((frame standard-application-frame)) (unless (frame-manager frame) - (error "Cannot enabled :disowned frame ~S" frame)) - (destructuring-bind - (&key width height &allow-other-keys) (frame-geometry frame) + (error "Cannot enabled a disowned frame ~S" frame)) + (destructuring-bind (&key width height &allow-other-keys) + (frame-geometry frame) (ecase (frame-state frame) (:enabled) ((:disabled :disowned) (let ((old (frame-state frame))) (setf (frame-state frame) :enabled) - ;; IF this is a new frame then if the user specified a width + ;; If this is a new frame then if the user specified a width ;; then we should be using that - ;; IF the frame already exists then we probably should be using + ;; If the frame already exists then we probably should be using ;; the top level sheet size (multiple-value-call #'layout-frame frame (ecase old (:disowned - (if (and width height) + (if (and width height) (values width height) (values))) (:disabled @@ -572,8 +566,7 @@ the same time " options)) (defmethod run-frame-top-level :around ((frame standard-application-frame)) (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame)) (unwind-protect - (let (#-Silica (*frame-layout-changing-p* *frame-layout-changing-p*) - ;; Reset the state of the input editor and the presentation + (let (;; Reset the state of the input editor and the presentation ;; type system, etc., in case there is an entry into another ;; application from inside the input editor, such as a Debugger ;; written using CLIM. @@ -590,33 +583,33 @@ the same time " options)) (*input-context* nil) (*accept-help* nil) (*assume-all-commands-enabled* nil) - #-Silica (*sizing-application-frame* nil) (*command-parser* 'command-line-command-parser) (*command-unparser* 'command-line-command-unparser) (*partial-command-parser* 'command-line-read-remaining-arguments-for-partial-command) (*application-frame* frame)) - (loop - (with-simple-restart (nil "~A top level" (frame-pretty-name frame)) - (loop - (catch 'layout-changed - (let ((*application-frame* frame) - (*pointer-documentation-output* - (frame-pointer-documentation-output frame))) - ;; We must return the values from CALL-NEXT-METHOD, - ;; or else ACCEPTING-VALUES will return NIL - #-CCL-2 - (return-from run-frame-top-level (call-next-method)) - ;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above - ;; doesn't work in Coral. If the "top level" restart - ;; above is taken, the CALL-NEXT-METHOD form blows out - ;; the second time through this code, claiming that it - ;; can't find the next method. Hoisting the - ;; CALL-NEXT-METHOD out of the RETURN-FROM form seems - ;; to fix it... So it conses, big deal. - #+CCL-2 - (let ((results (multiple-value-list (call-next-method)))) - (return-from run-frame-top-level (values-list results))))))))) + (with-frame-manager ((frame-manager frame)) + (loop + (with-simple-restart (nil "~A top level" (frame-pretty-name frame)) + (loop + (catch 'layout-changed + (let ((*application-frame* frame) + (*pointer-documentation-output* + (frame-pointer-documentation-output frame))) + ;; We must return the values from CALL-NEXT-METHOD, + ;; or else ACCEPTING-VALUES will return NIL + #-CCL-2 + (return-from run-frame-top-level (call-next-method)) + ;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above + ;; doesn't work in Coral. If the "top level" restart + ;; above is taken, the CALL-NEXT-METHOD form blows out + ;; the second time through this code, claiming that it + ;; can't find the next method. Hoisting the + ;; CALL-NEXT-METHOD out of the RETURN-FROM form seems + ;; to fix it... So it conses, big deal. + #+CCL-2 + (let ((results (multiple-value-list (call-next-method)))) + (return-from run-frame-top-level (values-list results)))))))))) (disable-frame frame)))) (defmethod run-frame-top-level ((frame standard-application-frame)) @@ -657,15 +650,14 @@ the same time " options)) #'command-line-read-remaining-arguments-for-partial-command #'menu-read-remaining-arguments-for-partial-command))) (command-stream - ;;-- We have to ask the frame since we do not want to - ;; just pick up a stream from the dynamic environment - (let ((si (or (frame-standard-input frame) - (frame-standard-output frame)))) - ;;--- I'm not really convinced that this is right - ;; Who is not convinced - (typecase si - (output-protocol-mixin si) - (t (frame-top-level-sheet frame)))))) + ;;--- We have to ask the frame since we do not want to + ;;--- just pick up a stream from the dynamic environment + (let ((si (or (frame-standard-input frame) + (frame-standard-output frame)))) + ;;--- I'm not really convinced that this is right --SWM + (typecase si + (output-protocol-mixin si) + (t (frame-top-level-sheet frame)))))) #+Allegro (unless (typep *standard-input* 'excl::bidirectional-terminal-stream) (assert (port *standard-input*))) @@ -746,7 +738,6 @@ the same time " options)) ;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc? ;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR? - (defun redisplay-frame-pane (frame pane &key force-p) (when (symbolp pane) (setq pane (get-frame-pane frame pane))) @@ -926,17 +917,18 @@ the same time " options)) (not (null (find-frame-pane-of-type frame 'interactor-pane)))) (defmethod notify-user (frame message &rest options) - (when frame (setf (getf options :frame) frame)) - (apply #'port-notify-user - (if frame (port frame) (find-port)) - message - options)) + (declare (dynamic-extent options)) + (when frame + (setf (getf options :frame) frame)) + (apply #'frame-manager-notify-user + (if frame (frame-manager frame) (find-frame-manager)) message options)) (defmethod select-file (frame &rest options) - (when frame (setf (getf options :frame) frame)) - (apply #'port-select-file - (if frame (port frame) (find-port)) - options)) + (declare (dynamic-extent options)) + (when frame + (setf (getf options :frame) frame)) + (apply #'frame-manager-select-file + (if frame (frame-manager frame) (find-frame-manager)) options)) ;;; Pointer documentation @@ -945,20 +937,19 @@ the same time " options)) (max (floor (* 1/10 internal-time-units-per-second)) 1)) (defvar *last-pointer-documentation-time* 0) -#+Genera -(defvar *pointer-documentation-buffer* - (make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t)) - ;;; Produce pointer documentation (defmethod frame-document-highlighted-presentation ((frame standard-application-frame) presentation input-context window x y stream) - (let (#+Genera (documentation-window (mouse-documentation-window window))) + (frame-manager-display-pointer-documentation + (frame-manager frame) frame presentation input-context window x y stream)) + +(defmethod frame-manager-display-pointer-documentation + ((framem standard-frame-manager) + frame presentation input-context window x y stream) + (when stream ;; The documentation should never say anything if we're not over a presentation (when (null presentation) - #+Genera (if documentation-window - (scl:send documentation-window :clear-window) - (window-clear stream)) - #-Genera (window-clear stream)) + (window-clear stream)) ;; Cheap test to not do this work too often (let ((old-modifier-state *last-pointer-documentation-modifier-state*) (modifier-state (window-modifier-state window)) @@ -967,19 +958,9 @@ the same time " options)) (setq *last-pointer-documentation-modifier-state* modifier-state) (when (and (< time (+ last-time *pointer-documentation-interval*)) (= modifier-state old-modifier-state)) - (return-from frame-document-highlighted-presentation nil)) + (return-from frame-manager-display-pointer-documentation nil)) (setq *last-pointer-documentation-time* time)) (when presentation - #+Genera - (when documentation-window - (setf (fill-pointer *pointer-documentation-buffer*) 0) - (with-output-to-string (stream *pointer-documentation-buffer*) - (scl:send documentation-window :clear-window) - (when (null (frame-document-highlighted-presentation-1 - frame presentation input-context window x y stream)) - (setq *last-pointer-documentation-time* 0)) - (scl:send documentation-window :string-out *pointer-documentation-buffer*)) - (return-from frame-document-highlighted-presentation nil)) (with-output-recording-options (stream :record nil) (with-end-of-line-action (stream :allow) (with-end-of-page-action (stream :allow) @@ -1100,5 +1081,3 @@ the same time " options)) middle middle-presentation middle-context right right-presentation right-context))) -#+Genera -(defmethod mouse-documentation-window ((window window-stream)) nil) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index da639f92..7d719ce7 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadget-output.lisp,v 1.15 92/05/07 13:12:16 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.16 92/05/12 18:25:02 cer Exp Locker: cer $ (in-package :clim-internals) @@ -32,91 +32,81 @@ ((gadget :initform nil :accessor output-record-gadget))) -(defmethod associate-record-and-gadget (rec gadget stream x y) +(defmethod associate-record-and-gadget (record gadget stream x y) ;; Just in case (setf (sheet-enabled-p gadget) nil) (sheet-adopt-child stream gadget) ;; In order to be able to determine the space the widget has to be ;; added to the parent and hopefully grafted (assert (port stream)) - (setf (output-record-gadget rec) gadget) + (setf (output-record-gadget record) gadget) (let ((sr (compose-space gadget))) (multiple-value-bind (abs-x abs-y) (point-position (stream-output-history-position stream)) (decf x abs-x) (decf y abs-y) - - #-ignore (multiple-value-bind (cx cy) (stream-cursor-position stream) (declare (type coordinate cx cy)) - (with-slots (start-x start-y) rec - (setq start-x (- cx abs-x) start-y (- cy abs-y)))) - + (with-slots (start-x start-y) record + (setq start-x (- cx abs-x) + start-y (- cy abs-y)))) (bounding-rectangle-set-edges - rec - x y (+ x (space-requirement-width sr)) - (+ y (space-requirement-height sr))) - - #-ignore - (when (output-record-parent rec) - (tree-recompute-extent rec))) - - (when (output-record-stream rec) - (update-gadget-position rec) + record + x y (+ x (space-requirement-width sr)) (+ y (space-requirement-height sr))) + ;;--- We can probably use RECOMPUTE-EXTENT-FOR-CHANGED-CHILD + (when (output-record-parent record) + (tree-recompute-extent record))) + (when (output-record-stream record) + (update-gadget-position record) (setf (sheet-enabled-p gadget) t)))) +(defmethod tree-recompute-extent-1 ((record gadget-output-record)) + (bounding-rectangle* record)) + ;; Three ways (defmethod note-output-record-moved ((record gadget-output-record) dx1 dy1 dx2 dy2) (declare (ignore dx1 dy1 dx2 dy2)) (update-gadget-position record)) -;;; Since this class is an output-record-mixin we do not need this. - -;(defmethod bounding-rectangle-set-position :after ((rec gadget-output-record) x y) -; (declare (ignore x y)) -; (update-gadget-position rec)) - -;;;--- We should not need this one either except that the one on -;;;--- recording protocol seems weird - -(defmethod bounding-rectangle-set-edges :after ((rec gadget-output-record) +(defmethod bounding-rectangle-set-edges :after ((record gadget-output-record) left top right bottom) (declare (ignore left top right bottom)) - (update-gadget-position rec)) + (update-gadget-position record)) + + +(defmethod bounding-rectangle-set-position :after ((record gadget-output-record) x y) + (declare (ignore x y)) + (update-gadget-position record)) -(defmethod bounding-rectangle-set-size :after ((rec gadget-output-record) a b) - (declare (ignore a b)) - (update-gadget-position rec)) +(defmethod bounding-rectangle-set-size :after ((record gadget-output-record) width height) + (declare (ignore width height)) + (update-gadget-position record)) -#+ignore +#+++ignore (defmethod update-gadget-position (record) (let ((gadget (output-record-gadget record))) (when gadget (with-bounding-rectangle* (left top right bottom) record (let ((xoff (coordinate 0)) (yoff (coordinate 0))) - (multiple-value-setq - (xoff yoff) - (convert-from-relative-to-absolute-coordinates - (sheet-parent gadget) - record)) + (multiple-value-setq (xoff yoff) + (convert-from-relative-to-absolute-coordinates + (sheet-parent gadget) record)) (move-and-resize-sheet* gadget (+ left xoff) (+ top yoff) (- right left) (- bottom top))))))) - -#-ignore +#---ignore (defmethod update-gadget-position (record) (let ((gadget (output-record-gadget record))) (when gadget - (multiple-value-bind - (xoff yoff) + (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates - (output-record-stream record) - (output-record-parent record)) + (output-record-stream record) + (output-record-parent record)) (with-bounding-rectangle* (left top right bottom) record (move-and-resize-sheet* gadget (+ left xoff) (+ top yoff) @@ -145,15 +135,14 @@ (with-look-and-feel-realization (,fm ,f) ,@body)) ,@args)))) -#+ignore +#+++ignore (defmethod invoke-with-output-as-gadget (stream continuation &key) ;;--- (PANE-FRAME STREAM) or *APPLICATION-FRAME*? (let* ((frame (pane-frame stream)) (framem (frame-manager frame))) (assert frame) (assert framem) - (multiple-value-bind (x y) - (stream-cursor-position stream) + (multiple-value-bind (x y) (stream-cursor-position stream) (let* (gadget (record (with-new-output-record (stream 'gadget-output-record record) @@ -162,39 +151,35 @@ ;;--- release the gadget? (unless (setq gadget (output-record-gadget record)) (associate-record-and-gadget - record - (setq gadget (funcall continuation framem frame)) - stream x y))))) + record + (setq gadget (funcall continuation framem frame)) + stream x y))))) (move-cursor-beyond-output-record stream record) (values gadget record))))) -#-ignore +#---ignore (defmethod invoke-with-output-as-gadget (stream continuation &key) (let* ((frame (pane-frame stream)) (framem (frame-manager frame))) (assert frame) (assert framem) - (multiple-value-bind (x y) - (stream-cursor-position stream) + (multiple-value-bind (x y) (stream-cursor-position stream) (let* (new gadget (record (with-new-output-record (stream 'gadget-output-record record) (unless (setq gadget (output-record-gadget record)) - (setq new t - gadget (funcall continuation framem frame)))))) - (when new - (associate-record-and-gadget - record - gadget - stream x y)) + (setq gadget (funcall continuation framem frame) + new t))))) + (when new + (associate-record-and-gadget record gadget stream x y)) (move-cursor-beyond-output-record stream record) (values gadget record))))) ;; incf redisplay wanted this! -(defmethod clear-output-record ((rec gadget-output-record)) +(defmethod clear-output-record ((record gadget-output-record)) nil) ;; kludge because of clear-output-record :after @@ -202,13 +187,13 @@ ;; If think is because the clear-output-record stuff should be on ;; composite-output-records rather than displayed output-records -(defmethod bounding-rectangle-set-edges :around ((rec gadget-output-record) - minx miny maxx maxy) - (unless (= minx miny maxx maxy) +(defmethod bounding-rectangle-set-edges :around ((record gadget-output-record) + left top right bottom) + (unless (= left top right bottom) (call-next-method))) -#+ignore -(defmethod add-output-record :after ((child gadget-output-record) (parent t)) +#+++ignore +(defmethod add-output-record :after ((record gadget-output-record) (parent t)) (do ((p parent (output-record-parent p))) ((null p) (warn "Parent is not a output-history")) @@ -217,41 +202,42 @@ ;; Perhaps we should enable the gadget at this point nil) -(defvar *with-deffered-gadget-updates* nil) +(defmethod note-output-record-attached :after ((record gadget-output-record) stream) + (declare (ignore stream)) + (when (output-record-gadget record) + (update-gadget-position record) + (update-output-record-gadget-state record t))) + +(defmethod note-output-record-detached :after ((record gadget-output-record)) + (update-output-record-gadget-state record nil)) + + +(defvar *with-deferred-gadget-updates* nil) -(defmacro with-defered-gadget-updates (&body body) - `(flet ((with-defered-gadget-updates-body () +(defmacro with-deferred-gadget-updates (&body body) + `(flet ((with-deferred-gadget-updates-body () ,@body)) - (if *with-deffered-gadget-updates* - (with-defered-gadget-updates-body) - (let ((*with-deffered-gadget-updates* (list nil))) - (multiple-value-prog1 - (with-defered-gadget-updates-body) - (complete-gadget-updates)))))) + (declare (dynamic-extent #'with-deferred-gadget-updates-body)) + (if *with-deferred-gadget-updates* + (with-deferred-gadget-updates-body) + (let ((*with-deferred-gadget-updates* (list nil))) + (multiple-value-prog1 + (with-deferred-gadget-updates-body) + (complete-gadget-updates)))))) (defun complete-gadget-updates () (mapc #'(lambda (x) - (setf (sheet-enabled-p (car x)) (cadr x))) - (remove-duplicates (cdr *with-deffered-gadget-updates*) - :key #'car - :test #'eq - :from-end t))) - -(defun update-output-rec-gadget-state (rec state) - (if *with-deffered-gadget-updates* - (push (list (output-record-gadget rec) state) - (cdr *with-deffered-gadget-updates*)) - (setf (sheet-enabled-p (output-record-gadget rec)) state))) - -(defmethod note-output-record-attached :after ((rec gadget-output-record) stream) - (declare (ignore stream)) - (when (output-record-gadget rec) - (update-gadget-position rec) - (update-output-rec-gadget-state rec t))) + (setf (sheet-enabled-p (first x)) (second x))) + (remove-duplicates (cdr *with-deferred-gadget-updates*) + :key #'car :from-end t))) -(defmethod note-output-record-detached :after ((rec gadget-output-record)) - (update-output-rec-gadget-state rec nil)) +(defun update-output-record-gadget-state (record state) + (if *with-deferred-gadget-updates* + (push (list (output-record-gadget record) state) + (cdr *with-deferred-gadget-updates*)) + (setf (sheet-enabled-p (output-record-gadget record)) state))) + ;;; Completion gadget ;;--- Gadget currently does not include prompt @@ -262,18 +248,17 @@ present-p query-identifier &key (prompt t)) (declare (ignore present-p)) - ;; value-key, test, sequence (with-output-as-gadget (stream) (let* (gadget frame-pane) (setq frame-pane - (outlining () - (setq gadget - (make-pane 'radio-box - :label (and (stringp prompt) prompt) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier))))) + (outlining () + (setq gadget + (make-pane 'radio-box + :label (and (stringp prompt) prompt) + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) (dolist (element (reverse sequence)) (make-pane 'toggle-button :label (funcall name-key element) @@ -286,40 +271,39 @@ :parent gadget)) frame-pane))) -;;; Subset + +;;; Subset completion gadget (define-presentation-method accept-present-default ((type subset-completion) stream - (view gadget-dialog-view) - default default-supplied-p - present-p query-identifier - &key (prompt t)) + (view gadget-dialog-view) + default default-supplied-p + present-p query-identifier + &key (prompt t)) (declare (ignore present-p)) - ;; value-key, test, sequence (with-output-as-gadget (stream) (let* (gadget frame-pane) (setq frame-pane - (outlining () - (setq gadget - (make-pane 'check-box - :label (and (stringp prompt) prompt) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier))))) + (outlining () + (setq gadget + (make-pane 'check-box + :label (and (stringp prompt) prompt) + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) (dolist (element (reverse sequence)) - (make-pane 'toggle-button - :label (funcall name-key element) - :value (and default-supplied-p - (member (funcall value-key default) - sequence - :test test - :key value-key)) - :idicator-type :some-of - :id element - :parent gadget)) + (make-pane 'toggle-button + :label (funcall name-key element) + :indicator-type :some-of + :value (and default-supplied-p + (member (funcall value-key default) sequence + :test test :key value-key)) + :id element + :parent gadget)) frame-pane))) + ;;; Boolean gadget (define-presentation-method gadget-includes-prompt-p @@ -336,28 +320,30 @@ (let (gadget) (with-output-as-gadget (stream) (outlining () - (setq gadget - (make-pane 'toggle-button - :label (and (stringp prompt) prompt) - :value default - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier))))) - ;;--- We end up not making a new gadget sometimes, I think because - ;;--- we find a gadget already in the record so we need to modify - ;;--- the value! - ;;--- I am no longer sure that this is true cos the graphics - ;;--- dialog seems to work fine. - #+ignore + (setq gadget + (make-pane 'toggle-button + :label (and (stringp prompt) prompt) + :value default + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) + ;;--- We end up not making a new gadget sometimes, I think because we + ;;--- find a gadget already in the record so we need to modify the value! + ;;--- I am no longer sure that this is true because the graphics dialog + ;;--- in the test suite seems to work fine. + #+++ignore (setf (gadget-value gadget) default))) -#+ignore + +;;; Numeric gadgets + +#+++ignore (define-presentation-method gadget-includes-prompt-p ((type integer) (stream t) (view gadget-view)) t) -#+ignore +#+++ignore (define-presentation-method accept-present-default ((type integer) stream (view gadget-dialog-view) @@ -367,21 +353,23 @@ (declare (ignore present-p)) (with-output-as-gadget (stream) (outlining () - (make-pane 'slider - :label (and (stringp prompt) prompt) - :value (if default-supplied-p default 0) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier))))) - - - + (make-pane 'slider + :label (and (stringp prompt) prompt) + :value (if default-supplied-p default 0) + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) + + ;;--- These should be defined in the standard DEFOPERATION way... (defmethod sheet-medium ((x standard-encapsulating-stream)) (sheet-medium (slot-value x 'stream))) +(defmethod sheet-parent ((x standard-encapsulating-stream)) + (sheet-parent (slot-value x 'stream))) + (defmethod port ((x standard-encapsulating-stream)) (port (slot-value x 'stream))) diff --git a/clim/gestures.lisp b/clim/gestures.lisp index e3f4bd0d..f585ca2c 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.5 92/03/10 10:12:36 cer Exp $ +;; $fiHeader: gestures.lisp,v 1.6 92/04/15 11:46:36 cer Exp $ (in-package :clim-internals) @@ -38,23 +38,6 @@ (setf state (dpb 1 (byte 1 bit) state)))) state)) -#+ignore -(defun print-modifier-state (state stream &optional brief-p) - (let ((n (length *modifier-keys*))) - (dotimes (i n) - (let ((bit (- n i 1))) - (let ((name (modifier-key-index-name bit))) - (when (ldb-test (byte 1 bit) state) - (if brief-p - (format stream "~A-" - (ecase name - (:shift "sh") - (:control "c") - (:meta "m") - (:super "s") - (:hyper "h"))) - (format stream "~:(~A-~)" name)))))))) - ;; A table indexed by mouse button and modifier state [now (3 x 32)]. ;; Each bucket in the table contains a sequence of gesture names. (defvar *button-and-modifier-key->gesture* @@ -109,15 +92,6 @@ nil) #|| -(defun modifier-state-keys (state) - ;; This could be table-driven, also, if it's called frequently - (let ((shifts nil)) - (dotimes (bit (length *modifier-keys*)) - (let ((name (modifier-key-index-name bit))) - (when (ldb-test (byte 1 bit) state) - (push name shifts)))) - (nreverse shifts))) - ;;; Returns an alist of (button . gestures) (defun gestures-for-modifier-state (state) ;; Eventually, cache this result because it's a common question @@ -133,12 +107,10 @@ (declare (dynamic-extent shift-names)) (let ((state (apply #'make-modifier-state shift-name))) (gestures-for-modifier-state state))) - ||# ;; We typically have our hands on a button index and a modifier key state, ;; and we need to know if it matches a named gesture - (defun-inline button-and-modifier-state-matches-gesture-name-p (button state gesture-name) (or (eq gesture-name 't) (member gesture-name (button-and-modifier-state-gesture-names button state)))) @@ -165,6 +137,7 @@ modifier-state gesture-name))) ;; GESTURE-NAME either names a gesture, or is a canonicalized gesture spec +;;--- Control-? doesn't match (:? :control), but does match (:? :control :shift) (defun keyboard-event-matches-gesture-name-p (event gesture-name) (when (and (characterp event) (characterp gesture-name) @@ -234,6 +207,79 @@ ;;--- and so forth. (values button (nreverse modifiers)))) + +(defvar *modifier-state-specifiers* nil) + +(defun modifier-state-keys (state) + (when (null *modifier-state-specifiers*) + ;; Fill the cache if it hasn't been done yet + (setq *modifier-state-specifiers* (make-array (ash 1 (length *modifier-keys*)))) + (dotimes (state (ash 1 (length *modifier-keys*))) + (let ((shifts nil)) + (dotimes (bit (length *modifier-keys*)) + (let ((name (modifier-key-index-name bit))) + (when (ldb-test (byte 1 bit) state) + (push name shifts)))) + (setf (aref *modifier-state-specifiers* state) shifts)))) + (aref *modifier-state-specifiers* state)) + +(defun gesture-specs-from-gesture-name (gesture-name) + (let ((gesture-specs nil)) + (do-button-and-modifier-state (button modifier-state bucket) + (when (member gesture-name bucket) + (push (list* (button-index-name button) (modifier-state-keys modifier-state)) + gesture-specs))) + (dotimes (modifier-state (ash 1 (length *modifier-keys*))) + (let ((bucket (aref *keysym-and-modifier-key->gesture* modifier-state))) + (dolist (entry bucket) + (when (member gesture-name (cdr entry)) + (push (list* (car entry) (modifier-state-keys modifier-state)) + gesture-specs))))) + (nreverse gesture-specs))) + +(defun describe-gesture-spec (gesture-spec + &key (stream *standard-output*) (brief t)) + (let ((alist (if brief + '((:hyper "h-") + (:super "s-") + (:meta "m-") + (:control "c-") + (:shift "sh-")) + '((:hyper "hyper-") + (:super "super-") + (:meta "meta-") + (:control "control-") + (:shift "shift-"))))) + (dolist (shift alist) + (when (member (first shift) (rest gesture-spec)) + (princ (second shift) stream))) + (let ((keysym (first gesture-spec))) + (when (and (characterp keysym) + (char<= #\A keysym #\A) + (not (member :shift (rest gesture-spec)))) + (princ (second (assoc :shift alist)) stream)) + (when (and (not brief) + (find keysym *pointer-buttons*)) + (princ "Mouse-" stream)) + (format stream "~:(~A~)" keysym)))) + +#+++ignore +(defun print-modifier-state (state stream &optional brief-p) + (let ((n (length *modifier-keys*))) + (dotimes (i n) + (let ((bit (- n i 1))) + (let ((name (modifier-key-index-name bit))) + (when (ldb-test (byte 1 bit) state) + (if brief-p + (format stream "~A-" + (ecase name + (:shift "sh") + (:control "c") + (:meta "m") + (:super "s") + (:hyper "h"))) + (format stream "~:(~A-~)" name)))))))) + (defun add-gesture-name (name type gesture-spec &key (unique t)) (check-type name symbol) diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 4aa3aa0c..10be93a4 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.8 92/04/15 11:46:37 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.9 92/05/07 13:12:20 cer Exp $ (in-package :clim-internals) @@ -176,16 +176,13 @@ root-objects object-printer inferior-producer &key duplicate-key duplicate-test) (declare (ignore duplicate-key duplicate-test)) - (let ((cutoff-depth (slot-value graph 'cutoff-depth)) - (depth 0)) - (labels ((format-node (object) - (when cutoff-depth - (incf depth) - (when (> depth cutoff-depth) - (return-from format-node nil))) + (let ((cutoff-depth (slot-value graph 'cutoff-depth))) + (labels ((format-node (object &optional (depth 1)) + (when (and cutoff-depth (> depth cutoff-depth)) + (return-from format-node nil)) (let ((children nil)) (dolist (inferior (funcall inferior-producer object)) - (let ((node (format-node inferior))) + (let ((node (format-node inferior (1+ depth)))) (when (and node (not (member node children))) ;; Don't add the same node to the children more than ;; once, which can come up during redisplay diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 5fc94501..5600d430 100644 --- a/clim/graphics-recording.lisp +++ b/clim/graphics-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-recording.lisp,v 1.5 92/04/28 09:25:47 cer Exp Locker: cer $ +;; $fiHeader: graphics-recording.lisp,v 1.6 92/05/07 13:12:25 cer Exp $ (in-package :clim-internals) @@ -14,36 +14,35 @@ highlighting-function) (destructuring-bind (function-args &key points-to-transform point-sequences-to-transform - distances-to-transform - optional-points-to-transform + optional-points-to-transform distances-to-transform &allow-other-keys) (get-drawing-function-description name) ;; Gross me right out! (setq function-args - (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) - function-args)) - (setq optional-points-to-transform - (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) - optional-points-to-transform)) + (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) + function-args)) (setq points-to-transform - (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) - points-to-transform)) + (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) + points-to-transform)) (setq point-sequences-to-transform - (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) - point-sequences-to-transform)) + (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) + point-sequences-to-transform)) + (setq optional-points-to-transform + (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) + optional-points-to-transform)) (setq distances-to-transform - (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) - distances-to-transform)) + (mapcar #'(lambda (x) (intern (symbol-name x) *package*)) + distances-to-transform)) (let* ((medium-graphics-function* - (intern (format nil "~A~A*" 'medium- name))) + (intern (format nil "~A~A*" 'medium- name))) (superclasses '(output-record-element-mixin graphics-displayed-output-record)) (slots - (remove 'filled (append medium-components function-args))) + (remove 'filled (append medium-components function-args))) (slot-descs - (mapcar #'(lambda (x) - (list x :initarg (intern (symbol-name x) *keyword-package*))) - slots))) + (mapcar #'(lambda (x) + (list x :initarg (intern (symbol-name x) *keyword-package*))) + slots))) `(progn (defclass ,class ,superclasses ,slot-descs) ;;--- Need to define a speedy constructor @@ -52,9 +51,9 @@ (when (stream-recording-p medium) (let ((transformation (medium-transformation medium)) ,@(mapcar #'(lambda (medium-component) - (list medium-component - `(,(fintern"~A~A" 'medium- medium-component) - medium))) + (list medium-component + `(,(fintern"~A~A" 'medium- medium-component) + medium))) medium-components)) ;; Overload FILLED and LINE-STYLE -- when FILLED is T, ;; the LINE-STYLE is ignored and must be NIL @@ -72,24 +71,24 @@ ((null pts) (nreverse r)) (push - (if (member (car pts) - optional-points-to-transform) - `(when ,(car pts) - (transform-positions (transformation) ,(car pts) ,(cadr pts))) - `(transform-positions (transformation) ,(car pts) ,(cadr pts))) - r)) + (if (member (first pts) optional-points-to-transform) + `(when ,(first pts) + (transform-positions (transformation) + ,(first pts) ,(second pts))) + `(transform-positions (transformation) + ,(first pts) ,(second pts))) + r)) (transform-distances (transformation) ,@distances-to-transform) (let ((record - (make-instance ',class - ,@(mapcan #'(lambda (x) - (list (intern (symbol-name x) *keyword-package*) x)) - slots)))) + (make-instance ',class + ,@(mapcan #'(lambda (x) + (list (intern (symbol-name x) *keyword-package*) x)) + slots)))) (multiple-value-bind (lf tp rt bt) (progn ,bounding-rectangle) (declare (type coordinate lf tp rt bt)) - (bounding-rectangle-set-edges - record - (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y)) + (bounding-rectangle-set-edges record + (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y)) (multiple-value-bind (cx cy) (stream-cursor-position medium) (declare (type coordinate cx cy)) ;; Doing this directly beats calling @@ -105,15 +104,15 @@ ,@(when points-to-transform `((with-slots ,points-to-transform record ,@(do ((p points-to-transform (cddr p)) - r) - ((null p) (nreverse r)) - (let ((b `(setf - ,(first p) (- ,(first p) abs-x) - ,(second p) (- ,(second p) abs-y)))) + r) + ((null p) (nreverse r)) + (let ((b `(setf ,(first p) (- ,(first p) abs-x) + ,(second p) (- ,(second p) abs-y)))) (push - (if (member (car p) optional-points-to-transform) - `(when ,(car p) ,b) b) - r))))))) + (if (member (car p) optional-points-to-transform) + `(when ,(car p) ,b) + b) + r))))))) (stream-add-output-record medium record))))) (when (stream-drawing-p medium) (call-next-method))) @@ -127,33 +126,34 @@ (with-slots (,@slots) record (with-sheet-medium (medium stream) (letf-globally (((medium-transformation medium) +identity-transformation+)) - (with-drawing-options - (medium ,@(mapcan #'(lambda (medium-component) - (list (intern (symbol-name medium-component) - *keyword-package*) - medium-component)) - medium-components)) - (let (,@(when (and (member 'filled function-args) - (member 'line-style medium-components)) - `((filled (not line-style)))) - ,@(mapcar #'(lambda (p) (list p p)) - points-to-transform) - ,@(mapcar #'(lambda (p) (list p p)) - point-sequences-to-transform)) - ,@(mapcar #'(lambda (p) - `(setq ,p (adjust-point-sequence - ,p (- x-offset) (- y-offset)))) - point-sequences-to-transform) - ,@(do ((p points-to-transform (cddr p)) - r) - ((null p) (nreverse r)) - (let ((b `(setf - ,(first p) (+ ,(first p) x-offset) - ,(second p) (+ ,(second p) y-offset)))) - (push - (if (member (car p) optional-points-to-transform) - `(when ,(car p) ,b) b) r))) - (,medium-graphics-function* medium ,@function-args))))))) + (with-drawing-options + (medium ,@(mapcan #'(lambda (medium-component) + (list (intern (symbol-name medium-component) + *keyword-package*) + medium-component)) + medium-components)) + (let (,@(when (and (member 'filled function-args) + (member 'line-style medium-components)) + `((filled (not line-style)))) + ,@(mapcar #'(lambda (p) (list p p)) + points-to-transform) + ,@(mapcar #'(lambda (p) (list p p)) + point-sequences-to-transform)) + ,@(mapcar #'(lambda (p) + `(setq ,p (adjust-point-sequence + ,p (- x-offset) (- y-offset)))) + point-sequences-to-transform) + ,@(do ((p points-to-transform (cddr p)) + r) + ((null p) (nreverse r)) + (let ((b `(setf ,(first p) (+ ,(first p) x-offset) + ,(second p) (+ ,(second p) y-offset)))) + (push + (if (member (car p) optional-points-to-transform) + `(when ,(car p) ,b) + b) + r))) + (,medium-graphics-function* medium ,@function-args))))))) ,@(when highlighting-test (let ((args (first highlighting-test)) @@ -547,53 +547,30 @@ ;;--- Where is DRAW-TEXT? and/or DRAW-STRING and DRAW-CHARACTER? - -(define-output-recorder text-output-record - draw-text (text-style ink) - :bounding-rectangle - (text-bounding-box medium - transformation - string-or-char - x y start end align-x - align-y - text-style - towards-x - towards-y - transform-glyphs)) - -(defun text-bounding-box (stream transformation - string x y start end align-x - align-y text-style - towards-x - towards-y - transform-glyphs) - (port-text-bounding-box - (port stream) - stream - string x y start end align-x - align-y text-style - towards-x - towards-y - transform-glyphs)) - -(defmethod port-text-bounding-box ((port port) - stream - string x y start end align-x - align-y text-style - towards-x - towards-y - transform-glyphs) +(define-output-recorder text-output-record draw-text (text-style ink) + :bounding-rectangle + (text-bounding-box medium transformation string-or-char x y + start end align-x align-y text-style + towards-x towards-y transform-glyphs)) + +(defun text-bounding-box (stream transformation string x y + start end align-x align-y text-style + towards-x towards-y transform-glyphs) + (port-text-bounding-box (port stream) stream string x y + start end align-x align-y text-style + towards-x towards-y transform-glyphs)) + +(defmethod port-text-bounding-box ((port port) stream string x y + start end align-x align-y text-style + towards-x towards-y transform-glyphs) (declare (ignore towards-x towards-y transform-glyphs)) (let* ((width (stream-string-width stream string - :start start - :end end - :text-style text-style)) - ;;-- Is this the correct? - ;;-- Text-style-foo does not take a port! - (ascent (text-style-ascent text-style (port stream))) - (descent (text-style-descent text-style (port stream))) - (height (+ ascent descent)) - vx vt vr vb) + :start start :end end + :text-style text-style)) + (ascent (text-style-ascent text-style (port stream))) + (descent (text-style-descent text-style (port stream))) + (height (+ ascent descent)) + vx vt vr vb) (ecase align-x (:left (setq vx x vr (+ x width))) @@ -602,15 +579,13 @@ (:center (setq vx (- x (round width 2)) vr (+ x (round width 2))))) (ecase align-y - ;;--- Using STREAM-LINE-HEIGHT for baseline isn't right. - (:baseline (setq vt (- y ascent) + (:baseline (setq vt (- y height) vb (+ y descent))) (:top (setq vt y vb (+ y height))) (:bottom (setq vt (- y height) vb y)) - ;;--- Use FLOOR and CEILING, no? - (:center (setq vt (- y (round height 2)) - vb (+ y (round height 2))))) + (:center (setq vt (- y (floor height 2)) + vb (+ y (ceiling height 2))))) (values (coordinate vx) (coordinate vt) (coordinate vr) (coordinate vb)))) diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp index f12b66ea..b6f5bea3 100644 --- a/clim/incremental-redisplay.lisp +++ b/clim/incremental-redisplay.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: incremental-redisplay.lisp,v 1.5 92/04/15 11:46:44 cer Exp $ +;; $fiHeader: incremental-redisplay.lisp,v 1.6 92/05/07 13:12:28 cer Exp $ (in-package :clim-internals) @@ -656,7 +656,7 @@ ;; ;; The question is what the default behavior should be. The current behavior ;; is sort of minimalist. -#+ignore +#+++ignore (defmethod compute-new-output-records ((record output-record-mixin) stream) ;; walk over children? ) @@ -751,7 +751,7 @@ (bounding-rectangle record))))))))))) ;; just use default, for now. -#+ignore +#+++ignore (defmethod find-child-output-record ((record standard-updating-output-record) use-old-children record-type &rest init-args &key unique-id id-test &allow-other-keys) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 825348ea..2bef2a18 100644 --- a/clim/input-editor-commands.lisp +++ b/clim/input-editor-commands.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-editor-commands.lisp,v 1.7 92/04/15 11:46:47 cer Exp $ +;; $fiHeader: input-editor-commands.lisp,v 1.8 92/05/07 13:12:32 cer Exp $ (in-package :clim-internals) @@ -64,7 +64,10 @@ (define-gesture-name :complete :keyboard (:tab)) (define-gesture-name :complete :keyboard (:complete)) (define-gesture-name :help :keyboard (:help)) +;;--- Both of these because of a bug in KEYBOARD-EVENT-MATCHES-GESTURE-NAME-P +;;--- that causes control-? not to match sometimes (define-gesture-name :possibilities :keyboard (:? :control)) +(define-gesture-name :possibilities :keyboard (:? :control :shift)) ;; These need to be on a per-implementation basis, naturally ;;--- If you change these, change *MAGIC-COMPLETION-GESTURES* too @@ -95,19 +98,19 @@ #.(logior +control-key+ +meta-key+ +super-key+ +hyper-key+)))) (cond ((and (eq aarray *input-editor-command-aarray*) bucky-p - (member keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9))) - ;; A numeric argument... - (position keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9))) + ;; If a numeric argument, return the digit + (position keysym '#(:|0| :|1| :|2| :|3| :|4| + :|5| :|6| :|7| :|8| :|9|)))) ((and (eq aarray *input-editor-command-aarray*) bucky-p - (eq keysym ':-)) ;a smiley face indeed! + (eq keysym ':|-|)) -1) (t (second (find gesture aarray :key #'first :test #'keyboard-event-matches-gesture-name-p)))))))) -(defmacro define-input-editor-command ((name &key (rescan T) (type 'motion) history) +(defmacro define-input-editor-command ((name &key (rescan t) (type 'motion) history) arglist &body body) (multiple-value-bind (arglist ignores) (canonicalize-and-match-lambda-lists *ie-command-arglist* arglist) @@ -309,32 +312,36 @@ (define-input-editor-command (com-ie-forward-character :rescan nil) (stream input-buffer numeric-argument) - (repeat numeric-argument - (let ((p (forward-or-backward input-buffer (insertion-pointer stream) nil #'true))) + (repeat (abs numeric-argument) + (let ((p (forward-or-backward input-buffer (insertion-pointer stream) + (minusp numeric-argument) #'true))) (if p (setf (insertion-pointer stream) p) (return (beep stream)))))) (define-input-editor-command (com-ie-forward-word :rescan nil) (stream input-buffer numeric-argument) - (repeat numeric-argument - (let ((p (move-over-word input-buffer (insertion-pointer stream) nil))) + (repeat (abs numeric-argument) + (let ((p (move-over-word input-buffer (insertion-pointer stream) + (minusp numeric-argument)))) (if p (setf (insertion-pointer stream) p) (return (beep stream)))))) (define-input-editor-command (com-ie-backward-character :rescan nil) (stream input-buffer numeric-argument) - (repeat numeric-argument - (let ((p (forward-or-backward input-buffer (insertion-pointer stream) t #'true))) + (repeat (abs numeric-argument) + (let ((p (forward-or-backward input-buffer (insertion-pointer stream) + (plusp numeric-argument) #'true))) (if p (setf (insertion-pointer stream) p) (return (beep stream)))))) (define-input-editor-command (com-ie-backward-word :rescan nil) (stream input-buffer numeric-argument) - (repeat numeric-argument - (let ((p (move-over-word input-buffer (insertion-pointer stream) t))) + (repeat (abs numeric-argument) + (let ((p (move-over-word input-buffer (insertion-pointer stream) + (plusp numeric-argument)))) (if p (setf (insertion-pointer stream) p) (return (beep stream)))))) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 18afb5d8..ba15bbb1 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.12 92/04/21 16:13:08 cer Exp Locker: cer $ +;; $fiHeader: input-protocol.lisp,v 1.13 92/05/07 13:12:34 cer Exp $ (in-package :clim-internals) @@ -76,29 +76,20 @@ :root (window-root stream))))))) (defmethod initialize-instance :after ((stream input-protocol-mixin) - &key - #+Silica (initial-cursor-visibility t) - #-Silica (initial-cursor-visibility ':inactive)) + &key (initial-cursor-visibility t)) (with-slots (text-cursor) stream - #+Silica (when text-cursor (setf (cursor-active text-cursor) initial-cursor-visibility) - (setf (cursor-stream text-cursor) stream)) - #-Silica - (when text-cursor - (setf (cursor-stream text-cursor) stream) - (setf (cursor-visibility text-cursor) initial-cursor-visibility)))) + (setf (cursor-stream text-cursor) stream)))) -;;; --- Cross-protocol violation here because CURSOR-POSITION is a method on -;;; --- extended-OUTPUT-protocol right now. Secondly, this should probably be a -;;; --- method on the abstract class, anyway. -#+Silica +;;--- Cross-protocol violation here because CURSOR-POSITION is a method on +;;--- extended-OUTPUT-protocol right now. Secondly, this should probably be a +;;--- method on the abstract class, anyway. (defmethod stream-set-cursor-position :after ((stream input-protocol-mixin) x y) (let ((cursor (stream-text-cursor stream))) (when cursor (cursor-set-position cursor x y)))) -#+Silica (defmethod stream-set-cursor-position-internal :after ((stream input-protocol-mixin) x y) (let ((cursor (stream-text-cursor stream))) (when cursor @@ -111,7 +102,6 @@ (when cursor (setf (cursor-active cursor) nil)))) -#+Silica (defmethod handle-repaint :after ((stream input-protocol-mixin) medium (region nowhere)) (declare (ignore medium)) ;; Repainting nowhere, don't repaint the cursor @@ -136,25 +126,19 @@ (defmethod pointer-motion-pending ((stream input-protocol-mixin) &optional - (pointer #+Ignore (stream-primary-pointer stream))) + (pointer #+++ignore (stream-primary-pointer stream))) (declare (ignore pointer)) ;--- (with-slots (pointer-motion-pending) stream (prog1 pointer-motion-pending (setf pointer-motion-pending nil)))) -(defmethod (setf pointer-motion-pending) (new-value - (stream input-protocol-mixin) - &optional (pointer - #+Ignore (stream-primary-pointer stream))) +(defmethod (setf pointer-motion-pending) (new-value (stream input-protocol-mixin) + &optional (pointer #+++ignore (stream-primary-pointer stream))) (declare (ignore pointer)) ;--- (with-slots (pointer-motion-pending) stream (setf pointer-motion-pending new-value))) -#+Silica -(progn -;;; --- assumes that input-protocol-mixin will be mixed in with a sheet that -;;; has standard-input-contract (defmethod queue-event ((stream input-protocol-mixin) (event key-press-event)) (let ((char (keyboard-event-character event)) (keysym (keyboard-event-key-name event))) @@ -224,18 +208,11 @@ (defmethod queue-event ((stream input-protocol-mixin) (event window-repaint-event)) (queue-put (stream-input-buffer stream) (copy-event event))) -) ;#+Silica (defmethod (setf window-visibility) :after (visibility (stream input-protocol-mixin)) (declare (ignore visibility)) (ensure-pointer-window stream)) -(defmethod window-stack-on-top :after ((stream input-protocol-mixin)) - (ensure-pointer-window stream)) - -(defmethod window-stack-on-bottom :after ((stream input-protocol-mixin)) - (ensure-pointer-window stream)) - (defun ensure-pointer-window (window) #-Silica (dolist (pointer (stream-pointers window)) @@ -304,7 +281,6 @@ (funcall input-wait-handler stream))) (otherwise (when input-happened - #+Silica (let ((gesture (queue-get (stream-input-buffer stream)))) (when gesture ;;--- What we *should* do is to reinstate a separate input @@ -322,33 +298,7 @@ gesture))) (when new-gesture (when peek-p (queue-unget (stream-input-buffer stream) gesture)) - (return-from stream-read-gesture new-gesture))))) - #-Silica - (with-slots (input-buffer) stream - (let ((gesture (queue-get input-buffer))) - (when gesture - (when peek-p - (queue-unget input-buffer gesture)) - ;; --- Foo. I can't find a general way to communicate from the outside - ;; (i.e. the global event process) that something has happened that the - ;; application should care about. - ;; Add this kludge until BSG's gesture preprocessor (or something) gets - ;; installed. This could throw when there is no catch tag, but I don't - ;; know how to tell if we are within run-frame-top-level. - (cond ((and (characterp gesture) - (member gesture *accelerator-gestures*)) - (signal 'accelerator-gesture - :event gesture - :numeric-argument (or *accelerator-numeric-argument* 1))) - ((and (characterp gesture) - (member gesture *abort-gestures*)) - (let ((cursor (slot-value stream 'text-cursor))) - (when (and cursor - (cursor-active-p cursor)) - (write-string "[Abort]" stream) - (force-output stream))) - (error 'abort-gesture :event gesture)) - (t (return-from stream-read-gesture gesture))))))))))))) + (return-from stream-read-gesture new-gesture)))))))))))) ;; Presentation translators have probably already run... (defmethod receive-gesture @@ -359,6 +309,15 @@ nil) gesture)) +;;--- This is horrible. --cer +;;--- A higher level will have to ignore this in some cases, or else we +;;--- get release events in input buffers (such as after clicking on +;;--- something to invoke a translator). --SWM +(defmethod receive-gesture + ((stream input-protocol-mixin) (gesture pointer-button-release-event)) + ;; don't translate it + gesture) + (defmethod receive-gesture ((stream input-protocol-mixin) (gesture (eql ':resynchronize))) (throw 'resynchronize t)) @@ -420,14 +379,7 @@ (defmethod receive-gesture ((stream input-protocol-mixin) (gesture event)) (process-event-locally stream gesture) nil) - -;;;--- This is horrible - -(defmethod receive-gesture - ((stream input-protocol-mixin) (gesture pointer-button-release-event)) - ;; don't translate it - gesture) - + (defmethod receive-gesture ((stream input-protocol-mixin) gesture) ;; don't translate it @@ -582,7 +534,7 @@ (with-slots (input-buffer) stream (unless (queue-empty-p input-buffer) (return-from stream-input-wait t)) - ;; Non-silica version is always one-process + ;; Non-Silica version is always one-process (loop (let ((flag (stream-event-handler stream :timeout timeout :input-wait-test input-wait-test))) @@ -604,8 +556,8 @@ ;; Will go blocked if there are no pending events, which unfortunately puts ;; the input-wait-test function out of commission. Need to get the "process-wait" ;; story straight. - ;; Non-silica version is always one-process - + ;; Silica version is always multi-process + ;;--- This won't work on Cloe, what can we steal from the #-Silica stuff? (let* ((flag nil) (start-time (get-internal-real-time)) (end-time (and timeout @@ -710,61 +662,19 @@ (stream-set-pointer-position stream x y)) ;;; The primitive we are interested in. The pointer is in inside-host-window coords. -#+Silica (defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer) (declare (ignore timeout)) (let ((pointer (or pointer (stream-primary-pointer stream)))) (pointer-position pointer))) -#-Silica -(defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer) - ;; Process any pending pointer motion events. - (stream-event-handler stream :timeout timeout) - (let ((pointer (or pointer (stream-primary-pointer stream)))) - (multiple-value-bind (left top) (window-offset stream) - (declare (type coordinate left top)) - (if pointer - (multiple-value-bind (x y) (pointer-position pointer) - (declare (type coordinate x y)) - (values (- x left) (- y top))) - (values (coordinate 0) (coordinate 0)))))) - (defun set-stream-pointer-position-in-window-coordinates (stream x y &key pointer) (declare (type real x y)) (unless pointer (setf pointer (stream-primary-pointer stream))) (setf (pointer-position-changed pointer) t) - #+Silica - (pointer-set-position pointer x y) - #-Silica - (multiple-value-bind (left top) (window-offset stream) - (declare (type coordinate left top)) - (set-stream-pointer-in-screen-coordinates - stream pointer (+ x left) (+ y top)))) - -#-Silica -(defmethod stream-note-pointer-button-press ((stream input-protocol-mixin) - pointer button modifier-state x y) - (declare (ignore pointer)) - (with-slots (input-buffer) stream - (queue-put input-buffer - (make-button-press-event stream - (coordinate x) (coordinate y) - button modifier-state)))) - -#-Silica -(defmethod stream-note-pointer-button-release ((stream input-protocol-mixin) - pointer button modifier-state x y) - (declare (ignore pointer)) - (with-slots (input-buffer) stream - (queue-put input-buffer - (make-button-release-event stream - (coordinate x) (coordinate y) - button modifier-state)))) + (pointer-set-position pointer x y)) -#+Silica (defmethod stream-set-input-focus ((stream input-protocol-mixin)) (setf (port-keyboard-input-focus (port stream)) stream)) -#+Silica (defmethod stream-restore-input-focus ((stream input-protocol-mixin) old-focus) (setf (port-keyboard-input-focus (port stream)) old-focus)) diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index b1f647e3..b5854b74 100644 --- a/clim/interactive-defs.lisp +++ b/clim/interactive-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-defs.lisp,v 1.7 92/03/10 15:40:12 cer Exp $ +;; $fiHeader: interactive-defs.lisp,v 1.8 92/05/07 13:12:36 cer Exp $ (in-package :clim-internals) @@ -51,12 +51,12 @@ ,@body)) (defun activation-gesture-p (gesture) - (and (not (typep gesture 'pointer-button-release-event)) + (and (not (typep gesture 'pointer-event)) ;--- kludge (dolist (set *activation-gestures*) (when (if (listp set) (member gesture set :test #'keyboard-event-matches-gesture-name-p) - (funcall set gesture)) + (funcall set gesture)) (return-from activation-gesture-p t))))) #+CLIM-1-compatibility @@ -89,12 +89,13 @@ ,@body)) (defun delimiter-gesture-p (gesture) - (dolist (set *delimiter-gestures*) - (when (if (listp set) - (member gesture set - :test #'keyboard-event-matches-gesture-name-p) - (funcall set gesture)) - (return-from delimiter-gesture-p t)))) + (and (not (typep gesture 'pointer-event)) ;---kludge + (dolist (set *delimiter-gestures*) + (when (if (listp set) + (member gesture set + :test #'keyboard-event-matches-gesture-name-p) + (funcall set gesture)) + (return-from delimiter-gesture-p t))))) #+CLIM-1-compatibility (progn @@ -168,7 +169,7 @@ ((ordinary-char-p gesture) (vector-push-extend gesture string) ;;--- haven't updated WRITE-CHAR yet - #+ignore (write-char gesture stream)) + #+++ignore (write-char gesture stream)) (t (beep stream)))) (t (return-token gesture)))))))) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index f4300202..51376adb 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-protocol.lisp,v 1.7 92/04/15 11:46:51 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.8 92/05/07 13:12:37 cer Exp $ (in-package :clim-internals) @@ -187,7 +187,7 @@ (setq noise-string next-char) ;---so what do we do with NOISE-STRING? (incf scan-pointer)) (t (when (< scan-pointer insertion-pointer) - #+ignore (error "Trying to make a noise string while rescanning") + #+++ignore (error "Trying to make a noise string while rescanning") (return-from prompt-for-accept (values))) (setq noise-string (make-noise-string @@ -761,36 +761,29 @@ &optional (start-position 0)) (with-slots (stream) istream - ;; --- should we just require that the encapsulated stream - ;; support the graphics protocol?? - ;; To avoid different kinds of input editors for the two commonest cases. - (cond (#+Silica t - #-Silica (graphics-stream-p stream) - (let (oleft otop oright obottom) - ;; Assumptions: 1. Erasure happens left-to-right, top-to-bottom (just - ;; like text output). 2. Nothing interesting appears on the screen below - ;; and to the right of text from the input editor. We merge erasures so - ;; as to erase as few rectangles as possible. - (labels ((erase-merged-stuff () - (draw-rectangle-internal stream (coordinate 0) (coordinate 0) - oleft otop oright obottom - +background-ink+ nil)) - (erase-screen-piece (left top right bottom extra) - (declare (ignore extra)) - (cond ((null oleft) ;First rectangle - (setf oleft left otop top oright right obottom bottom)) - ((= otop top) ;Same line - (maxf oright right) (maxf obottom bottom) (minf oleft left)) - ((<= oleft left) ;Further down, same or larger indent - (maxf oright right) (maxf obottom bottom)) - (t ;next line is further left than previous - (erase-merged-stuff) - (setf oleft left otop top oright right obottom bottom))))) - (declare (dynamic-extent #'erase-merged-stuff #'erase-screen-piece)) - (do-input-buffer-screen-real-estate istream #'erase-screen-piece start-position) - (when oleft (erase-merged-stuff))))) - ;; just reprompt on the next line. - (t (terpri stream))))) + (let (oleft otop oright obottom) + ;; Assumptions: 1. Erasure happens left-to-right, top-to-bottom (just + ;; like text output). 2. Nothing interesting appears on the screen below + ;; and to the right of text from the input editor. We merge erasures so + ;; as to erase as few rectangles as possible. + (labels ((erase-merged-stuff () + (draw-rectangle-internal stream (coordinate 0) (coordinate 0) + oleft otop oright obottom + +background-ink+ nil)) + (erase-screen-piece (left top right bottom extra) + (declare (ignore extra)) + (cond ((null oleft) ;First rectangle + (setf oleft left otop top oright right obottom bottom)) + ((= otop top) ;Same line + (maxf oright right) (maxf obottom bottom) (minf oleft left)) + ((<= oleft left) ;Further down, same or larger indent + (maxf oright right) (maxf obottom bottom)) + (t ;next line is further left than previous + (erase-merged-stuff) + (setf oleft left otop top oright right obottom bottom))))) + (declare (dynamic-extent #'erase-merged-stuff #'erase-screen-piece)) + (do-input-buffer-screen-real-estate istream #'erase-screen-piece start-position) + (when oleft (erase-merged-stuff)))))) ;;--- This mechanism is only partially implemented. In order to work better, ;;--- it requires that the IE maintain its own concept of the prompt. diff --git a/clim/item-list-manager.lisp b/clim/item-list-manager.lisp index 46d50c38..0a79dd52 100644 --- a/clim/item-list-manager.lisp +++ b/clim/item-list-manager.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: item-list-manager.lisp,v 1.1 92/01/31 14:27:57 cer Exp $ +;; $fiHeader: item-list-manager.lisp,v 1.2 92/02/24 13:08:00 cer Exp $ (in-package :clim-internals) @@ -31,7 +31,7 @@ (error "Could not find :after-item ~S in item-list" after-item))) (cond (before-index ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0 - #+Ignore + #+++ignore (assert (< -1 before-index (max 1 (length item-list))) () "The :before-index was ~D which is outside the bounds of the item-list" before-index) @@ -40,7 +40,7 @@ (push new-item (cdr (nthcdr (1- before-index) item-list))))) (after-index ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0 - #+Ignore + #+++ignore (assert (< -1 after-index (max 1 (length item-list))) () "The :after-index was ~D which is outside the bounds of the item-list" after-index) diff --git a/clim/menus.lisp b/clim/menus.lisp index c5b0360b..4e646793 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.21 92/05/06 15:37:41 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.22 92/05/07 13:12:39 cer Exp $ (in-package :clim-internals) @@ -9,9 +9,8 @@ (defvar *abort-menus-when-buried* t) -#+Silica (define-application-frame menu-frame () - (menu) + (menu) (:pane (with-slots (menu) *application-frame* (outlining () @@ -24,101 +23,28 @@ (and (boundp '*application-frame*) *application-frame*)) +;; Returns a stream that corresponds to the pane holding the menu (defun get-menu (&key port) (let ((frame (make-application-frame 'menu-frame :parent port :save-under t))) (values (slot-value frame 'menu) frame))) -;; This stub is used by implementations to create a new subclass -;; (of window-stream) for menus if desired -#-Silica -(defmethod menu-class-name (root) - (class-name (class-of root))) - -;;--- This associated-window/root stuff is pretty irksome. -;;--- Menus should really be application frames. -#-Silica -(defresource menu (associated-window root) - :constructor (open-window-stream :parent root ;"random" size - :left 100 :top 100 :width 300 :height 200 - :scroll-bars ':vertical - :window-class (menu-class-name root) - :save-under T) - ;; We used to have an initializer that set RECORD-P, cleared the window, - ;; and set the size. RECORD-P is unnecessary because we explicitly bind it - ;; below when drawing the menu contents. (Also, it should always be T - ;; anyway.) Clearing the window is unnecessary because it's done in the - ;; deinitializer. Setting the size is also unnecessary. Any application - ;; that's formatting into a menu is required to use WITH-END-OF-LINE-ACTION - ;; and WITH-END-OF-PAGE-ACTION or set the size first itself. - :initializer (initialize-menu menu associated-window) - ;; Deexpose the menu, and clear it so that the GC can reclaim any - ;; garbage output records. - :deinitializer (progn - (setf (window-visibility menu) nil) - (window-clear menu) - (setf (window-label menu) nil)) - :matcher (eq (window-parent menu) root)) - -#+Silica (defresource menu (associated-window root) :constructor (let* ((port (if (null root) (find-port) (port root)))) (get-menu :port port)) :deinitializer (window-clear menu) - ;; We used to have an initializer that set record-p, cleared the window, and set - ;; the size. Record-p is unnecessary because we explicitly bind it below - ;; when drawing the menu contents. (Also, it should always be T anyway.) - ;; Clearing the window is unnecessary because it's done in the deinitializer. - ;; Setting the size is also unnecessary. Any application that's formatting - ;; into a menu is required to use with-end-of-line-action and with-end-of-page-action - ;; or set the size first itself. :initializer (initialize-menu (port menu) menu associated-window) - ;; horrible kludge in the case where no associated window is passed in. + ;; Horrible kludge in the case where no associated window is passed in. :matcher (eq (port menu) (port root))) -#-Silica -;; no window-mixin -(defmethod initialize-menu ((menu window-mixin) associated-window) - (declare (ignore associated-window)) - ) - -#+Silica (defmethod initialize-menu ((port port) window associated-window) (declare (ignore window associated-window)) ) -#-Silica -(defun size-menu-appropriately (menu &key width height (right-margin 10) (bottom-margin 10)) - (with-slots (output-record parent) menu - (with-bounding-rectangle* (left top right bottom) output-record - (let ((width (or width (- right left))) - (height (or height (- bottom top)))) - (multiple-value-bind (label-width label-height) - (window-label-size menu) - (multiple-value-bind (parent-width parent-height) - (window-inside-size parent) - (multiple-value-bind (lm tm rm bm) - (host-window-margins menu) - (multiple-value-bind (wlm wtm wrm wbm) - (window-margins menu) - (bounding-rectangle-set-size - menu - (min (+ (max label-width width) right-margin wlm wrm lm rm) - parent-width) - (min (+ (max label-height height) bottom-margin wtm wbm tm bm) - parent-height))))))) - (window-set-viewport-position menu left top) - ;; blech - (clear-input menu)))) - -#+Silica -(defun size-menu-appropriately (menu &key - width height - (right-margin 10) - (bottom-margin 10) - (size-fn - #'window-set-inside-size)) +(defun size-menu-appropriately (menu &key width height + (right-margin 10) (bottom-margin 10) + (size-setter #'window-set-inside-size)) (with-slots (output-record) menu (with-bounding-rectangle* (left top right bottom) output-record (let* ((graft (graft menu)) @@ -126,13 +52,11 @@ (gh (bounding-rectangle-height (sheet-region graft))) (width (min gw (+ (or width (- right left)) right-margin))) (height (min gh (+ (or height (- bottom top)) bottom-margin)))) - (funcall size-fn menu width height) + (funcall size-setter menu width height) (window-set-viewport-position menu left top))))) - -#-Silica (defun position-window-near-carefully (window x y) - ;; unfortunately, the mouse-position is in window-parent coordinates + #-Silica (multiple-value-bind (width height) (bounding-rectangle-size window) (multiple-value-bind (parent-width parent-height) (window-inside-size (window-parent window)) @@ -147,22 +71,11 @@ (bounding-rectangle-set-position window (max 0 left) (max 0 top)))))) -#-Silica (defun position-window-near-pointer (window &optional x y) (unless (and x y) (multiple-value-setq (x y) - (stream-pointer-position-in-window-coordinates (window-parent window)))) - (position-window-near-carefully window x y)) - -#+Silica -(defun position-window-near-carefully (window x y) - ) - -#+Silica -(defun position-window-near-pointer (window &optional x y) - (unless (and x y) - (multiple-value-setq (x y) #+++ignore (poll-pointer (graft window)) - #---ignore (values 100 100))) + #+++ignore (pointer-position (port-pointer (port window))) + #---ignore (values 100 100))) (position-window-near-carefully window x y)) ;; items := (item*) @@ -335,28 +248,30 @@ (cell-align-x ':left) (cell-align-y ':top) pointer-documentation) (declare (values value chosen-item gesture)) - (declare (ignore default-item default-style + (declare (ignore associated-window + default-item default-style label printer presentation-type cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing cell-align-x cell-align-y pointer-documentation)) (declare (dynamic-extent keys)) - (apply #'port-menu-choose (port associated-window) items keys)) + (apply #'frame-manager-menu-choose (frame-manager *application-frame*) items keys)) ;; Specific ports can put :AROUND methods on this in order to use their own ;; kinds of menus. -(defmethod port-menu-choose ((port t) items &rest keys - &key (associated-window - (frame-top-level-sheet *application-frame*)) - default-item default-style - label printer presentation-type - (cache nil) (unique-id items) (id-test #'equal) - (cache-value items) (cache-test #'equal) - max-width max-height n-rows n-columns - x-spacing y-spacing - (cell-align-x ':left) (cell-align-y ':top) - pointer-documentation) +(defmethod frame-manager-menu-choose + ((framem standard-frame-manager) items &rest keys + &key (associated-window + (frame-top-level-sheet *application-frame*)) + default-item default-style + label printer presentation-type + (cache nil) (unique-id items) (id-test #'equal) + (cache-value items) (cache-test #'equal) + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + pointer-documentation) (declare (values value chosen-item gesture)) (declare (ignore keys)) (flet ((present-item (item stream) @@ -370,7 +285,7 @@ #+Lucid (items items)) (with-menu (menu associated-window) (setf (window-label menu) label) - #+Silica (reset-frame (pane-frame menu) :title label) + (reset-frame (pane-frame menu) :title label) (with-text-style (menu default-style) (with-end-of-line-action (menu :allow) (loop @@ -398,7 +313,7 @@ default-item nil cache nil) (clear-output-history menu)) - (t (return-from port-menu-choose + (t (return-from frame-manager-menu-choose (values (menu-item-value item) item gesture)))))))))))) @@ -417,9 +332,6 @@ (defmethod invoke-with-menu-as-popup ((window t) continuation) (funcall continuation)) -#+Allegro -(defvar *click-outside-menu-handler* nil) - ;; The drawer gets called with (stream presentation-type &rest drawer-args). ;; It can use presentation-type for its own purposes. The most common uses are: ;; 1) Using that type as the presentation-type of the presentations it makes for each item @@ -452,7 +364,6 @@ (*input-context* nil) (*accept-help* nil) (*assume-all-commands-enabled* nil) - #-Silica (*sizing-application-frame* nil) (*command-parser* 'command-line-command-parser) (*command-unparser* 'command-line-command-unparser) (*partial-command-parser* @@ -649,7 +560,7 @@ :presentation-type presentation-type :drawer-args drawer-args))) -;;--- How to get PORT-MENU-CHOOSE into the act here? +;;--- How to get FRAME-MANAGER-MENU-CHOOSE into the act here? (defmethod menu-choose ((static-menu static-menu) &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp index 5680c2a6..80fae920 100644 --- a/clim/noting-progress.lisp +++ b/clim/noting-progress.lisp @@ -2,8 +2,14 @@ (in-package :clim-internals) +;;; $fiHeader$ + "Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved." +;;;; frame-manager-clear-progress-note: called to make it go away +;;;; frame-manager-display-progress-note: Called to display it and +;;;; update it. +;;;; We probably need a frame-manager-make-progress-note also. (defvar *progress-notes* ()) (defvar *current-progress-note*) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 94430822..9250fd12 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.12 92/04/30 09:09:33 cer Exp Locker: cer $ +;; $fiHeader: output-protocol.lisp,v 1.13 92/05/07 13:12:41 cer Exp $ (in-package :clim-internals) @@ -46,35 +46,15 @@ (text-margin :initarg :text-margin) (default-text-margin :accessor stream-default-text-margin :initarg :default-text-margin) - #-Silica - (display-device-type :initarg :display-device-type - :accessor stream-display-device-type - :initform (error "You must supply a :DISPLAY-DEVICE-TYPE for ~ - character output devices.")) - #-Silica - (default-text-style :initarg :default-text-style - :accessor medium-default-text-style - :initform *default-text-style*) - #-Silica - (current-text-style :accessor medium-text-style - :initform *null-text-style*) (output-glyph-buffer :accessor stream-output-glyph-buffer :initarg :output-glyph-buffer) - #-Silica - (merged-text-style :initform *default-text-style*) - #-Silica - (merged-text-style-valid :initform nil - :accessor medium-merged-text-style-valid) - #+Silica - (user-transformation :initform +identity-transformation+ - :accessor stream-user-transformation) (default-view :initform +textual-view+ :accessor stream-default-view)) (:default-initargs :end-of-line-action :wrap :end-of-page-action :scroll - ;;-- Is this correct + ;;--- Is this really appropriate? :default-text-margin +largest-coordinate+ - ;;--- 16 bit indices into fonts big enough? + ;;--- 16 bit indices into fonts big enough? :output-glyph-buffer (make-array 512 :element-type '(unsigned-byte 16) :initial-element 0) :text-margin nil)) @@ -93,19 +73,14 @@ &key text-margin) (when text-margin (setq text-margin (process-spacing-arg stream text-margin 'stream-text-margin)) - (setf (slot-value stream 'text-margin) text-margin)) - #-Silica - (setf (slot-value stream 'default-text-style) - (parse-text-style (slot-value stream 'default-text-style)))) + (setf (slot-value stream 'text-margin) text-margin))) -#+Silica (defmethod (setf medium-foreground) :after (new-value (stream output-protocol-mixin)) (let ((medium (sheet-medium stream))) ;; Watch out for uninitialized MEDIUM slot. (when (and medium (typep medium 'medium)) (setf (medium-foreground medium) new-value)))) -#+Silica (defmethod (setf medium-background) :after (new-value (stream output-protocol-mixin)) (let ((medium (sheet-medium stream))) ;; Watch out for uninitialized MEDIUM slot. @@ -125,16 +100,19 @@ (setq current-text-style (parse-text-style current-text-style)) (setq merged-text-style-valid nil))) -(defmethod engraft-medium :after ((medium medium) port - (stream output-protocol-mixin)) +(defmethod engraft-medium :after ((medium medium) port (stream output-protocol-mixin)) (declare (ignore port)) ;;--- What about text style stuff, too? ;; We set the slots directly in order to avoid running any per-port ;; :AFTER methods (or whatever). That work should be done by similar ;; per-port methods on ENGRAFT-MEDIUM. (with-slots (silica::foreground silica::background) medium - (setf silica::foreground (or (medium-foreground stream) +black+) - silica::background (or (medium-background stream) +white+)))) + (setf silica::foreground (or (medium-foreground stream) + (setf (medium-foreground stream) + +black+)) + silica::background (or (medium-background stream) + (setf (medium-background stream) + +white+))))) ;;--- I sure don't like having to do this to make string streams work (defmethod stream-default-view ((stream t)) +textual-view+) @@ -151,10 +129,6 @@ (let ((text-margin (process-spacing-arg stream new-value 'stream-text-margin))) (setf (slot-value stream 'text-margin) text-margin))) -#+Silica -(defmethod get-transformation ((stream output-protocol-mixin)) - (stream-user-transformation stream)) - ;;; Genera supports passing an environment to CONSTANTP and EVAL. Allegro doesn't. ;;; Until we test all other candidates, be conservative. (defmacro with-end-of-page-action (#+CLIM-1-compatibility (stream &optional action) @@ -209,16 +183,6 @@ ,wrapped-body))) wrapped-body)) -#-Silica -(defmethod medium-merged-text-style ((stream output-protocol-mixin)) - (with-slots (current-text-style default-text-style - merged-text-style merged-text-style-valid) stream - (if merged-text-style-valid - merged-text-style - (prog1 (setf merged-text-style (merge-text-styles current-text-style - default-text-style)) - (setf merged-text-style-valid t))))) - (defmethod stream-cursor-position ((stream output-protocol-mixin)) (with-slots (cursor-x cursor-y) stream (values cursor-x cursor-y))) @@ -232,8 +196,6 @@ (setf current-line-height (coordinate 0) ;going to a new line baseline (coordinate 0))) (setf cursor-y (coordinate y)))) - #+Silica - ;;--- In the non-Silica case, this happens via an intermediary class (stream-ensure-cursor-visible stream x y)) #+CLIM-1-compatibility @@ -259,8 +221,6 @@ (setf current-line-height (coordinate 0) ;going to a new line baseline (coordinate 0))) (setf cursor-y (coordinate y)))) - #+Silica - ;;--- In the non-Silica case, this happens via an intermediary class (stream-ensure-cursor-visible stream x y)) #+Genera @@ -338,11 +298,9 @@ ) ;#+CLIM-1-compatibility -#+Silica (defmethod stream-force-output ((stream output-protocol-mixin)) (port-force-output (port stream))) -#+Silica (defmethod stream-finish-output ((stream output-protocol-mixin)) (port-finish-output (port stream))) @@ -355,16 +313,14 @@ ;stream-finish-output ;stream-force-output ;stream-clear-output -;stream-write-string-1 -;stream-write-char-1 (defmethod stream-start-line-p ((output-stream output-protocol-mixin)) (zerop (slot-value output-stream 'cursor-x))) (defmethod stream-line-column ((output-stream output-protocol-mixin)) (multiple-value-bind (origin-x origin-y space-width) - (stream-glyph-for-character output-stream #\space - (medium-merged-text-style output-stream)) + (port-glyph-for-character (port output-stream) #\space + (medium-merged-text-style output-stream)) (declare (ignore origin-x origin-y)) (multiple-value-bind (column remainder) (floor (slot-value output-stream 'cursor-x) space-width) @@ -373,8 +329,8 @@ (defmethod stream-advance-to-column ((output-stream output-protocol-mixin) column) (multiple-value-bind (origin-x origin-y space-width) - (stream-glyph-for-character output-stream #\space - (medium-merged-text-style output-stream)) + (port-glyph-for-character (port output-stream) #\space + (medium-merged-text-style output-stream)) (declare (ignore origin-x origin-y)) (let ((new-x (floor (* column space-width)))) (when (< (slot-value output-stream 'cursor-x) new-x) @@ -413,12 +369,9 @@ (setf baseline (coordinate 0) current-line-height (coordinate 0)))) -;;; --- Should probably be on some intermediary class, since it can only -;;; be run when the stream is part of a WINDSHIELD hierarchy. -#+Silica -;; --- See comment on stream-set-cursor-position -(defmethod stream-ensure-cursor-visible ((stream output-protocol-mixin) - &optional cx cy) +;;;--- Should probably be on some intermediary class, since it can only +;;;--- be run when the stream is part of a WINDSHIELD hierarchy. +(defmethod stream-ensure-cursor-visible ((stream output-protocol-mixin) &optional cx cy) (when (and (or (not (output-recording-stream-p stream)) (stream-drawing-p stream)) (pane-scroller stream)) @@ -470,12 +423,12 @@ ;; Special case so that we don't lozenge this. It is up to ;; the caller to have established the correct text style. #+CCL-2 (eql character #\CommandMark)) - (let (#+Silica (medium (sheet-medium stream)) + (let ((medium (sheet-medium stream)) (ink (medium-ink stream))) (dotimes (i 2) (multiple-value-bind (no-wrap new-cursor-x new-baseline new-height font index) - (stream-scan-character-for-writing stream #+Silica medium - character style cursor-x max-x) + (stream-scan-character-for-writing + stream medium character style cursor-x max-x) (declare (type coordinate new-cursor-x new-baseline new-height)) (when no-wrap (when record-p @@ -489,16 +442,11 @@ (setf baseline new-baseline)) ;;--- need draw-glyphs, which will take a port-specific font object, ;;--- as well as the :INK option. - #+Silica (with-identity-transformation (medium) (draw-text* medium character ; (code-char index)?? cursor-x (+ cursor-y (- baseline new-baseline)) :text-style style - :align-x :left :align-y :top)) - #-Silica - (stream-write-char-1 - stream index font ink - cursor-x (+ cursor-y (- baseline new-baseline)))) + :align-x :left :align-y :top))) (encode-stream-after-writing stream new-cursor-x cursor-y (max baseline new-baseline) (max height new-height)) @@ -619,14 +567,13 @@ (declare (type coordinate cursor-x cursor-y baseline height max-x)) (unless (or draw-p record-p) (return-from stream-write-string string)) ;No deeds to do - (let (#+Silica (medium (sheet-medium stream)) + (let ((medium (sheet-medium stream)) (ink (medium-ink stream))) (loop (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height font) - (stream-scan-string-for-writing stream #+Silica medium - string start end style - cursor-x max-x glyph-buffer) + (stream-scan-string-for-writing + stream medium string start end style cursor-x max-x glyph-buffer) (declare (type coordinate new-cursor-x new-baseline new-height)) (when record-p (stream-add-string-output @@ -643,21 +590,12 @@ (unless (zerop amount) ;; --- need draw-glyphs, which will take a port-specific font object, ;; as well as the :INK option. - #+Silica (with-identity-transformation (medium) (draw-text* medium string cursor-x (+ cursor-y (- baseline new-baseline)) :text-style style :start start :end next-char-index - :align-x :left :align-y :top)) - #-Silica - (if glyph-buffer - (stream-write-string-1 - stream glyph-buffer 0 (the fixnum (- next-char-index start)) font - ink cursor-x (+ cursor-y (- baseline new-baseline))) - (stream-write-string-1 - stream string start next-char-index font - ink cursor-x (+ cursor-y (- baseline new-baseline))))))) + :align-x :left :align-y :top))))) (setf baseline (max baseline new-baseline) height (max height new-height) cursor-x new-cursor-x) @@ -687,13 +625,13 @@ (defmethod stream-move-for-line-height-change ((stream output-protocol-mixin) movement old-height cursor-x cursor-y) ;;--- This doesn't appear to work yet, and it's "not cheap" - #+ignore (copy-area stream - 0 cursor-y - cursor-x (+ cursor-y old-height) - 0 (+ cursor-y movement)) - #+ignore (window-clear-area stream - 0 cursor-y - cursor-x (+ cursor-y movement))) + #+++ignore (copy-area stream + 0 cursor-y + cursor-x (+ cursor-y old-height) + 0 (+ cursor-y movement)) + #+++ignore (window-clear-area stream + 0 cursor-y + cursor-x (+ cursor-y movement))) ;;; Simple version: does no wrapping, assumes we start at leftmost ;;; column. It doesn't do what Genera :STRING-LENGTH message does, @@ -709,13 +647,12 @@ (baseline (coordinate 0)) (largest-x (coordinate 0))) (declare (type coordinate cursor-x cursor-y height baseline largest-x)) - (let (#+Silica (medium (sheet-medium stream))) + (let ((medium (sheet-medium stream))) (loop (when (>= start end) (return)) (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height) - (stream-scan-string-for-writing stream #+Silica medium - string start end style - cursor-x +largest-coordinate+) + (stream-scan-string-for-writing + stream medium string start end style cursor-x +largest-coordinate+) (declare (type coordinate new-cursor-x new-baseline new-height)) (maxf largest-x new-cursor-x) (maxf baseline new-baseline) @@ -723,7 +660,7 @@ (setf cursor-x new-cursor-x start next-char-index) (when write-char - (cond #+Ignore ;; Can't happen at the moment. + (cond #+++ignore ;; Can't happen at the moment. ((or (graphic-char-p write-char) (diacritic-char-p write-char)) (multiple-value-bind (no-wrap new-cursor-x new-baseline new-height) (stream-scan-character-for-writing stream character style @@ -765,7 +702,7 @@ (cond ((or (graphic-char-p character) (diacritic-char-p character)) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y) - (stream-glyph-for-character stream character style) + (port-glyph-for-character (port stream) character style) (declare (ignore index font escapement-x escapement-y origin-x origin-y)) (values bb-x bb-y))) ((or (eql character #\Newline) @@ -786,37 +723,21 @@ (let ((current-line-height (stream-current-line-height stream))) (if (or text-style (zerop current-line-height)) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y) - (stream-glyph-for-character stream #\Space - (or text-style - (medium-merged-text-style stream))) + (port-glyph-for-character (port stream) #\Space + (or text-style + (medium-merged-text-style stream))) (declare (ignore index font escapement-x escapement-y origin-x origin-y bb-x)) (coordinate bb-y)) current-line-height))) (defmethod stream-tab-size ((stream output-protocol-mixin) text-style) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y) - (stream-glyph-for-character stream #\n ;En space - (or text-style - (medium-merged-text-style stream))) + (port-glyph-for-character (port stream) #\n ;En space + (or text-style + (medium-merged-text-style stream))) (declare (ignore index font escapement-y origin-x origin-y bb-y)) (coordinate (* (max bb-x escapement-x) 8.)))) -;;;--- These forwarding methods are for Silica conversion convenience only. -;;; Their callers should be changed to invoke the method on the medium directly. -#+Silica -(defmethod stream-glyph-for-character ((stream output-protocol-mixin) character appearance &optional our-font) - (stream-glyph-for-character (sheet-medium stream) character appearance our-font)) - -#+Silica -(defmethod stream-write-char-1 ((stream output-protocol-mixin) index x-font color x y) - (stream-write-char-1 (sheet-medium stream) index x-font color x y)) - -;;;--- This forwarding method is for Silica conversion convenience only. -#+Silica -(defmethod stream-write-string-1 ((stream output-protocol-mixin) - glyph-buffer start end x-font color x y) - (stream-write-string-1 (sheet-medium stream) glyph-buffer start end x-font color x y)) - ;;; A few utilities for string writing. @@ -917,13 +838,11 @@ (values character start cursor-x baseline height our-font))) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y fixed-width-font-p) - ;; --- For now we are asserting that each string passed to WRITE-STRING - ;; will have no character style changes within it. So, we can - ;; eliminate a call to TEXT-STYLE-MAPPING within - ;; STREAM-GLYPH-FOR-CHARACTER, which saves a >lot< of time. - (stream-glyph-for-character - #-Silica stream #+Silica medium - character style our-font) + ;;--- For now we are asserting that each string passed to WRITE-STRING + ;;--- will have no character style changes within it. So, we can + ;;--- eliminate a call to TEXT-STYLE-MAPPING within + ;;--- PORT-GLYPH-FOR-CHARACTER, which saves a lot of time. + (port-glyph-for-character (port medium) character style our-font) (declare (ignore escapement-y origin-x bb-x)) (declare (type fixnum index)) (let ((origin-y (coordinate origin-y)) @@ -978,7 +897,7 @@ (setf our-font font) (setq start (the fixnum (+ start 1))))))))) -(defmethod stream-scan-string-for-writing ((stream output-protocol-mixin) #+Silica medium +(defmethod stream-scan-string-for-writing ((stream output-protocol-mixin) medium string start end style cursor-x max-x &optional glyph-buffer) (declare (values write-char next-char-index new-cursor-x new-baseline new-height font)) @@ -989,12 +908,12 @@ ;;; This function returns NIL as its first value if the character won't ;;; fit on the current line. It is never called on non-graphic ;;; characters; they are handled in WRITE-CHAR instead. -(defmethod stream-scan-character-for-writing ((stream output-protocol-mixin) #+Silica medium +(defmethod stream-scan-character-for-writing ((stream output-protocol-mixin) medium character style cursor-x max-x) (declare (values char-normal new-cursor-x new-baseline new-height font)) (declare (type coordinate cursor-x max-x)) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y) - (stream-glyph-for-character medium character style) + (port-glyph-for-character (port medium) character style) (declare (ignore escapement-y origin-x bb-x)) (when (> (+ cursor-x escapement-x *character-wrap-indicator-width*) max-x) (return-from stream-scan-character-for-writing @@ -1031,6 +950,46 @@ (let ((tab-size (stream-tab-size stream style))) (coordinate (* tab-size (ceiling (1+ cursor-x) tab-size))))) + +;;; Speedy, bare-bones drawing functions for things like highlighting + +(defun draw-line-internal + (stream xoff yoff x1 y1 x2 y2 ink style) + (let ((medium (sheet-medium stream))) + (letf-globally (((medium-line-style medium) + (or style (medium-line-style medium))) + ((medium-transformation medium) +identity-transformation+) + ((medium-ink medium) ink)) + (medium-draw-line* medium + (+ x1 xoff) (+ y1 yoff) + (+ x2 xoff) (+ y2 yoff))))) + +(defun draw-rectangle-internal + (stream xoff yoff left top right bottom ink style) + (let ((medium (sheet-medium stream))) + (letf-globally (((medium-line-style medium) + (or style (medium-line-style medium))) + ((medium-transformation medium) +identity-transformation+) + ((medium-ink medium) ink)) + (medium-draw-rectangle* medium + (+ left xoff) (+ top yoff) + (+ right xoff) (+ bottom yoff) + (not style))))) + +(defun draw-ellipse-internal + (stream xoff yoff center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink style) + (let ((medium (sheet-medium stream))) + (letf-globally (((medium-line-style medium) + (or style (medium-line-style medium))) + ((medium-transformation medium) +identity-transformation+) + ((medium-ink medium) ink)) + (medium-draw-ellipse* medium + (+ center-x xoff) (+ center-y yoff) + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle (not style))))) + ;;; Genera hooks @@ -1127,14 +1086,13 @@ (unless start (setq start 0)) (unless end (setq end (length string))) (let ((vsp (stream-vertical-spacing stream)) - #+Silica (medium (sheet-medium stream))) + (medium (sheet-medium stream))) (loop (when (>= start end) (return (values cursor-x cursor-y height baseline))) (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height) - (stream-scan-string-for-writing stream #+Silica medium - string start end style - cursor-x max-x) + (stream-scan-string-for-writing + stream medium string start end style cursor-x max-x) (maxf height new-height) (maxf baseline new-baseline) (setf start next-char-index) diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp index d8f3b381..7e49b469 100644 --- a/clim/pixmap-streams.lisp +++ b/clim/pixmap-streams.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pixmap-streams.lisp,v 1.4 92/04/21 16:13:12 cer Exp Locker: cer $ +;; $fiHeader: pixmap-streams.lisp,v 1.5 92/05/07 13:12:43 cer Exp $ (in-package :clim-internals) @@ -43,20 +43,16 @@ (defmethod update-mirror-region ((port port) (sheet pixmap-stream)) nil) -(defmethod initialize-instance :after ((stream pixmap-stream) &key - port - pixmap - width - height - sheet) +(defmethod initialize-instance :after ((stream pixmap-stream) + &key port sheet pixmap + width height) (setf (sheet-direct-mirror stream) pixmap (port stream) port (sheet-transformation stream) +identity-transformation+ (sheet-region stream) (make-bounding-rectangle 0 0 width height) - ;;-- What about text style - (medium-foreground stream) (medium-foreground sheet) - (medium-background stream) (medium-background sheet))) - + ;;--- What about text style? + (medium-foreground stream) (or (medium-foreground sheet) +black+) + (medium-background stream) (or (medium-background sheet) +white+))) ;; Interface to this stuff @@ -80,12 +76,12 @@ (defmethod allocate-pixmap-stream (sheet pixmap width height) (make-instance 'pixmap-stream - :sheet sheet :default-text-margin width :pixmap pixmap :width width :height height - :port (port sheet))) + :port (port sheet) + :sheet sheet)) (defun copy-from-pixmap (pixmap pixmap-x pixmap-y width height stream window-x window-y) diff --git a/clim/presentations.lisp b/clim/presentations.lisp index 732d2bc1..00e0dcc9 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.8 92/04/15 11:47:04 cer Exp $ +;; $fiHeader: presentations.lisp,v 1.9 92/05/07 13:12:50 cer Exp $ (in-package :clim-internals) @@ -383,16 +383,14 @@ (highlight-output-record history-window highlighted-presentation :unhighlight) (setf highlighted-presentation nil) - (when *pointer-documentation-output* - (frame-document-highlighted-presentation - frame highlighted-presentation - input-context history-window px py - *pointer-documentation-output*))) + (frame-document-highlighted-presentation + frame highlighted-presentation + input-context history-window px py + *pointer-documentation-output*)) ((eq presentation highlighted-presentation) ;; Over the same presentation as before - (when (and *pointer-documentation-output* - (/= (window-modifier-state history-window) - *last-pointer-documentation-modifier-state*)) + (when (/= (window-modifier-state history-window) + *last-pointer-documentation-modifier-state*) (frame-document-highlighted-presentation frame presentation input-context history-window px py @@ -405,11 +403,10 @@ history-window highlighted-presentation :unhighlight)) (highlight-output-record history-window presentation :highlight) (setf highlighted-presentation presentation) - (when *pointer-documentation-output* - (frame-document-highlighted-presentation - frame presentation - input-context history-window px py - *pointer-documentation-output*)))))))))) + (frame-document-highlighted-presentation + frame presentation + input-context history-window px py + *pointer-documentation-output*))))))))) (defun highlighted-presentation (stream &optional (prefer-pointer-window t)) (let ((history-window (if prefer-pointer-window (find-appropriate-window stream) stream))) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index 39193b36..6c52f91a 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes1.lisp,v 1.10 92/04/15 11:47:07 cer Exp $ +;; $fiHeader: ptypes1.lisp,v 1.11 92/05/07 13:12:51 cer Exp $ (in-package :clim-internals) @@ -280,7 +280,7 @@ ;; The following would be "the right thing," but it doesn't work because some compilers ;; evaluate the MAKE-LOAD-FORM forms out of order with the top-level forms, so the ;; presentation type class might not be defined yet when this is evaluated. - #+ignore `(find-presentation-type-class ',(class-presentation-type-name object)) + #+++ignore `(find-presentation-type-class ',(class-presentation-type-name object)) ;; So do this instead `(load-reference-to-presentation-type-class ',(class-presentation-type-name object #+(or Genera Minima) 'compile-file) @@ -397,14 +397,6 @@ (defmethod acceptable-presentation-type-class ((class ccl::compile-time-class)) nil) -#+Allegro -(progn -(warn "~S for ~S should be elsewhere" 'clos::class-prototype 'clos::structure-class) - -(defmethod clos::class-prototype ((class clos::structure-class)) - (allocate-instance class)) -) ;#+Allegro - ;;;; Retrieving Information about a Presentation Type or P.T. Abbreviation diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index b764be15..e3589ef8 100644 --- a/clim/ptypes2.lisp +++ b/clim/ptypes2.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes2.lisp,v 1.6 92/04/15 11:47:10 cer Exp $ +;; $fiHeader: ptypes2.lisp,v 1.7 92/05/07 13:12:54 cer Exp $ (in-package :clim-internals) @@ -96,11 +96,7 @@ (describe-presentation-type presentation-type stream plural-count)) (let ((type (expand-presentation-type-abbreviation presentation-type))) (with-presentation-type-decoded (nil nil options) type - (let ((description - (or (getf options :description) - (with-presentation-type-decoded (name) presentation-type - (gethash (find-presentation-type-class name) - *presentation-type-description-table* name))))) + (let ((description (getf options :description))) (if description (default-describe-presentation-type description stream plural-count) (funcall-presentation-generic-function describe-presentation-type diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index a0286437..b22d3568 100644 --- a/clim/recording-protocol.lisp +++ b/clim/recording-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: recording-protocol.lisp,v 1.10 92/05/06 15:37:43 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.11 92/05/07 13:12:55 cer Exp $ (in-package :clim-internals) @@ -104,20 +104,19 @@ (setf right (+ nx width) bottom (+ ny height)))))) -#+ignore +#+++ignore (defmethod bounding-rectangle-set-position :around ((record output-record-element-mixin) nx ny) (with-bounding-rectangle* (x1 y1 x2 y2) record (call-next-method) (note-output-record-moved record (- nx x1) (- ny y1) (- nx x2) (- ny y2)))) -#+ignore +#+++ignore (defmethod bounding-rectangle-set-edges :around ((record output-record-element-mixin) left top right bottom) (with-bounding-rectangle* (x1 y1 x2 y2) record (call-next-method) (note-output-record-moved record (- left x1) (- top y1) (- right x2) (- bottom y2)))) -#+Silica (defmethod note-output-record-moved ((record output-record-element-mixin) dx1 dy1 dx2 dy2) (declare (ignore dx1 dy1 dx2 dy2)) nil) @@ -414,7 +413,6 @@ (defmethod children-never-overlap-p ((record output-record-mixin)) nil) -#+Silica (defmethod note-output-record-moved :after ((record output-record-mixin) dx1 dy1 dx2 dy2) (unless (and (zerop dx1) (zerop dy1) @@ -425,7 +423,6 @@ (declare (dynamic-extent #'note-moved)) (map-over-output-records #'note-moved record)))) -#+Silica (defmethod bounding-rectangle-set-position :around ((record output-record-mixin) nx ny) (multiple-value-bind (ox oy) (output-record-position record) @@ -435,7 +432,6 @@ (coordinate 1) (coordinate 1) (coordinate 1) (coordinate 1))))) -#+Silica (defmethod bounding-rectangle-set-edges :around ((record output-record-mixin) left top right bottom) (declare (ignore left top right bottom)) @@ -689,12 +685,15 @@ #'replay-1 record region (- x-offset) (- y-offset) (+ x-offset xoff) (+ y-offset yoff)) - ;;--- Nasty hack to get around nasty bug + ;;--- Nasty hack to get around nasty bug caused by + ;;--- doing things this way + #+++ignore (note-output-record-replayed record stream region x-offset y-offset)) (replay-output-record record stream region x-offset y-offset)))) (declare (dynamic-extent #'replay-1)) (replay-1 record x-offset y-offset))) +#+++ignore (defmethod note-output-record-replayed ((record output-record-mixin) stream &optional region x-offset y-offset) (declare (ignore stream region x-offset y-offset)) @@ -1074,8 +1073,8 @@ (defmethod bounding-rectangle-set-edges ((record stream-output-history-mixin) nleft ntop nright nbottom) - #+ignore (assert (<= nleft nright)) - #+ignore (assert (<= ntop nbottom)) + #+++ignore (assert (<= nleft nright)) + #+++ignore (assert (<= ntop nbottom)) (with-slots (left top right bottom parent stream) record ;; Top-level output records must not have their upper left corner any ;; "later" than (0,0), or else scroll bars and scrolling will not do @@ -1091,7 +1090,6 @@ bottom (coordinate nbottom)))) record) -#+Silica (defmethod bounding-rectangle-set-edges :around ((record stream-output-history-mixin) nleft ntop nright nbottom) (let ((nleft (coordinate nleft)) @@ -1238,7 +1236,6 @@ (stream-close-text-output-record stream)))) ;;; This method should cover a multitude of sins. -#+Silica (defmethod repaint-sheet :after ((stream output-recording-mixin) region) ;;--- Who should establish the clipping region? ;;--- Is it here or in the handle-repaint method @@ -1249,93 +1246,11 @@ (bounding-rectangle stream))))) (unless (eq clear +nowhere+) (with-sheet-medium (medium stream) - (with-bounding-rectangle* (a b c d) clear - (draw-rectangle* - medium - a b c d - :ink +background-ink+))) + (with-bounding-rectangle* (left top right bottom) clear + (draw-rectangle* medium left top right bottom + :ink +background-ink+))) (stream-replay stream region)))) - -;;; For Silica -;;;--- Consider these old methods on a case-by-case basis to see if the -;;; general handle-repaint method subsumes them. - -;;; --- should merge our process-update-region with handle-repaint -;;; Do we use it anywhere where Silica isn't generating handle-repaint? - -;;; Mix in window-output-recording when you have mixed together -;;; something supporting the window protocol and something supporting -;;; the output recording protocol. -#-Silica -(progn - -(defmethod window-process-update-region :around ((stream window-output-recording)) - (let ((update-region (slot-value stream 'update-region))) - (when update-region - (with-output-recording-options (stream :draw t :record nil) - (let ((highlighted-presentation (slot-value stream 'highlighted-presentation))) - (when highlighted-presentation - (highlight-output-record stream highlighted-presentation :unhighlight)) - (call-next-method) - (dolist (region update-region) - (with-clipping-region (stream region) - (frame-replay *application-frame* stream region))) - (when highlighted-presentation - (highlight-output-record stream highlighted-presentation :highlight)))) - (window-flush-update-region stream)))) - -;;;--- We need some version of this code to do the area copying. -(defmethod window-set-viewport-position :around ((stream window-output-recording) - new-x new-y) - (declare (ignore new-x new-y)) - (with-bounding-rectangle* (left top right bottom) (window-viewport stream) - (call-next-method) - ;; now replay - (with-bounding-rectangle* (nl nt nr nb) (window-viewport stream) - (cond - ;; if some of the stuff that was previously on display is still on display - ;; bitblt it into the proper place and redraw the rest. - ((ltrb-overlaps-ltrb-p left top right bottom - nl nt nr nb) - ;; move the old stuff to the new position - (window-shift-visible-region stream left top right bottom - nl nt nr nb) - (window-process-update-region stream)) - ;; otherwise, just redraw the whole visible viewport - ;; Adjust for the left and top margins by hand so clear-area doesn't erase - ;; the margin components. - (t (multiple-value-bind (ml mt) (window-margins stream) - (declare (type coordinate ml mt)) - (multiple-value-bind (vw vh) (window-inside-size stream) - (declare (type coordinate vw vh)) - (window-clear-area stream - ml mt (+ ml vw) (+ mt vh)))) - (frame-replay *application-frame* stream (window-viewport stream))))))) - -(defmethod window-refresh :after ((stream window-output-recording)) - ;; don't bother me, it takes too long and is useless since - ;; we'll refresh this again when it eventually becomes visible - (when (window-drawing-possible stream) - (frame-replay *application-frame* stream (window-viewport stream)) - (let ((text-record (stream-text-output-record stream))) - (when text-record (replay text-record stream))) - (redisplay-decorations stream))) - -;;; I don't think that this is needed. -(defmethod window-note-size-or-position-change :after ((stream window-output-recording) - left top right bottom) - (declare (ignore left top right bottom)) - #+Ignore - (when (window-visibility stream) - (window-refresh stream))) - -;;; --- Define Silica version of this. -(defmethod window-clear :before ((stream window-output-recording)) - (clear-output-history stream)) - -) ; end of #-Silica PROGN - ;;; Genera compatibility diff --git a/clim/stream-class-defs.lisp b/clim/stream-class-defs.lisp index fe44262e..7ef28cc6 100644 --- a/clim/stream-class-defs.lisp +++ b/clim/stream-class-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: stream-class-defs.lisp,v 1.5 92/04/15 11:47:19 cer Exp $ +;; $fiHeader: stream-class-defs.lisp,v 1.6 92/05/07 13:13:02 cer Exp $ (in-package :clim-internals) @@ -89,25 +89,8 @@ ) ;#+CLIM-1-compatibility -;;; Exists to hang window&output-recording :around methods on. -#-Silica +;; For any window-specific output recording methods (defclass window-output-recording () ()) -;;; Exists to hang window&graphics :around methods on. +;; For any window-specific graphics output recording methods (defclass graphics-output-recording () ()) - -;;; This is the class you mix in (in addition) when you've mixed together -;;; the extended-input-protocol and the window-protocol. -#-Silica -(defclass input-and-window-protocol-intermediary () ()) - -;;; This is the class you mix in (in addition) when you've mixed together -;;; the extended-output-protocol and the window-protocol. -#-Silica -(defclass output-and-window-protocol-intermediary () ()) - -;;; This is the class you mix in (in addition) when you've mixed together -;;; the extended-output-protocol and output-recording-mixin. -#-Silica -(defclass output-and-recording-protocol-intermediary () ()) - diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp index ef6a79bf..f28f8a2b 100644 --- a/clim/stream-defprotocols.lisp +++ b/clim/stream-defprotocols.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: stream-defprotocols.lisp,v 1.6 92/04/15 11:47:21 cer Exp $ +;; $fiHeader: stream-defprotocols.lisp,v 1.7 92/05/07 13:13:03 cer Exp $ (in-package :clim-internals) @@ -180,15 +180,12 @@ #+CLIM-uses-lisp-stream-functions (:no-defgeneric t)) (defoperation stream-scan-string-for-writing fundamental-character-output-stream - ((stream fundamental-character-output-stream) #+Silica medium - string start end style cursor-x max-x &optional glyph-buffer)) + ((stream fundamental-character-output-stream) + medium string start end style cursor-x max-x &optional glyph-buffer)) (defoperation stream-scan-character-for-writing fundamental-character-output-stream - ((stream fundamental-character-output-stream) #+Silica medium - character style cursor-x max-x)) - -(defoperation stream-write-string-1 fundamental-character-output-stream - ((stream fundamental-character-output-stream) glyph-buffer start end font color x y)) + ((stream fundamental-character-output-stream) + medium character style cursor-x max-x)) #+Allegro (defoperation excl::stream-interactive-force-output fundamental-output-stream @@ -347,20 +344,9 @@ ;;; window protocol -#+Silica (define-stream-protocol window-mixin) -#-Silica -(define-stream-protocol window-mixin - window-parent - window-children - window-console - window-name - window-depth - window-viewport - window-update-region - window-visibility - window-label) +;;--- What about WINDOW-VISIBILITY, and the other "inside edges" generics? (defoperation window-clear window-mixin ((window window-mixin))) @@ -387,80 +373,9 @@ (defoperation window-set-inside-size window-mixin ((window window-mixin) new-width new-height)) -#-Silica (progn -(defoperation window-stack-on-top window-mixin - ((window window-mixin))) - -(defoperation window-stack-on-bottom window-mixin - ((window window-mixin))) - -(defoperation copy-area window-mixin - ((window window-mixin) - from-left from-top from-right from-bottom to-left to-top)) - -(defoperation window-drawing-possible window-mixin - ((window window-mixin))) - -(defoperation redisplay-decorations window-mixin - ((window window-mixin)) ) - -(defoperation window-to-screen-coordinates window-mixin - ((window window-mixin) x y)) - -(defoperation screen-to-window-coordinates window-mixin - ((window window-mixin) x y)) - -(defoperation window-inside-edges window-mixin - ((window window-mixin)) - (declare (values left top right bottom))) - -(defoperation window-set-inside-edges window-mixin - ((window window-mixin) new-left new-top new-right new-bottom)) - -(defoperation window-inside-left window-mixin - ((window window-mixin))) - -(defoperation window-inside-top window-mixin - ((window window-mixin))) - -(defoperation window-inside-right window-mixin - ((window window-mixin))) - -(defoperation window-inside-bottom window-mixin - ((window window-mixin))) - -(defoperation window-inside-width window-mixin - ((window window-mixin))) - -(defoperation window-inside-height window-mixin - ((window window-mixin))) - -(defoperation window-label-size window-mixin - ((window-mixin window-mixin) &optional (label (window-label window-mixin)))) - -(defoperation window-note-size-or-position-change window-mixin - ((window window-mixin) new-left new-top new-right new-bottom)) - -(defoperation window-shift-visible-region window-mixin - ((window window-mixin) - old-left old-top old-right old-bottom - new-left new-top new-right new-bottom)) - -(defoperation window-flush-update-region window-mixin - ((window window-mixin))) - -(defoperation window-process-update-region window-mixin - ((window window-mixin))) - -(defoperation window-beep window-mixin - ((window window-mixin))) - -;;; What modifier keys are presently down? (defoperation window-modifier-state window-mixin ((window window-mixin))) -) ;#-Silica - ;;; Output recording. (define-stream-protocol output-recording-mixin @@ -494,7 +409,6 @@ ;;; Input editing stream protocol doesn't need to be encapsulated, for obvious reasons. -#+Silica (progn (define-stream-protocol pane-protocol) (defoperation pane-display-function pane-protocol @@ -508,5 +422,3 @@ (defoperation pane-frame pane-protocol ((pane pane-protocol))) - -) ;#+Silica diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp index 1c0d2307..20075c22 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.6 92/04/15 11:47:25 cer Exp $ +;; $fiHeader: table-formatting.lisp,v 1.7 92/05/07 13:13:05 cer Exp $ (in-package :clim-internals) @@ -201,7 +201,7 @@ min-y (coordinate 0) max-x (coordinate 0) max-y (coordinate 0))) - #+ignore (assert (ltrb-well-formed-p min-x min-y max-x max-y)) + #+++ignore (assert (ltrb-well-formed-p min-x min-y max-x max-y)) (translate-coordinates x-offset y-offset min-x min-y max-x max-y) (bounding-rectangle-set-edges record min-x min-y max-x max-y) (values min-x min-y max-x max-y)))) @@ -391,8 +391,7 @@ (when (> row-count 5) (with-bounding-rectangle* (tleft ttop tright tbottom) table (multiple-value-bind (stream-width stream-height) - #-Silica (window-inside-size stream) - #+Silica (bounding-rectangle-size stream) + (bounding-rectangle-size stream) (declare (type coordinate stream-width) (ignore stream-height)) ;for now (let* ((table-width (- tright tleft)) @@ -435,7 +434,7 @@ (defmethod adjust-table-cells ((row standard-row-output-record) stream) (declare (ignore stream)) - #+ignore + #+++ignore (let ((x-spacing (slot-value (output-record-parent row) 'x-spacing)) (x-position (coordinate 0))) (map-over-row-cells @@ -448,7 +447,7 @@ (defmethod adjust-table-cells ((column standard-column-output-record) stream) (declare (ignore stream)) - #+ignore + #+++ignore (let ((x-spacing (slot-value (output-record-parent column) 'x-spacing)) (x-position (coordinate 0))) (map-over-row-cells diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index 4b568b20..84895b88 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.4 92/04/15 11:47:28 cer Exp $ +;; $fiHeader: text-recording.lisp,v 1.5 92/05/07 13:13:08 cer Exp $ (in-package :clim-internals) @@ -74,63 +74,50 @@ (start 0) (end (length string)) (text-style (medium-default-text-style stream)) - #+Silica (port (port stream)) - (baseline (- (text-style-height text-style #-Silica stream #+Silica port) - (text-style-descent text-style #-Silica stream #+Silica port))) + (port (port stream)) + (baseline (- (text-style-height text-style port) + (text-style-descent text-style port))) (glyph-buffer (stream-output-glyph-buffer stream)) (color (slot-value record 'ink))) (declare (type fixnum start end)) - (#-Silica progn - #+Silica with-sheet-medium #+Silica (medium stream) - (macrolet - ((do-it (end-position) - `(loop - (when (>= start ,end-position) (return)) - (multiple-value-bind (write-char next-char-index - new-cursor-x new-baseline new-height font) - (stream-scan-string-for-writing stream #+Silica medium - string start ,end-position text-style - cursor-x +largest-coordinate+ - glyph-buffer) - ;; GLYPH-BUFFER NIL => pass the string to the port-specific code. - #-Silica - (if glyph-buffer - (stream-write-string-1 - stream glyph-buffer 0 (the fixnum (- next-char-index start)) - font color - cursor-x (+ cursor-y (- baseline new-baseline))) - (stream-write-string-1 - stream string start next-char-index - font color - cursor-x (+ cursor-y (- baseline new-baseline)))) - #+Silica - (with-identity-transformation (medium) - (draw-text* medium string - cursor-x (+ cursor-y (- baseline new-baseline)) - :start start :end next-char-index - :align-y :top - :text-style text-style :ink color)) - (setf cursor-x new-cursor-x start next-char-index) - (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? - (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) - (t - (multiple-value-bind (new-cursor-x new-cursor-y) - (stream-draw-lozenged-character - stream write-char cursor-x cursor-y new-baseline new-height - text-style +largest-coordinate+ nil t) - (setf cursor-x new-cursor-x - cursor-y new-cursor-y)))) - (incf start)))))) - (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position record) - (declare (type coordinate cursor-x cursor-y)) - (translate-coordinates x-offset y-offset cursor-x cursor-y) - (do-it end) - #-Silica - (when (slot-value record 'wrapped-p) - (draw-character-wrap-indicator - stream cursor-y (bounding-rectangle-height record) (stream-text-margin stream) nil))))))) + (with-sheet-medium (medium stream) + (macrolet + ((do-it (end-position) + `(loop + (when (>= start ,end-position) (return)) + (multiple-value-bind (write-char next-char-index + new-cursor-x new-baseline new-height font) + (stream-scan-string-for-writing + stream medium string start ,end-position text-style + cursor-x +largest-coordinate+ glyph-buffer) + (with-identity-transformation (medium) + (draw-text* medium string + cursor-x (+ cursor-y (- baseline new-baseline)) + :start start :end next-char-index + :align-y :top + :text-style text-style :ink color)) + (setf cursor-x new-cursor-x start next-char-index) + (when write-char + (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? + (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) + (t + (multiple-value-bind (new-cursor-x new-cursor-y) + (stream-draw-lozenged-character + stream write-char cursor-x cursor-y new-baseline new-height + text-style +largest-coordinate+ nil t) + (setf cursor-x new-cursor-x + cursor-y new-cursor-y)))) + (incf start)))))) + (multiple-value-bind (cursor-x cursor-y) + (output-record-start-cursor-position record) + (declare (type coordinate cursor-x cursor-y)) + (translate-coordinates x-offset y-offset cursor-x cursor-y) + (do-it end) + #-Silica ;--- what about this? + (when (slot-value record 'wrapped-p) + (draw-character-wrap-indicator + stream cursor-y (bounding-rectangle-height record) + (stream-text-margin stream) nil))))))) (defmethod replay-output-record ((record styled-text-output-record) stream &optional region @@ -145,63 +132,50 @@ (glyph-buffer (stream-output-glyph-buffer stream)) (color (slot-value record 'ink))) (declare (type fixnum start end)) - (#-Silica progn - #+Silica with-sheet-medium #+Silica (medium stream) - (macrolet - ((do-it (end-position) - `(loop - (when (>= start ,end-position) (return)) - (multiple-value-bind (write-char next-char-index - new-cursor-x new-baseline new-height font) - (stream-scan-string-for-writing stream #+Silica medium - string start ,end-position text-style - cursor-x +largest-coordinate+ - glyph-buffer) - #-Silica - (if glyph-buffer - (stream-write-string-1 - stream glyph-buffer 0 (the fixnum (- next-char-index start)) - font color - cursor-x (+ cursor-y (- baseline new-baseline))) - (stream-write-string-1 - stream string start next-char-index - font color - cursor-x (+ cursor-y (- baseline new-baseline)))) - #+Silica - (with-identity-transformation (medium) - (draw-text* medium string - cursor-x (+ cursor-y (- baseline new-baseline)) - :start start :end next-char-index - :align-y :top - :text-style text-style :ink color)) - (setf cursor-x new-cursor-x start next-char-index) - (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? - (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) - (t - (multiple-value-bind (new-cursor-x new-cursor-y) - (stream-draw-lozenged-character - stream write-char cursor-x cursor-y new-baseline new-height - text-style +largest-coordinate+ nil t) - (setf cursor-x new-cursor-x - cursor-y new-cursor-y)))) - (incf start)))))) - (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position record) - (declare (type coordinate cursor-x cursor-y)) - (translate-coordinates x-offset y-offset cursor-x cursor-y) - (dolist (text-style-change (slot-value record 'text-style-changes)) - (let ((new-text-style (car text-style-change)) - (change-position (cdr text-style-change))) - (do-it change-position) - (setf text-style new-text-style - start change-position))) - (do-it end) - #-Silica - (when (slot-value record 'wrapped-p) - (draw-character-wrap-indicator - stream cursor-y (bounding-rectangle-height record) - (stream-text-margin stream) nil))))))) + (with-sheet-medium (medium stream) + (macrolet + ((do-it (end-position) + `(loop + (when (>= start ,end-position) (return)) + (multiple-value-bind (write-char next-char-index + new-cursor-x new-baseline new-height font) + (stream-scan-string-for-writing + stream medium string start ,end-position text-style + cursor-x +largest-coordinate+ glyph-buffer) + (with-identity-transformation (medium) + (draw-text* medium string + cursor-x (+ cursor-y (- baseline new-baseline)) + :start start :end next-char-index + :align-y :top + :text-style text-style :ink color)) + (setf cursor-x new-cursor-x start next-char-index) + (when write-char + (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? + (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) + (t + (multiple-value-bind (new-cursor-x new-cursor-y) + (stream-draw-lozenged-character + stream write-char cursor-x cursor-y new-baseline new-height + text-style +largest-coordinate+ nil t) + (setf cursor-x new-cursor-x + cursor-y new-cursor-y)))) + (incf start)))))) + (multiple-value-bind (cursor-x cursor-y) + (output-record-start-cursor-position record) + (declare (type coordinate cursor-x cursor-y)) + (translate-coordinates x-offset y-offset cursor-x cursor-y) + (dolist (text-style-change (slot-value record 'text-style-changes)) + (let ((new-text-style (car text-style-change)) + (change-position (cdr text-style-change))) + (do-it change-position) + (setf text-style new-text-style + start change-position))) + (do-it end) + #-Silica ;--- what about this? + (when (slot-value record 'wrapped-p) + (draw-character-wrap-indicator + stream cursor-y (bounding-rectangle-height record) + (stream-text-margin stream) nil))))))) (defmethod bounding-rectangle-set-edges :around ((record standard-text-output-record) new-left new-top new-right new-bottom) @@ -426,11 +400,11 @@ (defmethod stylize-text-output-record ((record standard-text-output-record) style stream) (with-slots (ink string wrapped-p left top right bottom start-x start-y end-x end-y) record - (let* (#+Silica (port (port stream)) + (let* ((port (port stream)) (new-record (make-styled-text-output-record-1 ink string wrapped-p - style (- (text-style-height style #-Silica stream #+Silica port) - (text-style-descent style #-Silica stream #+Silica port))))) + style (- (text-style-height style port) + (text-style-descent style port))))) (with-slots ((new-left left) (new-top top) (new-right right) (new-bottom bottom) (new-sx start-x) (new-sy start-y) (new-ex end-x) (new-ey end-y) (new-wrapped-p wrapped-p)) new-record @@ -451,7 +425,7 @@ ;; the first baseline but more likely to look good with misaligned things. (let ((baseline (coordinate 0)) (style (medium-default-text-style stream)) - #+Silica (port (port stream))) + (port (port stream))) (declare (type coordinate baseline)) (labels ((find-or-recurse (record y-offset) (declare (type coordinate y-offset)) @@ -461,8 +435,8 @@ (standard-text-output-record (maxf baseline (+ y-offset - (- (text-style-height style #-Silica stream #+Silica port) - (text-style-descent style #-Silica stream #+Silica port))))) + (- (text-style-height style port) + (text-style-descent style port))))) (t (multiple-value-bind (xoff yoff) (output-record-position record) (declare (type coordinate yoff)) diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index cfa86f13..490f7fa4 100644 --- a/clim/tracking-pointer.lisp +++ b/clim/tracking-pointer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: tracking-pointer.lisp,v 1.6 92/03/10 10:12:59 cer Exp $ +;; $fiHeader: tracking-pointer.lisp,v 1.7 92/04/15 11:47:30 cer Exp $ (in-package :clim-internals) @@ -149,27 +149,17 @@ ;; doing this, so we'll do it by hand right here. (make-release-event (window pointer buttons) (multiple-value-bind (px py) (pointer-position pointer) - (multiple-value-bind (ox oy) - #+Silica (values (coordinate 0) (coordinate 0)) - #-Silica (window-offset window) - (let ((wx (- px ox)) - (wy (- py oy)) - (mask (tv:mouse-chord-shifts genera-mouse))) - #-Silica - (multiple-value-setq (wx wy) - (viewport-to-drawing-surface-coordinates current-window wx wy)) - (let ((event (make-instance 'pointer-button-release-event - :sheet window - :button buttons - :modifiers mask - :x wx :y wy))) - (when transformp - (multiple-value-bind (tx ty) - (transform-position (medium-transformation window) - wx wy) - (setq wx (floor tx) - wy (floor ty)))) - (values event wx wy))))))) + (let ((event (make-instance 'pointer-button-release-event + :sheet window + :button buttons + :modifiers (tv:mouse-chord-shifts genera-mouse) + :x px :y py))) + (when transformp + (multiple-value-bind (tx ty) + (transform-position (medium-transformation window) px py) + (setq px (coordinate tx) + py (coordinate ty)))) + (values event px py))))) #+Genera (declare (dynamic-extent #'make-release-event)) #+Genera (when (and button-release-function generate-release-events @@ -191,41 +181,29 @@ (setq last-x x last-y y last-window current-window) ;; Pointer position is in root coordinates - ;;--- What to do about window offset and drawing-to-surface-coordinates? - (multiple-value-bind (ox oy) - #+Silica (values (coordinate 0) (coordinate 0)) - #-Silica (window-offset current-window) - (declare (type coordinate ox oy)) - (let ((wx (- x ox)) - (wy (- y oy))) - (declare (type coordinate wx wy)) - #-Silica - (multiple-value-setq (wx wy) - (viewport-to-drawing-surface-coordinates current-window wx wy)) - (when (or presentation-motion-function highlight) - (let ((presentation - (frame-find-innermost-applicable-presentation - *application-frame* *input-context* - current-window wx wy))) - (when presentation - (when highlight - (unless (eq presentation highlighted-presentation) - (unhighlight) - (highlight presentation))) - (when presentation-motion-function - (funcall presentation-motion-function - presentation current-window wx wy)) - (return-from handle-simple-motion)))) - (unhighlight) - (when motion-function - (when transformp - (multiple-value-bind (tx ty) - (transform-position (medium-transformation current-window) - wx wy) - (setq wx (floor tx) - wy (floor ty)))) - (funcall motion-function - current-window wx wy)))))))) + (when (or presentation-motion-function highlight) + (let ((presentation + (frame-find-innermost-applicable-presentation + *application-frame* *input-context* + current-window x y))) + (when presentation + (when highlight + (unless (eq presentation highlighted-presentation) + (unhighlight) + (highlight presentation))) + (when presentation-motion-function + (funcall presentation-motion-function + presentation current-window x y)) + (return-from handle-simple-motion)))) + (unhighlight) + (when motion-function + (when transformp + (multiple-value-bind (tx ty) + (transform-position (medium-transformation current-window) + x y) + (setq x (coordinate tx) + y (coordinate ty)))) + (funcall motion-function current-window x y)))))) (block input-wait (loop ;; Handle any clicks or characters, otherwise wait for something @@ -280,8 +258,8 @@ (multiple-value-bind (tx ty) (transform-position (medium-transformation current-window) px py) - (setq wx (floor tx) - wy (floor ty)))) + (setq wx (coordinate tx) + wy (coordinate ty)))) (typecase gesture (pointer-button-press-event #+Genera (when generate-release-events @@ -365,8 +343,7 @@ (when rectangle (multiple-value-setq (left top right bottom) (bounding-rectangle* rectangle))) - (multiple-value-call - #'make-bounding-rectangle + (multiple-value-call #'make-bounding-rectangle (pointer-input-rectangle* :left left :top top :right right :bottom bottom :stream stream diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index 8132c7f0..215d68c0 100644 --- a/clim/view-defs.lisp +++ b/clim/view-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: view-defs.lisp,v 1.3 92/01/31 14:59:01 cer Exp $ +;; $fiHeader: view-defs.lisp,v 1.4 92/02/24 13:08:50 cer Exp $ (in-package :clim-internals) @@ -44,6 +44,6 @@ ) ;#+CLIM-1-compatibility -(defmethod port-dialog-view ((port t)) +(defmethod frame-manager-dialog-view ((framem standard-frame-manager)) +textual-dialog-view+) diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp index 301390f2..88aa22b7 100644 --- a/clim/window-stream.lisp +++ b/clim/window-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: window-stream.lisp,v 1.5 92/03/10 10:13:02 cer Exp $ +;; $fiHeader: window-stream.lisp,v 1.6 92/04/15 11:47:33 cer Exp $ (in-package :clim-internals) @@ -12,48 +12,21 @@ ((key-table :accessor console-key-table) (pointer-list :initform nil :accessor console-pointer-list))) -#-Silica (progn -;;; Table to associate host windows with their CLIM window "owners". -(defvar *host-window-to-clim-window-mapping* (make-hash-table)) -(defun associate-clim-window-with-host-window (host-window clim-window) - (setf (gethash host-window *host-window-to-clim-window-mapping*) - clim-window)) - -(defun clim-window-for-host-window (host-window &key (error-if-no-match t)) - (let ((clim-window (gethash host-window *host-window-to-clim-window-mapping*))) - (if (null clim-window) - (if error-if-no-match - (error "Could not find CLIM window associated with ~S" host-window) - nil) - clim-window))) -) ;#-Silica - -#+Silica (define-stream-protocol-class window ()) -;;; Anything to be gained by the CLX drawable/window distinction? (defclass window-stream - ;; The ordering of these two groups of classes matters if the - ;; method combinations are going to come out right. However - ;; the ordering of the classes withing the two levels should not - ;; matter as each class defines its own stand-alone protocol. (graphics-output-recording - #-Silica window-output-recording - #-Silica input-and-window-protocol-intermediary - #-Silica output-and-window-protocol-intermediary - #-Silica output-and-recording-protocol-intermediary - #-Silica window-mixin + window-output-recording ;; This part still stands, but we need better layering so that you can ;; have a window stream with no output recording mixed in. output-recording-mixin - #-Silica graphics-mixin input-protocol-mixin output-protocol-mixin - #+Silica window) - ()) + window) + ()) -#-Silica ;no such slots in Silica +#-Silica ;--- no such slots in Silica (defmethod print-object ((window window-stream) stream) (print-unreadable-object (window stream :type t :identity t) (let ((left (safe-slot-value window 'left)) @@ -65,7 +38,6 @@ (defmethod window-stream-class-name ((window-stream window-stream)) (class-name (class-of window-stream))) -#+Silica (defmethod window-modifier-state ((window window-stream)) (let ((pointer (stream-primary-pointer window))) (pointer-button-state pointer))) @@ -73,76 +45,7 @@ ;;; Creation functions -#-Silica -(defun open-root-window (window-type &rest creation-args) - (declare (dynamic-extent creation-args)) - (assert (member window-type *implementations*) (window-type) - "The implementation type supplied, ~S, is not one of~{ ~S~}" - window-type *implementations*) - (apply (window-type-creation-function window-type) creation-args)) - -#-Silica -(defun open-window-stream (&rest args - &key parent left top right bottom width height window-class - &allow-other-keys) - (declare (dynamic-extent args)) - (declare (arglist &key parent left top right bottom width height - ;; Initialization arguments to window-stream - ;; that are not supplied below - borders console default-text-margin default-text-style depth - display-device-type draw-p end-of-line-action end-of-page-action - initial-cursor-visibility input-buffer label name output-record - ;((clim-internals::primary-pointer)) ;I think we don't want to mention this - record-p save-under scroll-bars window-class - stream-background stream-foreground - text-cursor text-margin viewport vertical-spacing)) - (assert (not (null parent)) (parent) - "You must supply the ~S option to ~S" ':parent 'open-window-stream) - (assert (typep parent 'window-stream) (parent) - "The value of the ~S option to ~S must be a window-stream" - ':parent 'open-window-stream) - (let ((p-left 0) (p-top 0) (p-right nil) (p-bottom nil)) - (multiple-value-setq (p-right p-bottom) - (window-inside-size parent)) - (macrolet ((rationalize-dimensions (low high delta direction) - (flet ((parent-name (name) (fintern "~A-~A" 'p name))) - (let ((p-low (parent-name low)) - (p-high (parent-name high))) - `(progn - (assert (not (and ,low ,high ,delta - (/= ,delta (- ,high ,low)))) - (,low ,high ,delta) - ,(format - nil - "The ~A dimensions of this window are overconstrained." - direction)) - (when ,low (setf ,p-low ,low)) - (when ,high (setf ,p-high ,high)) - (when ,delta (if ,high - (setf ,p-low (- ,p-high ,delta)) - (setf ,p-high (+ ,p-low ,delta)))) - (setf ,low ,p-low ,high ,p-high ,delta (- ,p-high ,p-low))))))) - (rationalize-dimensions left right width "horizontal") - (rationalize-dimensions top bottom height "vertical"))) - (with-keywords-removed (window-args args - '(:parent :left :top :right :bottom :width :height :window-class)) - (let ((class-name (or window-class (window-stream-class-name parent)))) - (apply #'make-instance class-name - :parent parent :left left :top top :right right :bottom bottom - :pointers (and parent (stream-pointers parent)) - window-args)))) - -;;; These aren't really tested since they aren't the primary way to create sheets. -#+Silica -(defun open-root-window (port-type &rest creation-args) - (assert (member port-type *port-types* :key #'car) (port-type) - "The implementation type supplied, ~S, is not one of~{ ~S~}" - port-type *port-types*) - (let ((port-type (second (assoc port-type *port-types*)))) - (let ((port (apply #'find-port :port-type port-type creation-args))) - (values (find-graft :port port :orientation :nw) port)))) - -#+Silica +#+Silica ;--- should we do this? (defun open-window-stream (&rest args &key parent left top right bottom width height &allow-other-keys) (declare (dynamic-extent args)) @@ -161,34 +64,3 @@ :parent parent :left left :top top :right right :bottom bottom)) - - -#-Silica (progn - -;;; For hooking up with host window decorations. -(defmethod window-set-viewport-position :after ((window window-stream) new-x new-y) - (declare (ignore new-x new-y)) - (redisplay-decorations window)) - -(defmethod bounding-rectangle-set-edges :after ((window window-stream) left top right bottom) - (declare (ignore left top right bottom)) - (redisplay-decorations window)) - -(defmethod bounding-rectangle-set-position :after ((window window-stream) left top) - (declare (ignore left top)) - (redisplay-decorations window)) - -(defmethod bounding-rectangle-set-size :after ((window window-stream) width height) - (declare (ignore width height)) - (redisplay-decorations window)) - -(defmethod window-clear :after ((window window-stream)) - (redisplay-decorations window)) - -(defmethod window-refresh :after ((window window-stream)) - (redisplay-decorations window)) - -(defmethod redisplay-decorations ((window window-stream)) - ) - -) ;#-Silica diff --git a/clx/clx-frames.lisp b/clx/clx-frames.lisp index be4fc79d..d60177bb 100644 --- a/clx/clx-frames.lisp +++ b/clx/clx-frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-frames.lisp,v 1.3 92/03/04 16:20:49 cer Exp $ +;; $fiHeader: clx-frames.lisp,v 1.5 92/04/15 11:45:49 cer Exp $ (in-package :clx-clim) @@ -23,11 +23,12 @@ (make-pane 'command-menu-pane :display-function `(display-command-menu :command-table ,menu-bar) + :default-text-style clim-internals::*command-table-menu-text-style* :width :compute :height :compute)) pane)) pane))) -(defmethod port-dialog-view ((port clx-port)) +(defmethod frame-manager-dialog-view ((framem clx-frame-manager)) +textual-dialog-view+) ;;--- Should "ungray" the command button, if there is one @@ -38,3 +39,32 @@ (defmethod note-command-disabled ((framem clx-frame-manager) frame command) (declare (ignore frame command))) +(defmethod frame-manager-notify-user + ((framem clx-frame-manager) message-string + &key (style :inform) + (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Notify user") + documentation + (exit-boxes '(:exit :abort :help)) + (name title)) + ) + +(defmethod frame-manager-select-file + ((framem clx-frame-manager) &rest options + &key (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Select a file") + documentation + file-search-proc + directory-list-label + file-list-label + (exit-boxes '(:exit :abort :help)) + (name title)) + ) diff --git a/clx/clx-medium.lisp b/clx/clx-medium.lisp index 613288dc..dd2111ec 100644 --- a/clx/clx-medium.lisp +++ b/clx/clx-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-medium.lisp,v 1.4 92/03/10 10:12:06 cer Exp $ +;; $fiHeader: clx-medium.lisp,v 1.5 92/04/15 11:45:53 cer Exp $ (in-package :clx-clim) @@ -140,6 +140,60 @@ #b0000000000000010 #b0000100000000000 #b0000000000100000)))))) + +(defvar *clx-opacity-stipples* + (mapcar #'(lambda (entry) + (cons (first entry) (apply #'make-stipple-image (second entry)))) + '((+nowhere+ (1 1 (#b0))) + (0.05 (8 16 (#b1000000000000000 + #b0000001000000000 + #b0000000000001000 + #b0010000000000000 + #b0000000010000000 + #b0000000000000010 + #b0000100000000000 + #b0000000000100000))) + (0.1 (8 8 (#b10000000 + #b00010000 + #b00000010 + #b01000000 + #b00001000 + #b00000001 + #b00100000 + #b00000100))) + (0.2 (4 4 (#b1000 + #b0010 + #b0100 + #b0001))) + (0.3 (3 3 (#b100 + #b010 + #b001))) + (0.4 (2 2 (#b10 + #b01))) + (0.6 (3 3 (#b011 + #b101 + #b110))) + (0.7 (4 4 (#b0111 + #b1101 + #b1011 + #b1110))) + (0.8 (8 8 (#b01111111 + #b11101111 + #b11111101 + #b10111111 + #b11110111 + #b11111110 + #b11011111 + #b11111011))) + (0.9 (8 16 (#b0111111111111111 + #b1111110111111111 + #b1111111111110111 + #b1101111111111111 + #b1111111101111111 + #b1111111111111101 + #b1111011111111111 + #b1111111111011111))) + (+everywhere+ (1 1 (#b1)))))) ;; The xlib:image objects are created at load time to save run time & space. ;; Here a '0' means white, '1' black. @@ -154,6 +208,20 @@ (when (< luminance l) (return-from clx-decode-luminance stipple))))))) +(defun clx-decode-opacity (opacity) + (let ((opacities *clx-opacity-stipples*)) + (cond ((eq opacity +nowhere+) + (cdr (first opacities))) + ((eq opacity +everywhere+) + (cdr (first (last opacities)))) + (t + (let ((last-op (cdr (first opacities))) + (value (opacity-value opacity))) + (dolist (op (cdr opacities) last-op) + (when (< value (car op)) + (return last-op)) + (setq last-op (cdr op)))))))) + ;; This should only be called on a color screen. (defmethod clx-decode-color ((medium clx-medium) (ink color)) (with-slots (screen color-p black-pixel) medium @@ -190,6 +258,9 @@ (defmethod clx-decode-ink ((ink (eql +foreground-ink+)) medium) (slot-value medium 'foreground-gc)) +(defmethod clx-decode-ink ((ink (eql +everywhere+)) medium) + (slot-value medium 'foreground-gc)) + (defmethod clx-decode-ink ((ink (eql +background-ink+)) medium) (slot-value medium 'background-gc)) @@ -542,12 +613,15 @@ start-angle angle-size filled))))) (defmethod port-draw-string* ((port clx-port) sheet medium - string x y start end align-x align-y) + string x y start end align-x align-y + towards-x towards-y transform-glyphs) (let ((transform (sheet-device-transformation sheet)) (ink (medium-ink medium)) (text-style (medium-merged-text-style medium)) (drawable (slot-value medium 'drawable))) (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) (unless end (setq end (length string))) (let* ((font (if text-style @@ -557,20 +631,28 @@ (descent (xlib:font-descent font)) (height (+ ascent descent)) (gc (clx-decode-ink ink medium))) - (incf x (clim-internals::compute-text-x-adjustment - align-x medium string text-style start end)) - (incf y (clim-internals::compute-text-y-adjustment - align-y descent ascent height)) + (let ((x-adjust (clim-internals::compute-text-x-adjustment + align-x medium string text-style start end)) + (y-adjust (clim-internals::compute-text-y-adjustment + align-y descent ascent height))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust))) (setf (xlib:gcontext-font gc) font) (xlib:draw-glyphs drawable gc x y string :start start :end end)))) (defmethod port-draw-character* ((port clx-port) sheet medium - character x y align-x align-y) + character x y align-x align-y + towards-x towards-y transform-glyphs) (let ((transform (sheet-device-transformation sheet)) (ink (medium-ink medium)) (text-style (medium-merged-text-style medium)) (drawable (slot-value medium 'drawable))) (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) (let* ((font (if text-style (text-style-mapping port text-style) (clx-get-default-font port medium))) @@ -578,64 +660,29 @@ (descent (xlib:font-descent font)) (height (+ ascent descent)) (gc (clx-decode-ink ink medium))) - (incf x (clim-internals::compute-text-x-adjustment - align-x medium character text-style)) - (incf y (clim-internals::compute-text-y-adjustment - align-y descent ascent height)) + (let ((x-adjust (clim-internals::compute-text-x-adjustment + align-x medium character text-style)) + (y-adjust (clim-internals::compute-text-y-adjustment + align-y descent ascent height))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust))) (setf (xlib:gcontext-font gc) font) (xlib:draw-glyph drawable gc x y character)))) (defmethod port-draw-text* ((port clx-port) sheet medium string-or-char x y start end align-x align-y - ;; towards-point towards-x towards-y - ;; transform-glyphs - ) + towards-x towards-y transform-glyphs) (if (characterp string-or-char) (port-draw-character* port sheet medium - string-or-char x y align-x align-y) + string-or-char x y align-x align-y + towards-x towards-y transform-glyphs) (port-draw-string* port sheet medium - string-or-char x y start end align-x align-y))) - -;;--- Is this used any more? -(defmethod port-write-char-1 ((port clx-port) medium - index font color x y) - (let ((transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (text-style (medium-merged-text-style medium)) - (drawable (slot-value medium 'drawable)) - (gc (clx-decode-ink ink medium))) - (convert-to-device-coordinates transform x y) - (setf (xlib:gcontext-font gc) font) - ;; Move line down so that the top of the character (not the baseline) is at Y. - (xlib:draw-glyph drawable gc (round x) (+ (round y) (xlib:font-ascent font)) index))) - -;;--- Is this used any more? -(defmethod port-write-string-1 ((port clx-port) medium - glyph-buffer start end - font color x y) - (when (> end start) - (let ((transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (text-style (medium-merged-text-style medium)) - (drawable (slot-value medium 'drawable)) - (gc (clx-decode-ink ink medium)) - (size (if (find-if #'(lambda (x) (> x 255.)) glyph-buffer :start start :end end) - 16 :default))) - (setf (xlib:gcontext-font gc) font) - ;; Move line down so that the top of the characters (not the baseline) is at Y. - (xlib:draw-glyphs drawable gc (round x) (+ (round y) (xlib:font-ascent font)) - glyph-buffer - :start start :end end :translate #'noop-translate-function - :size size)))) - -;;; Too bad we have to copy the glyphs again, but that's life... -(defun noop-translate-function (src src-start src-end font dst dst-start) - (declare (values ending-index horizontal-motion width)) - (declare (ignore font)) - (replace dst src :start1 dst-start :start2 src-start :end2 src-end) - (values src-end nil nil)) - + string-or-char x y start end align-x align-y + towards-x towards-y transform-glyphs))) (defmethod port-beep ((port clx-port) sheet) (declare (ignore sheet)) diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp index 59f6be17..d5c10ecf 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.3 92/03/04 16:20:54 cer Exp $ +;; $fiHeader: clx-mirror.lisp,v 1.4 92/04/15 11:45:54 cer Exp $ (in-package :clx-clim) @@ -179,9 +179,11 @@ :y mouse-y :native-x native-x :native-y native-y + :button nil ;--- fill this in :modifiers (current-modifier-state (make-state-from-buttons mouse-buttons) (tv:sheet-mouse mouse-window)) + :pointer (port-pointer port) :sheet sheet))) t)) ((:button-press :button-release) @@ -200,6 +202,7 @@ :button button :modifiers (current-modifier-state 0 (tv:sheet-mouse window)) + :pointer (port-pointer port) :sheet sheet)) t)) ((:key-press :key-release) @@ -254,7 +257,7 @@ (setf (sheet-enabled-p sheet) nil)) t)) (:configure-notify (event-window ;x y width height - #+ignore send-event-p) + #+++ignore send-event-p) (let ((sheet (mirror->sheet port event-window))) (when sheet (xlib:with-state (event-window) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index b74d117c..9d43494e 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.6 92/04/15 11:45:56 cer Exp $ +;; $fiHeader: clx-port.lisp,v 1.7 92/05/07 13:11:49 cer Exp $ (in-package :clx-clim) @@ -18,14 +18,15 @@ (default-grab-cursor :reader default-grab-cursor) (context :reader port-context) (width-pixels) - (height-pixels) - (type :allocation :class - :initform :clx :reader port-type)) + (height-pixels)) (:default-initargs :allow-loose-text-style-size-mapping t)) (defmethod find-port-type ((type (eql ':clx))) 'clx-port) +(defmethod port-type ((port clx-port)) + ':clx) + (defvar *clx-white-color* (xlib:make-color :red 1 :blue 1 :green 1)) (defvar *clx-black-color* (xlib:make-color :red 0 :blue 0 :green 0)) (defvar *cursor-font* nil) diff --git a/demo/address-book.lisp b/demo/address-book.lisp index 5c168fcf..a28ec694 100644 --- a/demo/address-book.lisp +++ b/demo/address-book.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: address-book.lisp,v 1.5 92/04/15 11:48:09 cer Exp $ +;; $fiHeader: address-book.lisp,v 1.6 92/05/07 13:13:33 cer Exp $ (in-package :clim-demo) @@ -44,7 +44,7 @@ (add-address (make-address :name "John Irwin" :address "Franz, Inc." :number "510-548-3600")) - (add-address (make-address :name "Scott Mckay" + (add-address (make-address :name "Scott McKay" :address "Symbolics, Inc." :number "617-221-1000")) (add-address (make-address :name "Bill York" @@ -116,7 +116,7 @@ (make-pane 'application-pane :incremental-redisplay t :display-function 'display-names)))) - (:layout + (:layouts (default (vertically () (horizontally () @@ -203,8 +203,8 @@ (multiple-value-bind (left top right bottom) (size-demo-frame root 100 100 500 400) (setq book (make-application-frame 'address-book :parent root - :left left :top top - :right right :bottom bottom))) + :width (- right left) + :height (- bottom top)))) (push (cons root book) *address-books*)) (run-frame-top-level book))) diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index 5d9385b6..a5b6faa3 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.6 92/04/15 11:48:12 cer Exp $ +;; $fiHeader: cad-demo.lisp,v 1.7 92/05/07 13:13:34 cer Exp $ (in-package :clim-demo) @@ -536,7 +536,7 @@ (design-area (make-pane 'application-pane))) (:pointer-documentation t) - (:layout + (:layouts (default (scrolling () design-area))) diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp index 6eee8ab8..a2ca1f10 100644 --- a/demo/demo-driver.lisp +++ b/demo/demo-driver.lisp @@ -1,14 +1,11 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: aaai-demo-driver.lisp,v 1.4 92/03/04 16:22:56 cer Exp $ +;; $fiHeader: aaai-demo-driver.lisp,v 1.5 92/04/15 11:48:07 cer Exp $ (in-package :clim-demo) "Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved." -#-Silica -(defvar *demo-root* nil) - (defvar *demos* nil) (defmacro define-demo (name start-form) @@ -42,12 +39,6 @@ (+ desired-left desired-width) (+ desired-top desired-height))) (defun start-demo (&optional (root #-Silica *demo-root*)) - #-Silica - (unless root - (lisp:format t "~&No current value for *DEMO-ROOT*. Use what value? ") - (setq root (eval (lisp:read))) - (setq *demo-root* root)) - #+Silica (unless root (setq root (find-graft))) (labels ((demo-menu-drawer (stream type &rest args) (declare (dynamic-extent args)) @@ -74,6 +65,7 @@ (defparameter *color-stream-p* t) (defun color-stream-p (stream) #-Genera *color-stream-p* ;--- kludge - #+Genera (if (eql (silica:port-type (port stream)) ':genera) + #+Genera (if (and stream + (eql (port-type (port stream)) ':genera)) (slot-value stream 'clim-internals::color-p) *color-stream-p*)) diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp index 51adc4a2..8fa9c3b9 100644 --- a/demo/graphics-demos.lisp +++ b/demo/graphics-demos.lisp @@ -1,27 +1,12 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-demos.lisp,v 1.3 92/04/10 14:27:31 cer Exp Locker: cer $ +;; $fiHeader: graphics-demos.lisp,v 1.4 92/04/15 11:48:16 cer Exp $ (in-package :clim-demo) "Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved. Portions copyright (c) 1989, 1990 International Lisp Associates." -#-Silica -(define-application-frame graphics-demo - () - () - (:panes ((commands :command-menu) - (demo :application) - (explanation :application :scroll-bars nil))) - (:layout ((default - (:column 1 - (:row :rest - (demo :rest) - (commands :compute)) - (explanation 1/6)))))) - -#+Silica (define-application-frame graphics-demo () () @@ -30,7 +15,7 @@ (explanation (scrolling () (make-pane 'application-pane :height 100)))) - (:layout (:default + (:layouts (:default (vertically () demo explanation)))) (define-graphics-demo-command (com-Exit-Graphics-Demo :menu "Exit") diff --git a/demo/listener.lisp b/demo/listener.lisp index f3f7425e..cf3ebab4 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: listener.lisp,v 1.9 92/04/15 11:48:19 cer Exp Locker: cer $ +;; $fiHeader: listener.lisp,v 1.10 92/04/30 09:09:46 cer Exp $ (in-package :clim-demo) @@ -9,17 +9,12 @@ (define-application-frame lisp-listener () () - #-Silica - (:panes ((listener :application - :initial-cursor-visibility :off) - (documentation :pointer-documentation))) - #+Silica - (:panes (listener :application - :initial-cursor-visibility :off)) - (:layout (:default listener)) + (:pane (outlining () + (scrolling () + (make-pane 'interactor-pane)))) (:command-table (lisp-listener :inherit-from (user-command-table))) (:command-definer t) - (:menu-bar nil) + (:menu-bar nil) (:top-level (lisp-listener-top-level))) (defmethod frame-maintain-presentation-histories ((frame lisp-listener)) t) @@ -49,11 +44,11 @@ ;; Current stack frame pointer. (defvar *current-frame-pointer* nil)) -(defvar *lisp-listener-frame* nil) +(defvar *lisp-listener-frame*) (defun lisp-listener-top-level (frame) "Run a simple Lisp listener using the window provided." - #+Silica (enable-frame frame) + (enable-frame frame) (let* ((*lisp-listener-frame* frame) (window (frame-query-io frame)) (command-table (frame-command-table frame)) @@ -158,13 +153,13 @@ (defun listener-debugger-hook (condition hook) (declare (ignore hook)) - (let ((*application-frame* *lisp-listener-frame*)) - (let ((*debug-io* (frame-query-io *application-frame*)) - (*error-output* (frame-query-io *application-frame*)) - (*debugger-condition* condition) - (*debugger-restarts* (compute-restarts))) - (describe-error *error-output*) - (lisp-listener-top-level *application-frame*)))) + (let* ((*application-frame* *lisp-listener-frame*) + (*debug-io* (frame-query-io *application-frame*)) + (*error-output* (frame-query-io *application-frame*)) + (*debugger-condition* condition) + (*debugger-restarts* (compute-restarts))) + (describe-error *error-output*) + (lisp-listener-top-level *application-frame*))) (define-presentation-type restart-name ()) diff --git a/demo/navfun.lisp b/demo/navfun.lisp index c504c2bb..09143bd5 100644 --- a/demo/navfun.lisp +++ b/demo/navfun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: navfun.lisp,v 1.6 92/04/15 11:48:21 cer Exp $ +;; $fiHeader: navfun.lisp,v 1.7 92/05/07 13:13:36 cer Exp $ (in-package :clim-demo) @@ -1026,7 +1026,7 @@ (:panes (display (make-pane 'application-pane)) (interactor (make-pane 'interactor-pane))) - (:layout + (:layouts (default (vertically () (scrolling () display) diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index cf43caa2..3f141693 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.5 92/04/15 11:48:26 cer Exp $ +;; $fiHeader: puzzle.lisp,v 1.6 92/05/07 13:13:38 cer Exp $ (in-package :clim-demo) @@ -21,7 +21,7 @@ :max-height +fill+ :incremental-redisplay T :display-function 'draw-puzzle)))) - (:layout + (:layouts (:default display))) (defmethod frame-query-io ((puzzle puzzle)) diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp index 1a17ba9e..3f991d5e 100644 --- a/demo/sysdcl.lisp +++ b/demo/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.8 92/04/15 11:48:28 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.9 92/05/07 13:13:39 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -39,7 +39,7 @@ ("puzzle" :load-before-compile ("aaai-demo-driver" "packages")) ("address-book" :load-before-compile ("aaai-demo-driver" "packages")) ("thinkadot" :load-before-compile ("aaai-demo-driver" "packages")) - ("demo-prefill" :features (and (not Silica) (or Genera Cloe-Runtime)))) + ("demo-prefill" :features (or Genera Cloe-Runtime))) #+Genera (clim-defsys:import-into-sct 'clim-demo diff --git a/demo/thinkadot.lisp b/demo/thinkadot.lisp index 2d5e1b43..6985daa4 100644 --- a/demo/thinkadot.lisp +++ b/demo/thinkadot.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: thinkadot.lisp,v 1.5 92/04/10 14:27:38 cer Exp Locker: cer $ +;; $fiHeader: thinkadot.lisp,v 1.6 92/04/15 11:48:29 cer Exp $ (in-package :clim-demo) @@ -55,7 +55,7 @@ (make-pane 'application-pane :display-function 'draw-the-display :incremental-redisplay t))) - (:layout + (:layouts (:default (scrolling () display)))) (defmethod initialize-instance :after ((frame thinkadot) &key) diff --git a/genera/genera-frames.lisp b/genera/genera-frames.lisp index 9fd2d795..4bbded14 100644 --- a/genera/genera-frames.lisp +++ b/genera/genera-frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-frames.lisp,v 1.4 92/04/15 11:47:51 cer Exp $ +;; $fiHeader: genera-frames.lisp,v 1.5 92/05/07 13:13:24 cer Exp $ (in-package :genera-clim) @@ -23,11 +23,12 @@ (make-pane 'command-menu-pane :display-function `(display-command-menu :command-table ,menu-bar) + :default-text-style clim-internals::*command-table-menu-text-style* :width :compute :height :compute)) pane)) pane))) -(defmethod port-dialog-view ((port genera-port)) +(defmethod frame-manager-dialog-view ((framem genera-frame-manager)) +textual-dialog-view+) ;;--- Should "ungray" the command button, if there is one @@ -39,15 +40,110 @@ (declare (ignore frame command))) ;;--- We can do better than this at some point -(defmethod port-notify-user ((port genera-port) message-string - &key (style :inform) - (frame nil frame-p) - (associated-window - (if frame-p - (frame-top-level-sheet frame) - (find-graft :port port))) - (title "Notify user") - documentation - (exit-boxes '(:exit :abort :help)) - (name title)) +(defmethod frame-manager-notify-user + ((framem genera-frame-manager) message-string + &key (style :inform) + (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Notify user") + documentation + (exit-boxes '(:exit :abort :help)) + (name title)) (tv:notify nil message-string)) + +(defmethod frame-manager-select-file + ((framem genera-frame-manager) &rest options + &key (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Select a file") + documentation + file-search-proc + directory-list-label + file-list-label + (exit-boxes '(:exit :abort :help)) + (name title)) + ) + + +;;; Pointer documentation and progress notes for Genera + +(defmacro with-who-line-stream ((stream-var frame field) &body body) + `(let ((,stream-var + (let* ((console (tv:sheet-console (sheet-mirror (frame-top-level-sheet ,frame)))) + (who-screen (if (eq console sys:*main-console*) + tv:who-line-screen + (tv:console-who-line-screen console)))) + (and who-screen + (tv:get-who-line-field ,field))))) + ,@body)) + +(defmethod clim-internals::frame-manager-clear-progress-note + ((framem genera-frame-manager) (note clim-internals::progress-note)) + (with-who-line-stream (stream (slot-value note 'clim-internals::frame) :file-state) + (when stream + (scl:send stream :clear-window)))) + +(defmethod clim-internals::frame-manager-display-progress-note + ((framem genera-frame-manager) (note clim-internals::progress-note)) + (with-who-line-stream (stream (slot-value note 'clim-internals::frame) :file-state) + (with-slots clim-internals::(name-displayed bar-length) note + (when stream + (let* ((stream-width (scl:send stream :inside-width)) + (line-height (- (scl:send stream :inside-height) 2)) + (new-bar-length + (floor (* stream-width (slot-value note 'clim-internals::numerator)) + (slot-value note 'clim-internals::denominator)))) + (unless clim-internals::name-displayed + (scl:send stream :clear-window)) + (unless clim-internals::name-displayed + (scl:send stream :set-cursorpos 0 0) + (scl:send stream :string-out (progress-note-name note)) + (setq clim-internals::name-displayed t)) + (when (< new-bar-length clim-internals::bar-length) + (scl:send stream :draw-rectangle + clim-internals::bar-length 2 0 line-height :erase)) + (scl:send stream :draw-rectangle new-bar-length 2 0 line-height :draw) + (setq clim-internals::bar-length new-bar-length)))))) + + +(defvar *pointer-documentation-buffer* + (make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t)) + +(defmethod clim-internals::frame-manager-display-pointer-documentation + ((framem genera-frame-manager) + frame presentation input-context window x y stream) + (declare (ignore stream)) + (let ((stream + (let ((console (tv:sheet-console (sheet-mirror (frame-top-level-sheet frame))))) + (if (eq console sys:*main-console*) + tv:who-line-documentation-window + (let ((who-screen (tv:console-who-line-screen console))) + (and who-screen + (tv:get-who-line-field :mouse-documentation who-screen))))))) + ;; The documentation should never say anything if we're not over a presentation + (when (null presentation) + (scl:send stream :clear-window)) + ;; Cheap test to not do this work too often + (let ((old-modifier-state clim-internals::*last-pointer-documentation-modifier-state*) + (modifier-state (clim-internals::window-modifier-state window)) + (last-time clim-internals::*last-pointer-documentation-time*) + (time (get-internal-real-time))) + (setq clim-internals::*last-pointer-documentation-modifier-state* modifier-state) + (when (and (< time (+ last-time clim-internals::*pointer-documentation-interval*)) + (= modifier-state old-modifier-state)) + (return-from clim-internals::frame-manager-display-pointer-documentation nil)) + (setq clim-internals::*last-pointer-documentation-time* time)) + (when presentation + (setf (fill-pointer *pointer-documentation-buffer*) 0) + (with-output-to-string (stream *pointer-documentation-buffer*) + (when (null (clim-internals::frame-document-highlighted-presentation-1 + frame presentation input-context window x y stream)) + (setq clim-internals::*last-pointer-documentation-time* 0))) + (scl:send stream :clear-window) + (scl:send stream :string-out *pointer-documentation-buffer*)))) diff --git a/genera/genera-medium.lisp b/genera/genera-medium.lisp index 2dda47a6..8f976745 100644 --- a/genera/genera-medium.lisp +++ b/genera/genera-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-medium.lisp,v 1.3 92/04/15 11:47:57 cer Exp $ +;; $fiHeader: genera-medium.lisp,v 1.4 92/05/07 13:13:26 cer Exp $ (in-package :genera-clim) @@ -86,6 +86,7 @@ (defun-inline follow-indirect-ink (ink medium) (cond ((eq ink +foreground-ink+) (medium-foreground medium)) ((eq ink +background-ink+) (medium-background medium)) + ((eq ink +everywhere+) (medium-foreground medium)) (t ink))) (defmethod genera-decode-color (ink medium &optional (stipple-p t)) @@ -139,6 +140,74 @@ 0000000000100000))) (otherwise boole-clr))))) +(defvar *genera-opacity-stipples* + (mapcar #'(lambda (entry) + (cons (first entry) (apply #'graphics::make-stipple (second entry)))) + '((+nowhere+ (1 1 (#b0))) + (0.05 (8 16 (#b1000000000000000 + #b0000001000000000 + #b0000000000001000 + #b0010000000000000 + #b0000000010000000 + #b0000000000000010 + #b0000100000000000 + #b0000000000100000))) + (0.1 (8 8 (#b10000000 + #b00010000 + #b00000010 + #b01000000 + #b00001000 + #b00000001 + #b00100000 + #b00000100))) + (0.2 (4 4 (#b1000 + #b0010 + #b0100 + #b0001))) + (0.3 (3 3 (#b100 + #b010 + #b001))) + (0.4 (2 2 (#b10 + #b01))) + (0.6 (3 3 (#b011 + #b101 + #b110))) + (0.7 (4 4 (#b0111 + #b1101 + #b1011 + #b1110))) + (0.8 (8 8 (#b01111111 + #b11101111 + #b11111101 + #b10111111 + #b11110111 + #b11111110 + #b11011111 + #b11111011))) + (0.9 (8 16 (#b0111111111111111 + #b1111110111111111 + #b1111111111110111 + #b1101111111111111 + #b1111111101111111 + #b1111111111111101 + #b1111011111111111 + #b1111111111011111))) + (+everywhere+ (1 1 (#b1)))))) + +(defun genera-decode-opacity (opacity) + (let ((opacities *genera-opacity-stipples*)) + (cond ((eq opacity +nowhere+) + (cdr (first opacities))) + ((eq opacity +everywhere+) + (cdr (first (last opacities)))) + (t + (let ((last-op (cdr (first opacities))) + (value (opacity-value opacity))) + (dolist (op (cdr opacities) last-op) + (when (< value (car op)) + (return last-op)) + (setq last-op (cdr op)))))))) + (defmethod genera-decode-color ((ink gray-color) medium &optional (stipple-p t)) (let ((window (slot-value medium 'window)) (color-p (slot-value (port medium) 'color-p))) @@ -627,12 +696,15 @@ :filled filled))))))))) (defmethod port-draw-string* ((port genera-port) sheet medium - string x y start end align-x align-y) + string x y start end align-x align-y + towards-x towards-y transform-glyphs) (when (medium-drawing-possible medium) (let ((transform (sheet-device-transformation sheet)) (ink (medium-ink medium)) (text-style (medium-merged-text-style medium))) (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) (unless start (setq start 0)) (unless end @@ -646,10 +718,15 @@ (height (sys:font-char-height font)) (descent (- height (sys:font-baseline font))) (ascent (- height descent))) - (incf x (clim-internals::compute-text-x-adjustment - align-x sheet string text-style start end)) - (incf y (clim-internals::compute-text-y-adjustment - align-y descent ascent height)) + (let ((x-adjust (clim-internals::compute-text-x-adjustment + align-x medium string text-style start end)) + (y-adjust (clim-internals::compute-text-y-adjustment + align-y descent ascent height))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust))) (with-stack-list (style :device-font (tv:font-name font) :normal) (with-appropriate-drawing-state medium ink nil #'(lambda (window alu) @@ -661,22 +738,31 @@ substring x y :character-style style))))))))) (defmethod port-draw-character* ((port genera-port) sheet medium - character x y align-x align-y) + character x y align-x align-y + towards-x towards-y transform-glyphs) (when (medium-drawing-possible medium) (let ((transform (sheet-device-transformation sheet)) (ink (medium-ink medium)) (text-style (medium-merged-text-style medium))) (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) (let* ((font (text-style-mapping port text-style *standard-character-set* (slot-value medium 'window))) (height (sys:font-char-height font)) (descent (- height (sys:font-baseline font))) (ascent (- height descent))) - (incf x (clim-internals::compute-text-x-adjustment - align-x sheet character text-style)) - (incf y (- (clim-internals::compute-text-y-adjustment - align-y descent ascent height) ascent)) + (let ((x-adjust (clim-internals::compute-text-x-adjustment + align-x medium character text-style)) + (y-adjust (- (clim-internals::compute-text-y-adjustment + align-y descent ascent height) + ascent))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust))) (with-appropriate-drawing-state medium ink nil #'(lambda (window alu) (declare (sys:downward-function)) @@ -689,63 +775,14 @@ (defmethod port-draw-text* ((port genera-port) sheet medium string-or-char x y start end align-x align-y - ;; towards-point towards-x towards-y - ;; transform-glyphs - ) + towards-x towards-y transform-glyphs) (if (characterp string-or-char) (port-draw-character* port sheet medium - string-or-char x y align-x align-y) + string-or-char x y align-x align-y + towards-x towards-y transform-glyphs) (port-draw-string* port sheet medium - string-or-char x y start end align-x align-y))) - -;;--- Is this used any more? -(defmethod port-write-char-1 ((port genera-port) medium - index font color x y) - ;;--- Convert X and Y to device coords - (let ((window (slot-value medium 'window))) - (when (medium-drawing-possible medium) - (tv:prepare-sheet (window) - (let ((x (+ x (tv:sheet-left-margin-size window))) - (y (+ y (tv:sheet-top-margin-size window)))) - ;; There is apparently no way to draw a glyph exactly where you want - ;; it on a sheet! Draw it on the screen instead... - (tv:sheet-draw-glyph index font x y - (if (eq color (medium-foreground medium)) - (tv:sheet-char-aluf window) - (genera-decode-color (follow-indirect-ink color medium) - medium nil)) - window)))))) - -;;--- Is this used any more? -(defmethod port-write-string-1 ((port genera-port) medium - glyph-buffer start end - font color x y) - ;;--- Convert X and Y to device coords - (unless (<= end start) - (let ((window (slot-value medium 'window))) - (when (medium-drawing-possible medium) - (tv:prepare-sheet (window) - (let ((glyph-buffer glyph-buffer) - (index start) - (index8 0) - (x (+ x (tv:sheet-left-margin-size window))) - (y (+ y (tv:sheet-top-margin-size window)))) - (declare (sys:array-register glyph-buffer)) - (sys:with-stack-array (glyphs8 (- end start) :element-type 'string-char) - (declare (sys:array-register glyphs8)) - (loop - (when (= index end) (return)) - (setf (aref glyphs8 index8) (code-char (aref glyph-buffer index))) - (incf index) - (incf index8)) - (tv:sheet-draw-string window - (if (eq color (medium-foreground medium)) - (tv:sheet-char-aluf window) - (genera-decode-color (follow-indirect-ink color medium) - medium nil)) - x y glyphs8 font 0 index8 - (tv:sheet-width window))))))))) - + string-or-char x y start end align-x align-y + towards-x towards-y transform-glyphs))) (defmethod port-beep ((port genera-port) sheet) (scl:beep sheet)) diff --git a/genera/genera-mirror.lisp b/genera/genera-mirror.lisp index 568ec21b..182b8dfb 100644 --- a/genera/genera-mirror.lisp +++ b/genera/genera-mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-mirror.lisp,v 1.3 92/04/15 11:48:00 cer Exp $ +;; $fiHeader: genera-mirror.lisp,v 1.4 92/05/07 13:13:28 cer Exp $ (in-package :genera-clim) @@ -559,9 +559,13 @@ :y mouse-y :native-x native-x :native-y native-y + :button (and (not (zerop mouse-buttons)) + (genera-button-number->standard-button-name + (ash mouse-buttons -1))) :modifiers (current-modifier-state (make-state-from-buttons mouse-buttons) (tv:sheet-mouse mouse-window)) + :pointer (port-pointer port) :sheet sheet))))) (when mouse-button-released (let ((sheet (and mouse-window (genera-window-sheet mouse-window)))) @@ -579,6 +583,7 @@ :modifiers (current-modifier-state (make-state-from-buttons mouse-buttons) (tv:sheet-mouse mouse-window)) + :pointer (port-pointer port) :sheet sheet))))))))) ;; Handle shift press and release events ((or shifts-up shifts-down) @@ -666,6 +671,7 @@ :button button :modifiers (current-modifier-state 0 (tv:sheet-mouse window)) + :pointer (port-pointer port) :sheet sheet)))))))))))))) ;; See general comments about sheet-native-native-region* and diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp index ad7a4253..2af24328 100644 --- a/genera/genera-port.lisp +++ b/genera/genera-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-port.lisp,v 1.4 92/04/15 11:48:02 cer Exp $ +;; $fiHeader: genera-port.lisp,v 1.5 92/05/07 13:13:29 cer Exp $ (in-package :genera-clim) @@ -10,9 +10,6 @@ (defvar *genera-default-server-path* `(:genera :host ,net:*local-host* :screen ,tv:main-screen)) -(warn "Changing the default server path to ~S" - (setq *default-server-path* *genera-default-server-path*)) - (defclass genera-port (port) ((screen :initform nil :reader port-display) @@ -22,14 +19,15 @@ (cursor-font) (cursor-cache :initform nil :type nil) (height-pixels) - (width-pixels) - (type :allocation :class - :initform :genera :reader port-type)) + (width-pixels)) (:default-initargs :allow-loose-text-style-size-mapping nil)) (defmethod find-port-type ((type (eql ':genera))) 'genera-port) +(defmethod port-type ((port genera-port)) + ':genera) + (defparameter *genera-use-color* t) ;for debugging monochrome... (defmethod initialize-instance :after ((port genera-port) @@ -293,7 +291,7 @@ (with-genera-glyph-for-character (port-glyph-for-character stream character style our-font))) -(defmethod stream-scan-string-for-writing ((port genera-port) #+Silica medium +(defmethod stream-scan-string-for-writing ((port genera-port) medium string start end style cursor-x max-x &optional glyph-buffer) (with-genera-glyph-for-character diff --git a/instclimol.lisp b/instclimol.lisp index 2825f2c8..8435d8f5 100644 --- a/instclimol.lisp +++ b/instclimol.lisp @@ -20,7 +20,7 @@ ;; applicable. ;; -;; $fiHeader: instclim-2.0.lisp,v 1.1 92/03/30 22:10:04 cer Exp $ +;; $fiHeader: instclimol.lisp,v 1.1 92/05/20 17:20:42 cer Exp Locker: cer $ ;; ;; Load CLIM @@ -28,6 +28,11 @@ (in-package :system) + +(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") +(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") +(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") + (load-application (progn (require :climol) (load-patches diff --git a/instclimxm.lisp b/instclimxm.lisp index 937fd286..fea55f0a 100644 --- a/instclimxm.lisp +++ b/instclimxm.lisp @@ -20,7 +20,7 @@ ;; applicable. ;; -;; $fiHeader: instclim.cl,v 1.4 92/03/10 17:24:59 cer Exp $ +;; $fiHeader: instclimxm.lisp,v 1.1 92/03/30 22:10:04 cer Exp Locker: cer $ ;; ;; Load CLIM @@ -28,6 +28,10 @@ (in-package :system) +(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") +(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") +(defvar sys::*libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") + (load-application (progn (require :climxm) (load-patches diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index da85ad8d..7e74c00b 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,15 +20,19 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.5 92/05/07 13:13:46 cer Exp Locker: cer $ +;; $fiHeader: compile-1.lisp,v 1.6 92/05/13 17:11:07 cer Exp Locker: cer $ (in-package :user) -(setq *ignore-package-name-case* t) +;;This should not matter +;;;; (setq *ignore-package-name-case* t) + (set-case-mode :case-insensitive-lower) (setf (sys:gsgc-switch :print) t) (setf (sys:gsgc-switch :stats) t) +(setq *compile-print* nil) + (setq comp:generate-call-count-code-switch (named-function |(> debug 1)| (lambda (safety size speed debug) @@ -40,8 +44,6 @@ (declare (ignore safety size debug)) (> speed 2)))) -(setq *compile-print* nil) - (unless (find-package 'clim-defsystem) (compile-file-if-needed "sys/defsystem") (let ((*enable-package-locked-errors* nil)) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 2b24b04b..c9bef9da 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,11 +20,13 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.5 92/05/07 13:13:47 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.6 92/05/13 17:11:09 cer Exp Locker: cer $ (excl::free (excl::malloc 262145)) -(setq *ignore-package-name-case* t) +;;;; This should not matter +;;;; (setq *ignore-package-name-case* t) + (set-case-mode :case-insensitive-lower) (tenuring @@ -40,7 +42,6 @@ (let ((*load-source-file-info* t) (*load-xref-info* nil) (excl:*global-gc-behavior* nil)) - #-ignore (ecase sys (motif-clim (load "climg.fasl") @@ -69,7 +70,8 @@ (load "demo/sysdcl") (tenuring - (clim-defsys::load-system 'clim-demo))) + #-ignore + (clim-defsys::load-system 'clim-demo))) (when (probe-file "/scm/4.1/sparc/src/code/") (let ((sys::*require-search-list* diff --git a/silica/classes.lisp b/silica/classes.lisp index 28522f1e..0aa1941f 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: classes.lisp,v 1.7 92/03/10 10:11:33 cer Exp $ +;; $fiHeader: classes.lisp,v 1.8 92/05/07 13:11:07 cer Exp Locker: cer $ (in-package :silica) @@ -54,7 +54,8 @@ ;; Thus each bucket is a list of fonts with the same family and face, ;; but different sizes. They are kept sorted small to large. (allow-loose-text-style-size-mapping - :initform nil :initarg :allow-loose-text-style-size-mapping))) + :initform nil :initarg :allow-loose-text-style-size-mapping) + (framems :initform nil :accessor port-frame-manager))) ;;--- Make a SHEET protocol class, and call this BASIC-SHEET (defclass sheet () diff --git a/silica/db-box.lisp b/silica/db-box.lisp index 04fe13f5..cc120a83 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-box.lisp,v 1.13 92/04/30 09:09:11 cer Exp Locker: cer $ +;; $fiHeader: db-box.lisp,v 1.14 92/05/06 15:37:14 cer Exp $ (in-package :silica) @@ -45,10 +45,11 @@ ((member :fill)) (pane (sheet-adopt-child pane child)) (cons - (unless (and (typep (first child) '(or (member :fill) (real 0 1))) - (panep (second child))) - (error "Invalid box child: ~S" contents)) - (sheet-adopt-child pane (second child))))) + ;; Handle top-down layout syntax + (unless (and (typep (first child) '(or (member :fill) (real 0 1))) + (panep (second child))) + (error "Invalid box child: ~S" contents)) + (sheet-adopt-child pane (second child))))) (with-slots ((c contents)) pane (setf c contents))) @@ -74,26 +75,23 @@ (if (consp entry) (psetf entry (second entry) scale (let ((n (first entry))) - (if (numberp n) - (float n) n))) - (setf scale 1.0)) + (if (numberp n) (float n) n))) + (setf scale 1.0)) (let ((space-req (apply #'compose-space entry width-or-height))) - (flet ((scale (x) (if (and (numberp scale) (< x +fill+)) (/ x scale) x))) - (if (eq scale :fill) - (incf major+ +fill+) - (progn - (incf major (+ (scale (funcall fn-major space-req)) space)) - (incf major+ (if (eq scale :fill) - +fill+ - (scale (funcall fn-major+ space-req)))))) + (flet ((scale (x) + (if (and (numberp scale) (< x +fill+)) (/ x scale) x))) + (declare (dynamic-extent #'scale)) + (cond ((eq scale :fill) + (incf major+ +fill+)) + (t + (incf major (+ (scale (funcall fn-major space-req)) space)) + (incf major+ (scale (funcall fn-major+ space-req))))) (incf major- (scale (funcall fn-major- space-req))) (setq minor (max minor (funcall fn-minor space-req))) - (setq minor-min - (max minor-min (funcall fn-minor- space-req))) - (setq minor-max - (min minor-max (funcall fn-minor+ space-req)))))))) + (maxf minor-min (funcall fn-minor- space-req)) + (minf minor-max (funcall fn-minor+ space-req))))))) (decf major space) - ;; ?? These calcs lead to weirdness when fills are involved. + ;;--- These calcs lead to weirdness when fills are involved. ;;--- This looks like a leftover from the time when +/- were relative ;;(setq minor- (max 0 (- minor minor-min))) ;;(setq minor+ (max 0 (- minor-max minor))) @@ -104,6 +102,7 @@ keys (list major major+ major- minor minor+ minor-))))))) + (defclass hbox-pane (box-pane) ()) (defmethod compose-space ((box-pane hbox-pane) &key width height) @@ -126,26 +125,27 @@ (cond ((atom x) (compose-space x :height height)) ((eq (car x) :fill) :fill) (t (make-space-requirement :height 0 :width (* (car x) width)))))) - (let ((sizes - (allocate-space-to-items - width - space-requirement - contents - #'space-requirement-min-width - #'space-requirement-width - #'space-requirement-max-width - #'compose)) - (x 0)) - (mapc #'(lambda (sheet size) - (when (or (panep sheet) - (and (consp sheet) - (panep (second sheet)) - (setq sheet (second sheet)))) - (move-and-resize-sheet* sheet - x 0 - (frob-size size width x) height)) - (incf x size)) - contents sizes))))) + (declare (dynamic-extent #'compose)) + (let ((sizes + (allocate-space-to-items + width + space-requirement + contents + #'space-requirement-min-width + #'space-requirement-width + #'space-requirement-max-width + #'compose)) + (x 0)) + (mapc #'(lambda (sheet size) + (when (or (panep sheet) + (and (consp sheet) + (panep (second sheet)) + (setq sheet (second sheet)))) + (move-and-resize-sheet* sheet + x 0 + (frob-size size width x) height)) + (incf x size)) + contents sizes))))) (defclass vbox-pane (box-pane) ()) @@ -168,19 +168,18 @@ (compose-space box-pane :width width :height height)) (flet ((compose (x) (cond ((atom x) (compose-space x :width width)) - ((eq (car x) :fill) - :fill) - (t - (make-space-requirement :width 0 :height (* (car x) height)))))) + ((eq (car x) :fill) :fill) + (t (make-space-requirement :width 0 :height (* (car x) height)))))) + (declare (dynamic-extent #'compose)) (let ((sizes - (allocate-space-to-items - height - space-requirement - contents - #'space-requirement-min-height - #'space-requirement-height - #'space-requirement-max-height - #'compose)) + (allocate-space-to-items + height + space-requirement + contents + #'space-requirement-min-height + #'space-requirement-height + #'space-requirement-max-height + #'compose)) (y 0)) (mapc #'(lambda (sheet size) (when (or (panep sheet) @@ -189,7 +188,7 @@ (setq sheet (second sheet)))) (move-and-resize-sheet* sheet 0 y - width (frob-size size height y))) + width (frob-size size height y))) (incf y size)) contents sizes))))) diff --git a/silica/db-button.lisp b/silica/db-button.lisp index 6e202471..7f5bbf46 100644 --- a/silica/db-button.lisp +++ b/silica/db-button.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-button.lisp,v 1.6 92/04/15 11:45:01 cer Exp $ +;; $fiHeader: db-button.lisp,v 1.7 92/05/07 13:11:10 cer Exp $ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." @@ -11,6 +11,10 @@ (defclass button-pane-mixin (space-requirement-mixin leaf-pane) + ;; ARMED has three states: + ;; NIL ==> the button is not armed + ;; T ==> the button is armed, waiting for a pointer button press + ;; :ACTIVE ==> the button is armed, waiting for a pointer button release ((armed :initform nil))) ;; General highlight-by-inverting method @@ -19,7 +23,42 @@ (draw-rectangle* medium left top right bottom :ink +flipping-ink+ :filled t))) +(defmethod handle-event ((pane button-pane-mixin) (event pointer-enter-event)) + (with-slots (armed) pane + (unless armed + (cond ((and (pointer-event-button event) + (not (zerop (pointer-event-button event)))) + (setf armed :active) + (with-sheet-medium (medium pane) + (highlight-button pane medium))) + (t (setf armed t))) + (armed-callback pane (gadget-client pane) (gadget-id pane))))) + +(defmethod handle-event ((pane button-pane-mixin) (event pointer-exit-event)) + (with-slots (armed) pane + (when armed + (when (eq armed :active) + (with-sheet-medium (medium pane) + (highlight-button pane medium))) + (setf armed nil) + (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) + +(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-press-event)) + (with-slots (armed) pane + (when armed + (setf armed :active) + (with-sheet-medium (medium pane) + (highlight-button pane medium))))) + +(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-release-event)) + (with-slots (armed) pane + (when (eq armed :active) + (setf armed t) + (with-sheet-medium (medium pane) + (highlight-button pane medium)) + (activate-callback pane (gadget-client pane) (gadget-id pane))))) + ;;; Push buttons (defclass push-button-pane (push-button button-pane-mixin) ((show-as-default :initarg :show-as-default @@ -33,7 +72,7 @@ (compute-gadget-label-size pane) (make-space-requirement :width width :height height))) -;; Draw the text, invert the whole button when armed. +;; Draw the text, invert the whole button when actively armed (defmethod repaint-sheet ((pane push-button-pane) region) (declare (ignore region)) (with-sheet-medium (medium pane) @@ -48,40 +87,7 @@ :text-style text-style ;;--- :align-x ':center :align-y ':center :align-x ':left :align-y ':center) - (when armed - (highlight-button pane medium))))) - -(defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event)) - (with-slots (armed) pane - (unless armed - (setf armed t) - (armed-callback pane (gadget-client pane) (gadget-id pane)) - (with-sheet-medium (medium pane) - (highlight-button pane medium))))) - -(defmethod handle-event ((pane push-button-pane) (event pointer-button-release-event)) - (with-slots (armed) pane - (when armed - (activate-callback pane (gadget-client pane) (gadget-id pane)) - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane)) - (with-sheet-medium (medium pane) - (highlight-button pane medium))))) - -(defmethod handle-event ((pane push-button-pane) (event pointer-enter-event)) - (with-slots (armed) pane - (unless armed - (setf armed t) - (armed-callback pane (gadget-client pane) (gadget-id pane)) - (with-sheet-medium (medium pane) - (highlight-button pane medium))))) - -(defmethod handle-event ((pane push-button-pane) (event pointer-exit-event)) - (with-slots (armed) pane - (when armed - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane)) - (with-sheet-medium (medium pane) + (when (eq armed :active) (highlight-button pane medium))))) @@ -99,7 +105,6 @@ (make-space-requirement :width (+ width (* radius 2) 5) :height (max height (* radius 2)))))) -;; Draw the text, invert the whole button when armed. (defmethod repaint-sheet ((pane toggle-button-pane) region) (declare (ignore region)) (with-sheet-medium (medium pane) @@ -133,30 +138,17 @@ (draw-circle* medium cx cy (round radius 2) :ink (if (gadget-value pane) +foreground-ink+ +background-ink+))))))) -(defmethod handle-event ((pane toggle-button-pane) (event pointer-button-press-event)) - (with-slots (armed) pane - (unless armed - (setf armed t) - (armed-callback pane (gadget-client pane) (gadget-id pane))))) +;; Highlighting is a no-op +(defmethod highlight-button ((pane toggle-button-pane) medium) + (declare (ignore medium))) (defmethod handle-event ((pane toggle-button-pane) (event pointer-button-release-event)) (with-slots (armed) pane - (when armed - (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))) - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) - -(defmethod handle-event ((pane toggle-button-pane) (event pointer-enter-event)) - (with-slots (armed) pane - (unless armed + (when (eq armed :active) (setf armed t) - (armed-callback pane (gadget-client pane) (gadget-id pane))))) - -(defmethod handle-event ((pane toggle-button-pane) (event pointer-exit-event)) - (with-slots (armed) pane - (when armed - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) + (with-sheet-medium (medium pane) + (highlight-button pane medium)) + (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))))) ;;; Menu buttons diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index d0ff1c62..a6452ee7 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-layout.lisp,v 1.16 92/05/07 13:11:11 cer Exp Locker: cer $ +;; $fiHeader: db-layout.lisp,v 1.17 92/05/12 18:24:24 cer Exp Locker: cer $ (in-package :silica) @@ -69,6 +69,21 @@ (defmethod change-space-requirements ((pane layout-mixin) &key &allow-other-keys) nil) +(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it) + (note-layout-mixin-region-changed pane :port port-did-it)) + +(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) + (declare (ignore port)) + (multiple-value-bind (width height) (bounding-rectangle-size pane) + (allocate-space pane width height))) + + +(defmacro changing-space-requirements ((&rest options &key resize-frame layout) &body body) + (declare (ignore resize-frame)) + `(flet ((changing-space-requirements-body () ,@body)) + (declare (dynamic-extent #'changing-space-requirements-body)) + (invoke-with-changing-space-requirements + #'changing-space-requirements-body ,@options))) (defmethod change-space-requirements-to ((pane layout-mixin) space-requirement) (multiple-value-bind @@ -79,30 +94,22 @@ pane :width width :min-width min-width :max-width max-width :height height :min-height min-height :max-height max-height))) -(defmacro changing-space-requirements ((&rest options &key resize-frame layout) &body body) - `(flet ((changing-space-requirements-body () - ,@body)) - (declare (dynamic-extent #'changing-space-requirements-body)) - (invoke-with-changing-space-requirements - #'changing-space-requirements-body - ,@options))) - (defvar *inside-changing-space-requirements* nil) (defun invoke-with-changing-space-requirements (continuation &key resize-frame (layout t)) (let ((old-inside-changing-space-requirements - *inside-changing-space-requirements*) + *inside-changing-space-requirements*) (*inside-changing-space-requirements* - (cons nil *inside-changing-space-requirements*))) + (cons nil *inside-changing-space-requirements*))) (multiple-value-prog1 - (funcall continuation) + (funcall continuation) (unless (or (not layout) old-inside-changing-space-requirements) - ;; Layout that frames that need to be laid out - ;; and relayout the minimal subtrees that need to be laid out + ;; Layout that frames that need to be laid out and + ;; re-layout the minimal subtrees that need to be laid out (let* ((frames (remove-duplicates - (remove-if-not - #'(lambda (x) (typep x 'application-frame)) - *inside-changing-space-requirements*))) + (remove-if-not + #'(lambda (x) (application-frame-p x)) + *inside-changing-space-requirements*))) (panes (remove-if #'(lambda (x) (or (not (panep x)) (member (pane-frame x) frames))) @@ -117,30 +124,23 @@ ;; the tree (clear-space-requirement-caches-in-tree pane) (multiple-value-call #'allocate-space - pane (bounding-rectangle-size pane))))))))) + pane (bounding-rectangle-size pane))))))))) (defmethod note-space-requirement-changed (parent child) (multiple-value-call #'allocate-space parent (bounding-rectangle-size parent))) -(defmethod change-space-requirements :around ((pane layout-mixin) &key - resize-frame - &allow-other-keys) +(defmethod change-space-requirements :around ((pane layout-mixin) + &key resize-frame + &allow-other-keys) (call-next-method) (if *inside-changing-space-requirements* (push (if resize-frame (pane-frame pane) (sheet-parent pane)) (cdr *inside-changing-space-requirements*)) - (if resize-frame - (layout-frame (pane-frame pane)) - (note-space-requirement-changed (sheet-parent pane) pane)))) + (if resize-frame + (layout-frame (pane-frame pane)) + (note-space-requirement-changed (sheet-parent pane) pane)))) -(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it) - (note-layout-mixin-region-changed pane :port port-did-it)) - -(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) - (declare (ignore port)) - (multiple-value-bind (width height) (bounding-rectangle-size pane) - (allocate-space pane width height))) (defun map-space-requirement (fn req) (setf (space-requirement-width req) (funcall fn (space-requirement-width req)) @@ -412,6 +412,9 @@ (with-slots (space-requirement) pane (setf space-requirement nil))) +(defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key) + (clear-space-requirement-cache pane)) + (defmethod note-space-requirements-changed :before (composite (pane space-requirement-cache-mixin)) (declare (ignore composite)) @@ -422,9 +425,6 @@ (clear-space-requirement-cache sheet)) sheet)) -(defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key) - (clear-space-requirement-cache pane)) - (defun clear-space-requirement-caching-in-ancestors (menu) (do ((parent (sheet-parent menu) (sheet-parent parent))) ((null parent)) @@ -501,24 +501,24 @@ ;;; Generally useful layout function ;;; Used all over to satisfy constraints + ;;--- I think that since coordinates are ultimately integers we loose ;;---- along the way, calling fix-coor on alloc helps a little but we ;;---- still end up with a gap along the bottom-right edges. - -#+ignore +#+++ignore (defun allocate-space-to-items (given wanted items min-size desired-size max-size item-size) - (flet ((desired-size (x) (funcall desired-size x)) - (min-size (x) (funcall min-size x)) - (max-size (x) (funcall max-size x)) - (item-size (x) (funcall item-size x))) + (macrolet ((desired-size (x) `(funcall desired-size ,x)) + (min-size (x) `(funcall min-size ,x)) + (max-size (x) `(funcall max-size ,x)) + (item-size (x) `(funcall item-size ,x))) (let ((stretch-p (>= given (desired-size wanted))) extra give used sizes) (if stretch-p (setq give (- (max-size wanted) (desired-size wanted)) extra (min (- given (desired-size wanted)) give)) - (setq give (- (desired-size wanted) (min-size wanted)) - extra (min (- (desired-size wanted) given) give))) + (setq give (- (desired-size wanted) (min-size wanted)) + extra (min (- (desired-size wanted) given) give))) (dolist (item items) (let (alloc) (typecase item @@ -529,93 +529,93 @@ (setq alloc (ceiling alloc)) (fix-coordinates alloc) (decf give +fill+)) - (setq alloc 0))) + (setq alloc 0))) (t - (let* ((item-size (item-size item))) - (if (eq item-size :fill) - (if stretch-p - (progn - (setq alloc (/ (* +fill+ extra) give)) - (setq alloc (ceiling alloc)) - (fix-coordinates alloc) - (decf give +fill+)) - (setq alloc 0)) - (progn - (setq alloc (desired-size item-size)) - (when (> give 0) - (if stretch-p - (progn - (setq used (/ (* (- (max-size item-size) - (desired-size item-size)) - extra) - give)) - (incf alloc used) - (fix-coordinates alloc) - (decf give (- (max-size item-size) - (desired-size item-size)))) - (progn - (setq used (/ (* (- (desired-size item-size) - (min-size item-size)) - extra) - give)) - (decf alloc used) - (fix-coordinates alloc) - (decf give (- (desired-size item-size) - (min-size item-size))))) - (decf extra used))))))) + (let* ((item-size (item-size item))) + (if (eq item-size :fill) + (if stretch-p + (progn + (setq alloc (/ (* +fill+ extra) give)) + (setq alloc (ceiling alloc)) + (fix-coordinates alloc) + (decf give +fill+)) + (setq alloc 0)) + (progn + (setq alloc (desired-size item-size)) + (when (> give 0) + (if stretch-p + (progn + (setq used (/ (* (- (max-size item-size) + (desired-size item-size)) + extra) + give)) + (incf alloc used) + (fix-coordinates alloc) + (decf give (- (max-size item-size) + (desired-size item-size)))) + (progn + (setq used (/ (* (- (desired-size item-size) + (min-size item-size)) + extra) + give)) + (decf alloc used) + (fix-coordinates alloc) + (decf give (- (desired-size item-size) + (min-size item-size))))) + (decf extra used))))))) (push alloc sizes))) (nreverse sizes)))) - -;;-- This new supa dupa version saves up all the fills to the end and -;;-- then divides up any leftover space equally amongst them and it -;;-- seems to work! - + +;; This new supa dupa version saves up all the fills to the end and +;; then divides up any leftover space equally amongst them and it +;; seems to work! +#---ignore (defun allocate-space-to-items (given wanted items min-size desired-size max-size item-size) - (flet ((desired-size (x) (funcall desired-size x)) - (min-size (x) (funcall min-size x)) - (max-size (x) (funcall max-size x)) - (item-size (x) (funcall item-size x))) + (macrolet ((desired-size (x) `(funcall desired-size ,x)) + (min-size (x) `(funcall min-size ,x)) + (max-size (x) `(funcall max-size ,x)) + (item-size (x) `(funcall item-size ,x))) (let ((stretch-p (>= given (desired-size wanted))) (allocated 0) extra give used sizes) (if stretch-p (setq give (- (max-size wanted) (desired-size wanted)) extra (min (- given (desired-size wanted)) give)) - (setq give (- (desired-size wanted) (min-size wanted)) - extra (min (- (desired-size wanted) given) give))) + (setq give (- (desired-size wanted) (min-size wanted)) + extra (min (- (desired-size wanted) given) give))) (dolist (item items) (let (alloc) (typecase item ((member :fill) (setq alloc :fill)) (t - (let* ((item-size (item-size item))) - (if (eq item-size :fill) - (setq alloc :fill) - (progn - (setq alloc (desired-size item-size)) - (when (> give 0) - (if stretch-p - (progn - (setq used (/ (* (- (max-size item-size) - (desired-size item-size)) - extra) - give)) - (incf alloc used) - (fix-coordinates alloc) - (decf give (- (max-size item-size) - (desired-size item-size)))) - (progn - (setq used (/ (* (- (desired-size item-size) - (min-size item-size)) - extra) - give)) - (decf alloc used) - (fix-coordinates alloc) - (decf give (- (desired-size item-size) - (min-size item-size))))) - (decf extra used))))))) + (let ((item-size (item-size item))) + (if (eq item-size :fill) + (setq alloc :fill) + (progn + (setq alloc (desired-size item-size)) + (when (> give 0) + (if stretch-p + (progn + (setq used (/ (* (- (max-size item-size) + (desired-size item-size)) + extra) + give)) + (incf alloc used) + (fix-coordinates alloc) + (decf give (- (max-size item-size) + (desired-size item-size)))) + (progn + (setq used (/ (* (- (desired-size item-size) + (min-size item-size)) + extra) + give)) + (decf alloc used) + (fix-coordinates alloc) + (decf give (- (desired-size item-size) + (min-size item-size))))) + (decf extra used))))))) (when (numberp alloc) (incf allocated alloc)) (push alloc sizes))) @@ -624,10 +624,11 @@ (when (> fills 0) (let ((x (if (> leftover 0) (fix-coordinate (/ leftover fills)) - 0))) + 0))) (setf sizes (nsubstitute x :fill sizes))))) (nreverse sizes)))) - + + ;;; Most of the layout panes should inherit from this (defclass layout-pane (sheet-mute-input-mixin @@ -650,4 +651,3 @@ (resize-sheet* child (space-requirement-width space-req) (space-requirement-height space-req))))) - diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 0577c6a0..ef76416e 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.19 92/05/06 15:37:16 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.20 92/05/07 13:11:13 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -14,14 +14,14 @@ (defclass scroller-pane (client-space-requirement-mixin wrapping-space-mixin layout-pane) - ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy) - (vertical-scroll-bar :initform nil :accessor scroller-pane-vertical-scroll-bar) - (horizontal-scroll-bar :accessor - scroller-pane-horizontal-scroll-bar - :initform nil) - (scrolling-supplied-by-gadget :initform nil) - contents - viewport) + ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy) + (vertical-scroll-bar :initform nil + :accessor scroller-pane-vertical-scroll-bar) + (horizontal-scroll-bar :initform nil + :accessor scroller-pane-horizontal-scroll-bar) + (scrolling-supplied-by-gadget :initform nil) + contents + viewport) (:default-initargs :scroll-bars :both)) (defmethod pane-viewport ((x sheet)) @@ -44,24 +44,22 @@ (declare (ignore frame-manager frame ignore contents)) nil) -(defmethod allocate-space :before ((sp scroller-pane) width height) +(defmethod allocate-space :before ((scroller scroller-pane) width height) (declare (ignore width height)) ;; Adjust the status of the scrollbars - (multiple-value-bind - (changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p) - (compute-dynamic-scroll-bar-values sp) - (if changedp - (update-dynamic-scroll-bars - sp - changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p)))) - -(defmethod compose-space ((sp scroller-pane) &key width height) + (multiple-value-bind (changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values scroller) + (when changedp + (update-dynamic-scroll-bars scroller changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p)))) + +(defmethod compose-space ((scroller scroller-pane) &key width height) (declare (ignore width height)) (let ((sr (copy-space-requirement (call-next-method)))) + ;;--- Make sure the scroller pane is big enough to hold something (maxf (space-requirement-width sr) 50) (maxf (space-requirement-height sr) 50) sr)) @@ -69,77 +67,75 @@ ;;--- Ideally we should use a toolkit scrolling window. This will look ;;--- exactly right and will deal with user specified placement of scroll-bars. ;;--- However the geometry management problems are quite huge. - (defmethod initialize-instance :after ((pane scroller-pane) &key contents frame-manager frame scroll-bars) - (let ((x (gadget-supplied-scrolling frame-manager frame contents :scroll-bars scroll-bars))) + (let ((x (gadget-supplied-scrolling frame-manager frame contents + :scroll-bars scroll-bars))) (if x (progn (sheet-adopt-child pane x) (setf (slot-value pane 'scrolling-supplied-by-gadget) t) x) - (progn - (check-type scroll-bars - (member :both :dynamic :vertical :horizontal)) - (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane - (with-look-and-feel-realization (frame-manager frame) - (let ((verticalp - (member scroll-bars '(:both :dynamic :vertical))) - (horizontalp - (member scroll-bars '(:both :dynamic :horizontal)))) - (setf vertical-scroll-bar - (and verticalp - (make-pane 'scroll-bar - :orientation :vertical - :client pane - :id :vertical)) - horizontal-scroll-bar - (and horizontalp - (make-pane 'scroll-bar - :id :horizontal - :client pane - :orientation :horizontal)) - c contents - viewport (make-pane 'viewport)) - (sheet-adopt-child pane - (cond ((and horizontalp verticalp) - (tabling () - (viewport vertical-scroll-bar) - (horizontal-scroll-bar - nil))) - (verticalp - (horizontally () - viewport - vertical-scroll-bar)) - (horizontalp - (vertically () - viewport - horizontal-scroll-bar)) - (t (error "Should not have got here")))) - - (sheet-adopt-child viewport c) - ;;-- Add callbacks - ))))))) - - -(defun update-scroll-bars (vp) - ;;-- This is not the most efficient thing in the world - (multiple-value-bind - (changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar - vscroll-bar-enabled-p) - (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent vp))) + (progn + (check-type scroll-bars + (member :both :dynamic :vertical :horizontal)) + (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane + (with-look-and-feel-realization (frame-manager frame) + (let ((verticalp + (member scroll-bars '(:both :dynamic :vertical))) + (horizontalp + (member scroll-bars '(:both :dynamic :horizontal)))) + (setf vertical-scroll-bar + (and verticalp + (make-pane 'scroll-bar + :orientation :vertical + :id :vertical + :client pane)) + horizontal-scroll-bar + (and horizontalp + (make-pane 'scroll-bar + :orientation :horizontal + :id :horizontal + :client pane)) + c contents + viewport (make-pane 'viewport)) + (sheet-adopt-child + pane + (cond ((and horizontalp verticalp) + (tabling () + (viewport vertical-scroll-bar) + (horizontal-scroll-bar nil))) + (verticalp + (horizontally () + viewport + vertical-scroll-bar)) + (horizontalp + (vertically () + viewport + horizontal-scroll-bar)) + (t (error "Internal error laying out scroll bars")))) + (sheet-adopt-child viewport c) + ;;--- Add callbacks + ))))))) + +(defun update-scroll-bars (viewport) + ;;--- This is not the most efficient thing in the world + (multiple-value-bind (changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent viewport))) (update-dynamic-scroll-bars - (sheet-parent (sheet-parent vp)) - changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar - vscroll-bar-enabled-p t)) - (with-bounding-rectangle* (minx miny maxx maxy) - (viewport-contents-extent vp) + (sheet-parent (sheet-parent viewport)) changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p t)) + (with-bounding-rectangle* (minx miny maxx maxy) + (viewport-contents-extent viewport) (with-bounding-rectangle* (vminx vminy vmaxx vmaxy) - (viewport-viewport-region vp) + (viewport-viewport-region viewport) (with-accessors ((horizontal-scroll-bar scroller-pane-horizontal-scroll-bar) (vertical-scroll-bar scroller-pane-vertical-scroll-bar)) - (sheet-parent (sheet-parent vp)) + (sheet-parent (sheet-parent viewport)) (when vertical-scroll-bar (update-scroll-bar vertical-scroll-bar miny maxy vminy vmaxy)) @@ -147,53 +143,53 @@ (update-scroll-bar horizontal-scroll-bar minx maxx vminx vmaxx)))))) - ;;--- In the case where the viewport is bigger than the window this ;;--- code gets things wrong. Check out the thinkadot demo. It's ;;--- because (- (--) (- vmin)) is negative. - (defun update-scroll-bar (scroll-bar min max vmin vmax) (declare (optimize (safety 0) (speed 3))) (let ((current-size (scroll-bar-current-size scroll-bar)) (current-value (scroll-bar-current-value scroll-bar))) - ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size + ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size + ;; before, and the viewport is bigger than the extent, don't bother with + ;; the fancy math. (let* ((gmin (float (gadget-min-value scroll-bar) 0s0)) (gmax (float (gadget-max-value scroll-bar) 0s0)) (range (- gmax gmin))) - (declare (type single-float range gmin gmax)) - (if (and (and current-size (= (the single-float current-size) range)) - (> (- vmax vmin) (- max min))) + (declare (type single-float range gmin gmax)) + (when (and (and current-size (= (the single-float current-size) range)) + (> (- vmax vmin) (- max min))) (return-from update-scroll-bar)) - (let* ((size (the single-float - (* range - (the single-float - (if (= max min) - 1.0 - (min 1.0 (the single-float - (/ (float (- vmax vmin) 0.0s0) - (float (- max min) 0.0s0))))))))) - (pos (the single-float - (min 1.0 - (the single-float - (max 0.0 - (the single-float - (if (zerop (- (- max min) (- vmax vmin))) - 0.0 - (the single-float - (/ (float (- vmin min) 0.0s0) - (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) - (value (+ (gadget-min-value scroll-bar) - (* (- range size) pos)))) - (declare (type single-float pos size)) - (unless (and current-size - current-value - (= current-size size) - (= current-value value)) - (setf (scroll-bar-current-size scroll-bar) size - (scroll-bar-current-value scroll-bar) value) - (change-scroll-bar-values scroll-bar - :slider-size size - :value value)))))) + (let* ((size (the single-float + (* range + (the single-float + (if (= max min) + 1.0 + (min 1.0 (the single-float + (/ (float (- vmax vmin) 0.0s0) + (float (- max min) 0.0s0))))))))) + (pos (the single-float + (min 1.0 + (the single-float + (max 0.0 + (the single-float + (if (zerop (- (- max min) (- vmax vmin))) + 0.0 + (the single-float + (/ (float (- vmin min) 0.0s0) + (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) + (value (+ (gadget-min-value scroll-bar) + (* (- range size) pos)))) + (declare (type single-float pos size)) + (unless (and current-size + current-value + (= current-size size) + (= current-value value)) + (setf (scroll-bar-current-size scroll-bar) size + (scroll-bar-current-value scroll-bar) value) + (change-scroll-bar-values scroll-bar + :slider-size size + :value value)))))) (defmethod scroll-bar-value-changed-callback :before @@ -207,18 +203,16 @@ (defmethod scroll-bar-value-changed-callback (sheet (client scroller-pane) id value size) (with-slots (viewport contents) client - ;;--- This TYPEP stuff is a major kludge (let* ((extent (viewport-contents-extent viewport)) - (vp viewport) - (viewport (viewport-viewport-region vp))) + (region (viewport-viewport-region viewport))) (case id (:vertical (scroll-extent contents - :x (bounding-rectangle-min-x viewport) + :x (bounding-rectangle-min-x region) :y (+ (bounding-rectangle-min-y extent) (* (max 0 (- (bounding-rectangle-height extent) - (bounding-rectangle-height viewport))) + (bounding-rectangle-height region))) (if (= size (gadget-range sheet)) 0 (/ (- value (gadget-min-value sheet)) @@ -227,12 +221,12 @@ (scroll-extent contents :x (* (max 0 (- (bounding-rectangle-width extent) - (bounding-rectangle-width viewport))) + (bounding-rectangle-width region))) (if (= size (gadget-range sheet)) 0 (/ (- value (gadget-min-value sheet)) (- (gadget-range sheet) size)))) - :y (bounding-rectangle-min-y viewport))))))) + :y (bounding-rectangle-min-y region))))))) (defun update-region (stream nleft ntop nright nbottom &key no-repaint) ;;--- I suspect that we should pass in mins and maxs since this does @@ -261,56 +255,52 @@ (max (bounding-rectangle-height stream) height)))))) (defun scroll-extent (stream &key (x 0) (y 0)) - (let ((vp (pane-viewport stream))) - (when vp + (let ((viewport (pane-viewport stream))) + (when viewport (with-bounding-rectangle* (left top right bottom) - (pane-viewport-region stream) + (pane-viewport-region stream) ;;;---- This should actually bash the sheet-transformation (setf (sheet-transformation stream) - (make-translation-transformation (- x) (- y))) - (bounding-rectangle-set-position (viewport-viewport-region vp) x y) + (make-translation-transformation (- x) (- y))) + (bounding-rectangle-set-position (viewport-viewport-region viewport) x y) ;;--- Is this the correct place? - (update-scroll-bars vp) + (update-scroll-bars viewport) (with-bounding-rectangle* (nleft ntop nright nbottom) - (pane-viewport-region stream) + (pane-viewport-region stream) ;;--- Do we really want to do this here?? (update-region stream nleft ntop nright nbottom) (cond - ;; if some of the stuff that was previously on display is still on display - ;; bitblt it into the proper place and redraw the rest. - ((ltrb-overlaps-ltrb-p left top right bottom - nleft ntop nright nbottom) - ;; move the old stuff to the new position - (window-shift-visible-region stream - left top right bottom - nleft ntop nright nbottom) - (let ((rectangles (ltrb-difference nleft ntop nright nbottom - left top right bottom))) - (with-sheet-medium (medium stream) - (dolist (region rectangles) - (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* region) - :ink +background-ink+ :filled t) - (when (typep stream 'clim-internals::output-recording-mixin) - (replay (stream-output-history stream) stream region)))))) - ;; otherwise, just redraw the whole visible viewport - ;; adjust for the left and top margins by hand so clear-area doesn't erase - ;; the margin components. - ((typep stream 'clim-internals::output-recording-mixin) - (let ((region (viewport-viewport-region vp))) - ;;---- we should make the sheet-region bigger at this point - ;; perhaps we do a union of the sheet-region and the viewport - (with-sheet-medium (medium stream) - (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* region) - :ink +background-ink+ :filled t)) - (replay (stream-output-history stream) stream region))))) + ;; If some of the stuff that was previously on display is still on + ;; display, BITBLT it into the proper place and redraw the rest. + ((ltrb-overlaps-ltrb-p left top right bottom + nleft ntop nright nbottom) + ;; move the old stuff to the new position + (window-shift-visible-region stream + left top right bottom + nleft ntop nright nbottom) + (let ((rectangles (ltrb-difference nleft ntop nright nbottom + left top right bottom))) + (with-sheet-medium (medium stream) + (dolist (region rectangles) + (multiple-value-call #'draw-rectangle* + medium (bounding-rectangle* region) + :ink +background-ink+ :filled t) + (when (output-recording-stream-p stream) + (replay (stream-output-history stream) stream region)))))) + ;; Otherwise, just redraw the whole visible viewport + ;; adjust for the left and top margins by hand so clear-area doesn't erase + ;; the margin components. + ((output-recording-stream-p stream) + (let ((region (viewport-viewport-region viewport))) + ;;---- we should make the sheet-region bigger at this point + ;; perhaps we do a union of the sheet-region and the viewport + (with-sheet-medium (medium stream) + (multiple-value-call #'draw-rectangle* + medium (bounding-rectangle* region) + :ink +background-ink+ :filled t)) + (replay (stream-output-history stream) stream region))))) (when (and (/= left x) (/= top y)) - (note-viewport-position-changed - (pane-frame stream) - stream)))))) + (note-viewport-position-changed (pane-frame stream) stream)))))) (defmethod note-viewport-position-changed (frame pane) nil) @@ -389,10 +379,9 @@ :height shaft-thickness)))))))) (sheet-adopt-child pane inferiors))))) -(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) &rest args +(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) &key slider-size value) - (declare (dynamic-extent args)) - (declare (ignore slider-size value)) + ;;--- Set the indicator to the proper size and location ) diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp index 40076c95..5b316a16 100644 --- a/silica/db-slider.lisp +++ b/silica/db-slider.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-slider.lisp,v 1.6 92/04/15 11:45:05 cer Exp $ +;; $fiHeader: db-slider.lisp,v 1.7 92/05/07 13:11:15 cer Exp $ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." @@ -16,6 +16,10 @@ ((thickness :initarg :thickness :initform 20) (show-value :initarg :show-value :accessor slider-show-value) + ;; ARMED has three states: + ;; NIL ==> the slider is not armed + ;; T ==> the slider is armed, waiting for a pointer button press + ;; :ACTIVE ==> the slider is armed, waiting for a pointer button release (armed :initform nil)) (:default-initargs :value 0 :show-value nil)) @@ -86,11 +90,22 @@ (- x dx) mid-y) :ink ink))))))) -(defmethod handle-event ((pane slider-pane) (event pointer-button-press-event)) +(defmethod handle-event ((pane slider-pane) (event pointer-enter-event)) (with-slots (armed) pane (unless armed + (setf armed t) + (armed-callback pane (gadget-client pane) (gadget-id pane))))) + +(defmethod handle-event ((pane slider-pane) (event pointer-exit-event)) + (with-slots (armed) pane + (when armed + (setf armed nil) + (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) + +(defmethod handle-event ((pane slider-pane) (event pointer-button-press-event)) + (with-slots (armed) pane + (when armed (setf armed :active) - (armed-callback pane (gadget-client pane) (gadget-id pane)) (let ((x (pointer-event-x event)) (y (pointer-event-y event))) (with-bounding-rectangle* (left top right bottom) (sheet-region pane) @@ -102,9 +117,8 @@ (defmethod handle-event ((pane slider-pane) (event pointer-button-release-event)) (with-slots (armed) pane - (when armed - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane)) + (when (eq armed :active) + (setf armed t) (let ((x (pointer-event-x event)) (y (pointer-event-y event))) (with-bounding-rectangle* (left top right bottom) (sheet-region pane) @@ -118,7 +132,7 @@ (defmethod handle-event ((pane slider-pane) (event pointer-motion-event)) (with-slots (armed) pane - (when (eql armed :active) + (when (eq armed :active) (let ((x (pointer-event-x event)) (y (pointer-event-y event))) (with-bounding-rectangle* (left top right bottom) (sheet-region pane) @@ -129,18 +143,6 @@ (update-slider-value pane x left right))))) (drag-callback pane (gadget-client pane) (gadget-id pane) (gadget-value pane))))) -(defmethod handle-event ((pane slider-pane) (event pointer-enter-event)) - (with-slots (armed) pane - (unless armed - (setf armed t) - (armed-callback pane (gadget-client pane) (gadget-id pane))))) - -(defmethod handle-event ((pane slider-pane) (event pointer-exit-event)) - (with-slots (armed) pane - (when armed - (setf armed nil) - (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) - (defmethod update-slider-value ((pane slider-pane) coord min max) (let* ((min-value (slot-value pane 'min-value)) (max-value (slot-value pane 'max-value)) diff --git a/silica/event.lisp b/silica/event.lisp index e8853bf2..7969ed50 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.10 92/05/07 13:11:17 cer Exp Locker: cer $ +;; $fiHeader: event.lisp,v 1.11 92/05/13 17:10:35 cer Exp Locker: cer $ (in-package :silica) @@ -203,27 +203,27 @@ ;;; This code does not deal with cases (2) and (3) correctly. ;;; It will fail to generate enter/exit events for cases -(defun generate-crossing-events (port sheet x y modifiers button) +(defun generate-crossing-events (port sheet x y modifiers button pointer) (macrolet ((generate-enter-event (sheet) `(let ((sheet ,sheet)) (dispatch-event sheet (make-instance 'pointer-enter-event - :x x - :y y - :button button :sheet sheet - :modifiers modifiers)))) + :x x :y y + :button button + :modifiers modifiers + :pointer pointer)))) (generate-exit-event (sheet) `(let ((sheet ,sheet)) (dispatch-event sheet (make-instance 'pointer-exit-event - :x x - :y y - :button button :sheet sheet - :modifiers modifiers))))) + :x x :y y + :button button + :modifiers modifiers + :pointer pointer))))) (let ((v (port-trace-thing port))) ;; Pop up the stack of sheets (unless (zerop (fill-pointer v)) @@ -270,13 +270,10 @@ (map-sheet-position-to-child child new-x new-y)) (setq sheet child) (vector-push-extend child v))))))) - - -(warn "Checking for port") -(defun distribute-pointer-event (port mirrored-sheet event-type x y modifiers button) +(defun distribute-pointer-event (port mirrored-sheet event-type x y modifiers button pointer) ;; Generate all the correct enter/exit events - (generate-crossing-events port mirrored-sheet x y modifiers button) + (generate-crossing-events port mirrored-sheet x y modifiers button pointer) ;; dispatch event to the innermost sheet (let ((sheet (let ((v (port-trace-thing port))) (and (not (zerop (fill-pointer v))) @@ -289,41 +286,45 @@ sheet (make-instance event-type :sheet sheet - :native-x x - :native-y y - :x tx - :y ty + :native-x x :native-y y + :x tx :y ty :modifiers modifiers - :button button)))))) + :button button + :pointer pointer)))))) (defmethod distribute-event ((port port) event) (distribute-event-1 port event)) -(defgeneric distribute-event-1 (port event) - (:method ((port port) (event event)) - (dispatch-event (event-sheet event) event)) - (:method ((port port) (event keyboard-event)) - (let ((focus (or (port-keyboard-input-focus port) - (event-sheet event)))) - ;;--- Is this correct??? - (setf (slot-value event 'sheet) focus) - (dispatch-event focus event))) - (:method ((port port) (event window-event)) - (dispatch-event - (window-event-mirrored-sheet event) - event)) - (:method ((port port) (event pointer-event)) - (distribute-pointer-event - port - (event-sheet event) - (typecase event - ((or pointer-exit-event pointer-enter-event) - 'pointer-motion-event) - (t (type-of event))) - (pointer-event-native-x event) - (pointer-event-native-y event) - (event-modifier-state event) - (pointer-event-button event)))) +(defgeneric distribute-event-1 (port event)) + +(defmethod distribute-event-1 ((port port) (event event)) + (dispatch-event (event-sheet event) event)) + +(defmethod distribute-event-1 ((port port) (event keyboard-event)) + (let ((focus (or (port-keyboard-input-focus port) + (event-sheet event)))) + ;;--- Is this correct??? + (setf (slot-value event 'sheet) focus) + (dispatch-event focus event))) + +(defmethod distribute-event-1 ((port port) (event window-event)) + (dispatch-event + (window-event-mirrored-sheet event) + event)) + +(defmethod distribute-event-1 ((port port) (event pointer-event)) + (distribute-pointer-event + port + (event-sheet event) + (typecase event + ((or pointer-exit-event pointer-enter-event) + 'pointer-motion-event) + (t (type-of event))) + (pointer-event-native-x event) + (pointer-event-native-y event) + (event-modifier-state event) + (pointer-event-button event) + (pointer-event-pointer event))) ;;; Local event processing diff --git a/silica/framem.lisp b/silica/framem.lisp index 5e7649a0..b88922c8 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: framem.lisp,v 1.6 92/04/21 16:12:39 cer Exp Locker: cer $ +;; $fiHeader: framem.lisp,v 1.7 92/05/06 15:37:18 cer Exp $ (in-package :silica) @@ -29,20 +29,42 @@ ((port :reader port :initarg :port) (frames :accessor frame-manager-frames :initform nil))) -;;-- This is most likely wrong. - +;;--- This is most likely wrong (defmethod graft ((framem standard-frame-manager)) (car (port-grafts (port framem)))) -(defvar *frame-managers* nil) +(defvar *default-frame-manager* nil) + +(defmacro with-frame-manager ((framem) &body body) + `(let ((*default-frame-manager* ,framem)) + ,@body)) (defun find-frame-manager (&rest options - &key (port (apply #'find-port options)) + &key port &allow-other-keys) (declare (dynamic-extent options)) - (second (or (assoc port *frame-managers*) - (car (push (list port (make-frame-manager port)) - *frame-managers*))))) + (unless port + (with-keywords-removed (options options '(:port)) + (setq port (apply #'find-port options)))) + (cond + ;; (find-frame-manager) -> default one + ((and (null options) *default-frame-manager*)) + ;; We specified a port we have to make sure the default on + ;; matches it + ((and *default-frame-manager* + (framem-matches-options-p + *default-frame-manager* + port options)) + *default-frame-manager*) + ;; Failing that we make one + (t + (or (port-frame-manager port) + (setf (port-frame-manager port) + (make-frame-manager port)))))) + +(defmethod framem-matches-options-p ((framem standard-frame-manager) port options) + (declare (ignore options)) + (eq (port framem) port)) (defmethod make-frame-manager (port) (cerror "Make a default frame manager" @@ -75,7 +97,6 @@ (defmethod adopt-frame :after ((framem standard-frame-manager) frame) (pushnew frame (frame-manager-frames framem))) - (defmethod disown-frame ((framem standard-frame-manager) frame) (let ((top (frame-top-level-sheet frame))) (when top @@ -84,9 +105,8 @@ (frame-state frame) :disowned)))) (defmethod disown-frame :after ((framem standard-frame-manager) frame) - (setf (frame-manager-frames framem) - (delete frame (frame-manager-frames framem)) - (slot-value frame 'frame-manager) nil)) + (setf (frame-manager-frames framem) (delete frame (frame-manager-frames framem)) + (slot-value frame 'frame-manager) nil)) (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame) (update-frame-settings framem frame) @@ -94,9 +114,8 @@ (when (frame-top-level-sheet frame) (setf (sheet-enabled-p (frame-top-level-sheet frame)) t))) -(defmethod update-frame-settings ((framem standard-frame-manager) (frame t)) - nil) - (defmethod note-frame-disabled :after ((framem standard-frame-manager) frame) (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)) +(defmethod update-frame-settings ((framem standard-frame-manager) frame) + nil) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index a9e4ff9c..6c2ef8a8 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.21 92/05/07 13:11:19 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.22 92/05/12 18:24:27 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -32,15 +32,17 @@ (defclass gadget (foreground-background-and-text-style-mixin) - ((id :initarg :id :reader gadget-id :initform nil) - (client :initarg :client :initform nil :accessor gadget-client) - (armed-callback :initarg :armed-callback :initform nil - :reader gadget-armed-callback) - (disarmed-callback :initarg :disarmed-callback :initform nil - :reader gadget-disarmed-callback) - (active :initarg :active :accessor gadget-active-p)) + ((id :initarg :id :reader gadget-id :initform nil) + (client :initarg :client :initform nil :accessor gadget-client) + (armed-callback :initarg :armed-callback :initform nil + :reader gadget-armed-callback) + (disarmed-callback :initarg :disarmed-callback :initform nil + :reader gadget-disarmed-callback) + (active :initarg :active :accessor gadget-active-p)) (:default-initargs :active t)) +;;; Arming and disarming + (defmethod armed-callback :around ((gadget gadget) (client t) (id t)) (let ((callback (gadget-armed-callback gadget))) (if callback @@ -59,6 +61,24 @@ (defmethod disarmed-callback ((gadget gadget) (client t) (id t)) nil) +;;; Activation and deactivation, not intended to be like callbacks + +(defmethod activate-gadget ((gadget gadget)) + (unless (gadget-active-p gadget) + (setf (gadget-active-p gadget) t) + (note-gadget-activated (gadget-client gadget) gadget))) + +(defmethod note-gadget-activated ((client t) (gadget gadget)) + nil) + +(defmethod deactivate-gadget ((gadget gadget)) + (when (gadget-active-p gadget) + (setf (gadget-active-p gadget) nil) + (note-gadget-deactivated (gadget-client gadget) gadget))) + +(defmethod note-gadget-deactivated ((client t) (gadget gadget)) + nil) + (defclass value-gadget (gadget) ((value :initarg :value :initform nil @@ -110,13 +130,13 @@ ;;; Basic gadgets-mixins -(defclass oriented-gadget () +(defclass oriented-gadget-mixin () ((orientation :initarg :orientation :accessor gadget-orientation)) (:default-initargs :orientation :horizontal)) -(defclass labelled-gadget () +(defclass labelled-gadget-mixin () ((label :initarg :label :accessor gadget-label) (alignment :initarg :align-x @@ -125,11 +145,11 @@ ;;--- Do the right thing #---ignore -(defmethod compute-gadget-label-size ((pane labelled-gadget)) +(defmethod compute-gadget-label-size ((pane labelled-gadget-mixin)) (values 50 20)) #+++ignore -(defun compute-gadget-label-size ((pane labelled-gadget)) +(defun compute-gadget-label-size ((pane labelled-gadget-mixin)) (let ((text (gadget-label pane)) (text-style (slot-value pane 'text-style))) (with-sheet-medium (medium pane) @@ -154,18 +174,16 @@ ;;; The intent is that the real implementations inherit from these ;;; Slider - (defclass slider - (value-gadget oriented-gadget range-gadget-mixin labelled-gadget) + (value-gadget oriented-gadget-mixin range-gadget-mixin labelled-gadget-mixin) ((drag-callback :initarg :drag-callback :initform nil :reader slider-drag-callback) (decimal-places :initarg :decimal-places :reader slider-decimal-places) (show-value-p :initarg :show-value-p :accessor gadget-show-value-p)) - (:default-initargs - :decimal-places 0 - :show-value-p nil)) + (:default-initargs :decimal-places 0 + :show-value-p nil)) (defmethod drag-callback :around ((gadget slider) (client t) (id t) value) (let ((callback (slider-drag-callback gadget))) @@ -179,9 +197,8 @@ ;;; Scroll bar - (defclass scroll-bar - (value-gadget range-gadget-mixin oriented-gadget) + (value-gadget range-gadget-mixin oriented-gadget-mixin) ((current-value :initform nil :accessor scroll-bar-current-value) (current-size :initform nil :accessor scroll-bar-current-size) (drag-callback :initarg :drag-callback :initform nil @@ -205,27 +222,27 @@ ;;; Push-button (defclass push-button - (action-gadget labelled-gadget) + (action-gadget labelled-gadget-mixin) ()) - -(defclass toggle-button (value-gadget labelled-gadget) - ((indicator-type :initarg :indicator-type :initform :some-of - :type (member :some-of :one-of) - :reader gadget-indicator-type))) - +;;; Toggle button +(defclass toggle-button + (value-gadget labelled-gadget-mixin) + ((indicator-type :initarg :indicator-type :initform :some-of + :type (member :some-of :one-of) + :reader gadget-indicator-type))) ;;; Menu button (defclass menu-button - (value-gadget labelled-gadget) + (value-gadget labelled-gadget-mixin) ((indicator-type :initarg :indicator-type :initform :some-of :reader gadget-indicator-type))) (defclass label-pane - (gadget labelled-gadget) + (gadget labelled-gadget-mixin) ()) @@ -235,7 +252,7 @@ ;;; Radio box [exclusive-choice] .. [inclusive-choice] (defclass radio-box - (value-gadget oriented-gadget) + (value-gadget oriented-gadget-mixin) ((selections :initform nil :reader radio-box-selections) ;;--- think about this... @@ -254,13 +271,12 @@ :value (equal (radio-box-current-selection rb) choice) :label (if (stringp choice) (string choice) - (gadget-label choice)) + (gadget-label choice)) :id choice :parent rb)))))) - -;; Check-box +;;; Check-box (defclass check-box (value-gadget oriented-gadget) @@ -271,18 +287,21 @@ :initarg :current-selection :accessor check-box-current-selection))) -(defmethod initialize-instance :after ((rb check-box) &key choices) - (let ((frame (pane-frame rb))) +(defmethod initialize-instance :after ((cb check-box) &key choices) + (let ((frame (pane-frame cb))) (with-look-and-feel-realization ((frame-manager frame) frame) (dolist (choice choices) - (make-pane 'toggle-button - :value (equal (check-box-current-selection rb) choice) - :label (if (stringp choice) - (string choice) - (gadget-label choice)) - :indicator-type :some-of - :id choice - :parent rb))))) + (unless (panep choice) + ;; Sometimes the user calls MAKE-PANE within a call to + ;; WITH-RADIO-BOX, so don't mess up + (make-pane 'toggle-button + :value (equal (check-box-current-selection cb) choice) + :label (if (stringp choice) + (string choice) + (gadget-label choice)) + :indicator-type :some-of + :id choice + :parent cb)))))) ;;; Menu-bar @@ -351,7 +370,7 @@ (viewport-region-changed (sheet-child viewport) viewport)) ;;--- Work on this -#+ignore +#+++ignore (defmethod note-sheet-region-changed :around ((viewport viewport) &key port-did-it) (declare (ignore port-did-it)) (multiple-value-bind (changedp @@ -365,8 +384,7 @@ vscroll-bar vscroll-bar-enabled-p) (call-next-method)))) -(defun update-dynamic-scroll-bars (sp - changedp +(defun update-dynamic-scroll-bars (scroller changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar vscroll-bar-enabled-p &optional relayout) @@ -376,38 +394,37 @@ (when vscroll-bar (setf (sheet-enabled-p vscroll-bar) vscroll-bar-enabled-p)) (when (or (and hscroll-bar (not hscroll-bar-enabled-p)) - (and vscroll-bar (not vscroll-bar-enabled-p))) - (let* ((contents (slot-value sp 'contents)) - (c-extent (viewport-contents-extent - (pane-viewport contents)))) - (multiple-value-bind - (vx vy) (window-viewport-position contents) - - (window-set-viewport-position - contents - (if (and hscroll-bar (not hscroll-bar-enabled-p)) - (bounding-rectangle-min-x c-extent) - vx) - (if (and vscroll-bar (not vscroll-bar-enabled-p)) - (bounding-rectangle-min-y c-extent) - vy))))) - (clear-space-requirement-caches-in-tree sp) + (and vscroll-bar (not vscroll-bar-enabled-p))) + (let* ((contents (slot-value scroller 'contents)) + (c-extent (viewport-contents-extent + (pane-viewport contents)))) + (multiple-value-bind (vx vy) + (window-viewport-position contents) + (window-set-viewport-position + contents + (if (and hscroll-bar (not hscroll-bar-enabled-p)) + (bounding-rectangle-min-x c-extent) + vx) + (if (and vscroll-bar (not vscroll-bar-enabled-p)) + (bounding-rectangle-min-y c-extent) + vy))))) + (clear-space-requirement-caches-in-tree scroller) (when relayout - (let ((table (sheet-child sp))) - (multiple-value-bind - (w h) - (bounding-rectangle-size table) - (allocate-space table w h)))))) - -(defun compute-dynamic-scroll-bar-values (sp) - (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar sp)) - (vscroll-bar (scroller-pane-vertical-scroll-bar sp)) - (scroll-bar-policy (scroller-pane-scroll-bar-policy sp))) + (let ((table (sheet-child scroller))) + (multiple-value-bind (width height) + (bounding-rectangle-size table) + (allocate-space table width height)))))) + +(defun compute-dynamic-scroll-bar-values (scroller) + (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar scroller)) + (vscroll-bar (scroller-pane-vertical-scroll-bar scroller)) + (scroll-bar-policy (scroller-pane-scroll-bar-policy scroller))) (if (eq scroll-bar-policy :dynamic) - (multiple-value-bind (vwidth vheight) (bounding-rectangle-size sp) + (multiple-value-bind (vwidth vheight) + (bounding-rectangle-size scroller) (multiple-value-bind (cwidth cheight) (bounding-rectangle-size - (viewport-contents-extent (slot-value sp 'viewport))) + (viewport-contents-extent (slot-value scroller 'viewport))) (let ((ohenp (sheet-enabled-p hscroll-bar)) (ovenp (sheet-enabled-p vscroll-bar)) (nhenp (> cwidth vwidth)) @@ -422,10 +439,10 @@ (values nil nil nil nil nil)))) (defun viewport-contents-extent (viewport) - (let ((c (sheet-child viewport))) - (stream-output-history c))) - - + (let ((contents (sheet-child viewport))) + (if (output-recording-stream-p contents) + (stream-output-history contents) + contents))) ;;; Then there is the layout stuff and scrolling macros @@ -441,6 +458,29 @@ :frame frame :frame-manager framem options)) + +;;; List panes and option menus + +(defclass set-gadget-mixin () + ((items :initarg :items :accessor set-gadget-items) + (name-key :initarg :name-key :accessor set-gadget-name-key) + (value-key :initarg :value-key :accessor set-gadget-value-key) + (test :initarg :test :accessor set-gadget-test)) + (:default-initargs :items nil + :test #'eql + :value-key #'identity + :name-key #'princ-to-string)) + +(defclass list-pane (set-gadget-mixin value-gadget) + ((mode :initarg :mode :type (member :exclusive :nonexclusive) + :accessor list-pane-mode)) + (:default-initargs :mode :exclusive)) + +(defclass option-pane (set-gadget-mixin + value-gadget + labelled-gadget) + ()) + ;; Callbacks on widgets generate these events @@ -458,48 +498,3 @@ (defmethod handle-event ((gadget action-gadget) (event activate-gadget-event)) (activate-callback gadget (gadget-client gadget) (gadget-id gadget))) - - -;;; Do these have readers and writers? - -;;; Activation/Deactivation protocol - -(defmethod activate-gadget ((gadget gadget)) - (unless (gadget-active-p gadget) - (setf (gadget-active-p gadget) t) - (note-gadget-activated (gadget-client gadget) gadget))) - -(defmethod note-gadget-activated ((client t) (gadget gadget)) - nil) - -(defmethod deactivate-gadget ((gadget gadget)) - (when (gadget-active-p gadget) - (setf (gadget-active-p gadget) nil) - (note-gadget-deactivated (gadget-client gadget) gadget))) - -(defmethod note-gadget-deactivated ((client t) (gadget gadget)) - nil) - -;;; List panes and option menus - -(defclass set-gadget-mixin () - ((items :initarg :items :accessor set-gadget-items) - (name-key :initarg :name-key :accessor set-gadget-name-key) - (value-key :initarg :value-key :accessor set-gadget-value-key) - (test :initarg :test :accessor set-gadget-test)) - (:default-initargs - :items nil - :test #'eql - :value-key #'identity - :name-key #'princ-to-string)) - -(defclass list-pane (set-gadget-mixin value-gadget) - ((mode :initarg :mode :type (member :exclusive :nonexclusive) - :accessor list-pane-mode)) - (:default-initargs :mode :exclusive)) - -(defclass option-pane (set-gadget-mixin - value-gadget - labelled-gadget) - ()) - diff --git a/silica/graphics.lisp b/silica/graphics.lisp index 9c4b2bf3..e7af6197 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics.lisp,v 1.10 92/04/28 09:25:19 cer Exp Locker: cer $ +;; $fiHeader: graphics.lisp,v 1.11 92/05/07 13:11:21 cer Exp $ (in-package :silica) @@ -146,20 +146,20 @@ (dolist (x spread-values) (push x spread-argument-names)))) (let ((original-keywords keyword) (new-keywords - (mapcan #'(lambda (x) - (let ((y (assoc (if (consp x) (car x) x) keyword-arguments-to-spread))) - (if y (copy-list (cddr y)) (list x)))) - keyword))) - (values (nreverse unspread-argument-names) - (nreverse spread-arguments) - (nreverse spread-argument-names) - (mapcar #'(lambda (x) (if (consp x) (car x) x)) new-keywords) - original-keywords - new-keywords - (mapcar #'(lambda (x) - (intern (symbol-name (if (consp x) (car x) x)) - *keyword-package*)) - new-keywords))))) + (mapcan #'(lambda (x) + (let ((y (assoc (if (consp x) (car x) x) + keyword-arguments-to-spread))) + (if y (copy-list (cddr y)) (list x)))) + keyword))) + (values (nreverse unspread-argument-names) + (nreverse spread-arguments) + (nreverse spread-argument-names) + (mapcar #'(lambda (x) (if (consp x) (car x) x)) new-keywords) + original-keywords + new-keywords + (mapcar #'(lambda (x) + (intern (symbol-name (if (consp x) (car x) x)) :keyword)) + new-keywords))))) (defun transform-graphics-function-call (medium-or-stream medium-graphics-function-name @@ -167,9 +167,7 @@ other-keyword-arguments required-arguments rest-argument - &optional - arguments - keyword-arguments-to-spread) + &optional arguments keyword-arguments-to-spread) (let ((drawing-options (mapcar #'(lambda (x) (intern (symbol-name x) :keyword)) @@ -217,16 +215,14 @@ ,medium-or-stream-name ,@required-arguments ,@(mapcan #'(lambda (kw-arg) - (let ((v - (or (second (assoc (kw-arg-keyword kw-arg) stuff)) - (kw-arg-default-value - kw-arg))) + (let ((v (or (second (assoc (kw-arg-keyword kw-arg) stuff)) + (kw-arg-default-value kw-arg))) (ks (assoc kw-arg keyword-arguments-to-spread))) (if ks (ecase (second ks) (point (list `(and ,v (point-x ,v)) `(and ,v (point-y ,v))))) - (list v)))) + (list v)))) other-keyword-arguments))) (supplied-drawing-options (mapcan #'(lambda (do) @@ -245,8 +241,7 @@ ,call) call)))))))))) -) - ;eval-when +) ;eval-when (defmacro transform-positions ((transform) &rest positions) @@ -319,8 +314,6 @@ points-to-transform distances-to-transform point-sequences-to-transform) - (flet ((kintern (x) - (intern x :keyword))) (let* ((spread-name (intern (format nil "~A*" name))) (drawing-options (all-drawing-options-lambda-list drawing-options)) @@ -330,7 +323,7 @@ (intern (format nil "~A~A*" 'port- name)))) (multiple-value-bind (unspread-argument-names spread-arguments spread-argument-names keyword-argument-names - unspread-other-keyword-arguments + unspread-other-keyword-arguments other-keyword-arguments keywords) (decode-graphics-function-arguments arguments keywords-to-spread) `(progn @@ -339,42 +332,50 @@ (declare (ignore ,@drawing-options ,@keyword-argument-names) (dynamic-extent args)) ,(if keywords-to-spread - `(with-keywords-removed - (args args - ',(mapcar #'(lambda (x) - (intern (car x) :keyword)) - keywords-to-spread)) - (apply #',spread-name - medium - ,@spread-arguments - ,@(mapcan #'(lambda (x) - (destructuring-bind - (name type . rest) x - (ecase type - (point (list - (kintern (first rest)) - `(and ,name (point-x ,name)) - (kintern (second rest)) - `(and ,name (point-y ,name))))))) - keywords-to-spread) - args)) - `(apply #',spread-name - medium - ,@spread-arguments - args))) + `(with-keywords-removed + (args args ',(mapcar #'(lambda (x) + (intern (symbol-name (car x)) :keyword)) + keywords-to-spread)) + (apply #',spread-name + medium + ,@spread-arguments + ,@(mapcan + #'(lambda (x) + (destructuring-bind (name type . rest) x + (ecase type + (point + (list (intern (symbol-name (first rest)) :keyword) + `(and ,name (point-x ,name)) + (intern (symbol-name (second rest)) :keyword) + `(and ,name (point-y ,name))))))) + keywords-to-spread) + args)) + `(apply #',spread-name + medium + ,@spread-arguments + args))) (defun ,spread-name (medium ,@spread-argument-names &rest args &key ,@drawing-options ,@other-keyword-arguments) (declare (ignore ,@drawing-options) (dynamic-extent args)) - (with-keywords-removed (args args ',keywords) - (apply #'invoke-with-drawing-options - medium - #'(lambda () - (,medium-graphics-function-name - medium - ,@spread-argument-names - ,@keyword-argument-names)) - args))) + ,(if keywords + `(with-keywords-removed (args args ',keywords) + (apply #'invoke-with-drawing-options + medium + #'(lambda () + (,medium-graphics-function-name + medium + ,@spread-argument-names + ,@keyword-argument-names)) + args)) + `(apply #'invoke-with-drawing-options + medium + #'(lambda () + (,medium-graphics-function-name + medium + ,@spread-argument-names + ,@keyword-argument-names)) + args))) (setf (get ',name 'args) '((,@spread-argument-names ,@keyword-argument-names) ,@args)) @@ -391,20 +392,17 @@ (let* ((sheet (medium-sheet medium))) ;; want to tranform stuff, set up clipping region etc etc ,(and points-to-transform - (do ((pts points-to-transform (cddr pts)) - (tf '#:transform) - (r nil)) - ((null pts) - `(let ((,tf (medium-transformation medium))) - ,@(nreverse r))) - (let ((b - `(transform-positions - (,tf) - ,(car pts) ,(cadr pts)))) - (if (member (car pts) - optional-points-to-transform) - (push `(when ,(car pts) ,b) r) - (push b r))))) + (do ((pts points-to-transform (cddr pts)) + (tf '#:transform) + (r nil)) + ((null pts) + `(let ((,tf (medium-transformation medium))) + ,@(nreverse r))) + (let ((b `(transform-positions (,tf) + ,(first pts) ,(second pts)))) + (if (member (car pts) optional-points-to-transform) + (push `(when ,(car pts) ,b) r) + (push b r))))) ,@(and distances-to-transform `((transform-distances ((medium-transformation medium)) @@ -429,7 +427,11 @@ unspread-other-keyword-arguments other-keyword-arguments arguments - keywords-to-spread)))))) + keywords-to-spread))))) + +(defun get-drawing-function-description (name) + (or (get name 'args) + (error "Cannot find description for: ~S" name))) (define-graphics-function draw-point ((point point x y)) @@ -543,11 +545,13 @@ (height (pattern-height pattern))) (if (or clipping-region transformation) (with-drawing-options (medium :clipping-region clipping-region - :transformation transformation) + :transformation transformation + :ink pattern) + (draw-rectangle* medium x y (+ x width) (+ y height) + :filled t)) + (with-drawing-options (medium :ink pattern) (draw-rectangle* medium x y (+ x width) (+ y height) - :filled t :ink pattern)) - (draw-rectangle* medium x y (+ x width) (+ y height) - :filled t :ink pattern)))) + :filled t))))) (define-graphics-function draw-polygon ((points point-sequence list-of-x-and-ys) @@ -655,81 +659,23 @@ (define-graphics-function draw-text (string-or-char (point point x y) - &key (start 0) - (end nil) - (align-x :left) - (align-y :baseline) - towards-point - transform-glyphs) + &key (start 0) (end nil) + (align-x :left) + (align-y :baseline) + towards-point + transform-glyphs) :points-to-transform (x y towards-x towards-y) :optional-points-to-transform (towards-x towards-y) :keywords-to-spread ((towards-point point towards-x towards-y)) :drawing-options :text) -(defmethod stream-glyph-for-character ((medium medium) character text-style - &optional our-font) - (port-glyph-for-character (port medium) character text-style our-font)) - -(defmethod stream-write-string-1 ((medium medium) glyph-buffer - start end x-font color x y) - (port-write-string-1 (port medium) medium - glyph-buffer start end x-font color x y)) - (defmethod sheet-beep ((x t)) x) (defmethod sheet-beep ((x sheet)) (port-beep (port x) x)) -(defun get-drawing-function-description (name) - (or (get name 'args) - (error "Cannot find description for: ~S" name))) - -(defmacro define-port-graphics-method ((name port-class) &body body) - (destructuring-bind (args &rest ignore) - (get-drawing-function-description name) - (declare (ignore ignore)) - `(defmethod ,(intern (format nil "~A~A*" 'port- name)) - ((port ,port-class) ,@args) - ,@body))) - -;;--- Remove this when the time comes... -(defun clim-internals::draw-line-internal - (stream xoff yoff x1 y1 x2 y2 ink style) - (letf-globally (((medium-line-style stream) - (or style (medium-line-style stream))) - ((medium-transformation stream) +identity-transformation+)) - (draw-line* stream - (+ x1 xoff) (+ y1 yoff) - (+ x2 xoff) (+ y2 yoff) - :ink ink))) - -;;--- Remove this when the time comes... -(defun clim-internals::draw-rectangle-internal - (stream xoff yoff left top right bottom ink style) - (letf-globally (((medium-line-style stream) - (or style (medium-line-style stream))) - ((medium-transformation stream) +identity-transformation+)) - (draw-rectangle* stream - (+ left xoff) (+ top yoff) - (+ right xoff) (+ bottom yoff) - :filled (not style) :ink ink))) - -;;--- Remove this when the time comes... -(defun clim-internals::draw-ellipse-internal - (stream xoff yoff center-x center-y - radius-1-dx radius-1-dy radius-2-dx radius-2-dy - start-angle end-angle ink style) - (letf-globally (((medium-line-style stream) - (or style (medium-line-style stream))) - ((medium-transformation stream) +identity-transformation+)) - (draw-ellipse* stream - (+ center-x xoff) (+ center-y yoff) - radius-1-dx radius-1-dy radius-2-dx radius-2-dy - :start-angle start-angle :end-angle end-angle - :filled (not style) :ink ink))) - (defmethod copy-area (sheet from-left from-top from-right from-bottom to-left to-top) diff --git a/silica/layout.lisp b/silica/layout.lisp index ae6402ad..e1ef353d 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: layout.lisp,v 1.16 92/05/07 13:11:22 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.17 92/05/12 18:24:30 cer Exp Locker: cer $ (in-package :silica) @@ -92,13 +92,13 @@ ;(defmethod allocate-space (sheet width height) ; (declare (ignore sheet width height))) - (defun parse-box-contents (contents) (mapcar #'(lambda (x) + ;; Handle top-down layout syntax (if (and (consp x) - (typep (car x) '(or (member :fill) number))) - `(list ,(car x) ,(second x)) - x)) + (typep (first x) '(or (member :fill) number))) + `(list ,(first x) ,(second x)) + x)) contents)) (defmacro vertically (options &body contents) @@ -112,9 +112,10 @@ :contents (list ,@(parse-box-contents contents)) ,@options)) + (defmethod resize-sheet* ((sheet sheet) width height) (unless (and (> width 0) (> height 0)) - (error "Trying to resize sheet to zero ~S,~S,~S" + (error "Trying to resize sheet ~S to be too small (~D x ~D)" sheet width height)) (when (or width height) (with-bounding-rectangle* (minx miny maxx maxy) sheet @@ -131,10 +132,6 @@ ;;-- I guess we do not want to do this always but ... (allocate-space sheet owidth oheight)))))) -(defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) - (resize-sheet* sheet width height) - (move-sheet* sheet minx miny)) - (defmethod move-sheet* ((sheet sheet) minx miny) (let ((trans (sheet-transformation sheet))) (multiple-value-bind (x y) @@ -147,6 +144,10 @@ (if minx (- minx x) 0) (if miny (- miny y) 0))))))) +(defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) + (resize-sheet* sheet width height) + (move-sheet* sheet minx miny)) + ;; Various @@ -318,14 +319,14 @@ (defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port) (if port - ;; We do this because if the wm has resized us then we want to - ;; do the complete layout-frame thing including clearing caches + ;; We do this because if the WM has resized us then we want to + ;; do the complete LAYOUT-FRAME thing including clearing caches ;; etc etc. (multiple-value-call #'layout-frame (pane-frame pane) (bounding-rectangle-size pane)) - ;; Otherwise just call allocate-space etc - (call-next-method))) + ;; Otherwise just call ALLOCATE-SPACE etc + (call-next-method))) #+++ignore (defmethod allocate-space ((sheet top-level-sheet) width height) diff --git a/silica/medium.lisp b/silica/medium.lisp index 89e6c080..6a1fc9ef 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: medium.lisp,v 1.11 92/05/13 17:10:37 cer Exp Locker: cer $ +;; $fiHeader: medium.lisp,v 1.12 92/05/14 11:03:46 cer Exp Locker: cer $ (in-package :silica) @@ -236,7 +236,8 @@ merged-text-style merged-text-style-valid) medium (if merged-text-style-valid merged-text-style - (prog1 (setf merged-text-style (merge-text-styles text-style default-text-style)) + (prog1 + (setf merged-text-style (merge-text-styles text-style default-text-style)) (setf merged-text-style-valid t))))) (defmacro with-text-style ((stream style) &body body) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 1c685788..d24ed726 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.17 92/05/07 13:11:26 cer Exp Locker: cer $ +;; $fiHeader: mirror.lisp,v 1.18 92/05/12 18:24:33 cer Exp Locker: cer $ (in-package :silica) @@ -44,9 +44,9 @@ (defgeneric enable-mirror (port sheet)) (defgeneric disable-mirror (port sheet)) - (defmethod sheet-direct-mirror ((sheet sheet)) nil) + (defclass mirrored-sheet-mixin () ((mirror :initform nil :accessor sheet-direct-mirror) (native-transformation :initform +identity-transformation+ @@ -68,9 +68,9 @@ (defmethod sheet-device-transformation ((sheet sheet)) (or (sheet-cached-device-transformation sheet) (setf (sheet-cached-device-transformation sheet) - (compose-transformations - (sheet-transformation sheet) - (sheet-device-transformation (sheet-parent sheet)))))) + (compose-transformations + (sheet-transformation sheet) + (sheet-device-transformation (sheet-parent sheet)))))) (defmethod sheet-device-transformation :around ((sheet mirrored-sheet-mixin)) (if (sheet-direct-mirror sheet) @@ -97,16 +97,14 @@ (sheet-native-region sheet)) ;;--- This assumes that sheet siblings do not overlap... - (defmethod sheet-device-region ((sheet sheet)) (or (sheet-cached-device-region sheet) (setf (sheet-cached-device-region sheet) - (region-intersection - (transform-region - (sheet-device-transformation sheet) - (sheet-region sheet)) - (sheet-device-region (sheet-parent sheet)))))) - + (region-intersection + (transform-region + (sheet-device-transformation sheet) + (sheet-region sheet)) + (sheet-device-region (sheet-parent sheet)))))) ;;;; Mirror region stuff @@ -162,14 +160,12 @@ (setf (sheet-direct-mirror sheet) (call-next-method))))) (setf (gethash mirror (port-mirror->sheet-table port)) sheet) - ;;--- What is the right thing do here. - ;;--- In the motif port we note specify the width and height of - ;;--- widgets when we make them. We rely on the layout protocol - - ;;--- ??? to take care of all of that, ie. to go in and change - ;;--- the size - #+ignore - (update-mirror-transformation port sheet) - (setf (sheet-native-transformation sheet) +identity-transformation+) + ;;--- What is the right thing do here? + ;;--- In the Motif port we note specify the width and height of + ;;--- widgets when we make them. We rely on the layout protocol + ;;--- to take care of all of that, ie. to go in and change the size + #+++ignore (update-mirror-transformation port sheet) + #---ignore (setf (sheet-native-transformation sheet) +identity-transformation+) mirror)) (defmethod destroy-mirror :around ((port port) (sheet mirrored-sheet-mixin)) diff --git a/silica/port.lisp b/silica/port.lisp index 44ef5c83..3e6e69e2 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: port.lisp,v 1.11 92/05/06 15:37:22 cer Exp Locker: cer $ +;; $fiHeader: port.lisp,v 1.12 92/05/07 13:11:29 cer Exp $ (in-package :silica) @@ -52,7 +52,6 @@ (:method (x) (error "Cannot find port type: ~S" x))) -(defmethod port ((x t)) nil) (defmethod initialize-instance :around ((port port) &key server-path) (setf (slot-value port 'server-path) (copy-list server-path)) @@ -62,13 +61,9 @@ (defgeneric port (x) - ;;;-- Do we need this??? - #+ignore (:method ((port port)) port) - #+ignore (:method ((object t)) nil)) - (defgeneric port-properties (port)) (defgeneric (setf port-properties) (properties port)) diff --git a/silica/protocols.lisp b/silica/protocols.lisp index 10ce206c..e8890bc3 100644 --- a/silica/protocols.lisp +++ b/silica/protocols.lisp @@ -21,9 +21,9 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader$ +;; $fiHeader: protocols.lisp,v 1.2 92/01/02 15:09:22 cer Exp Locker: cer $ -(in-package "CLIM-UTILS") +(in-package :clim-utils) ;;; ;;; Protocol Stuff (should be moved to a utils package) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index c757c0c8..8a91f25e 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: sheet.lisp,v 1.13 92/05/12 18:24:36 cer Exp Locker: cer $ +;; $fiHeader: sheet.lisp,v 1.14 92/05/14 11:03:48 cer Exp Locker: cer $ (in-package :silica) @@ -29,7 +29,7 @@ (defgeneric sheet-child (sheet)) (defgeneric sheet-enabled-children (sheet)) (defgeneric sheet-siblings (sheet)) -(defgeneric sheet-ancestor-p (sheet)) +(defgeneric sheet-ancestor-p (sheet putative-ancestor)) (defgeneric sheet-adopt-child (sheet child)) (defgeneric sheet-disown-child (sheet child)) @@ -118,7 +118,7 @@ (error "~S is not child of ~S" child parent)) (setf (sheet-parent child) nil) (setf (sheet-children parent) - (delete child (sheet-children parent))) + (remove child (sheet-children parent))) (note-sheet-disowned child) (when (port parent) (setf (port child) nil))) @@ -265,28 +265,28 @@ (declare (ignore port-did-it)) nil)) -(defgeneric invalidate-cached-transformations (sheet) - (:method ((sheet sheet)) - (setf (sheet-cached-device-region sheet) nil) - (setf (sheet-cached-device-transformation sheet) nil)) - (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-transformations (sheet-children sheet)))) - (defgeneric invalidate-cached-regions (sheet) (:method ((sheet sheet)) (setf (sheet-cached-device-region sheet) nil)) (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-regions (sheet-children sheet)))) + (mapc #'invalidate-cached-regions (sheet-children sheet)))) (defmethod note-sheet-region-changed :before ((sheet sheet) &key port-did-it) (declare (ignore port-did-it)) (invalidate-cached-regions sheet)) +(defgeneric invalidate-cached-transformations (sheet) + (:method ((sheet sheet)) + (setf (sheet-cached-device-region sheet) nil) + (setf (sheet-cached-device-transformation sheet) nil)) + (:method :after ((sheet sheet-parent-mixin)) + (mapc #'invalidate-cached-transformations (sheet-children sheet)))) + ;;--- Check to see if the call to invalidate-cached-regions is really necessary. ;;--- CER thinks we do because regions depend on transformations. (defmethod note-sheet-transformation-changed :before ((sheet sheet) &key port-did-it) - (declare (ignore port-did-it)) + (declare (ignore port-did-it)) (invalidate-cached-transformations sheet) (invalidate-cached-regions sheet)) @@ -328,7 +328,12 @@ (defclass permanent-medium-sheet-output-mixin (sheet-with-medium-mixin) ()) -(defmethod note-sheet-grafted :after ((sheet permanent-medium-sheet-output-mixin)) + +(defmethod note-sheet-grafted :around ((sheet permanent-medium-sheet-output-mixin)) + ;; By making this an around we make sure that the mirror has been + ;; realized at this point, if its a mirror sheet. This is pretty + ;; horrible but it makes sure that things happen in the right order. + (call-next-method) (when (sheet-medium-type sheet) (setf (sheet-medium sheet) (make-medium (port sheet) sheet)) diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp index e857622e..faaaa88f 100644 --- a/sys/defsystem.lisp +++ b/sys/defsystem.lisp @@ -27,7 +27,7 @@ ;;; ;;;----------------------------------------------------------- -;; $fiHeader: defsystem.lisp,v 1.9 92/04/15 11:47:35 cer Exp $ +;; $fiHeader: defsystem.lisp,v 1.10 92/05/07 13:13:12 cer Exp $ ;; 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. @@ -46,9 +46,9 @@ (pushnew :ansi-90 *features*)))) #+ANSI-90 -(defpackage "CLIM-DEFSYSTEM" - (:use "COMMON-LISP") - (:nicknames "CLIM-DEFSYS" "CLIM-DS") +(defpackage :clim-defsystem + (:use :common-lisp) + (:nicknames :clim-defsys :clim-ds) (:export *current-system* *defsystem-version* @@ -70,16 +70,16 @@ (in-package :clim-defsystem) #+(or Genera-Release-8-0 Genera-Release-8-1) -(lisp:in-package "CLIM-DEFSYSTEM" - :use '("LISP") - :nicknames '("CLIM-DEFSYS")) +(lisp:in-package :clim-defsystem + :use '(:lisp) + :nicknames '(:clim-defsys)) #-(or ANSI-90 Genera-Release-8-0 Genera-Release-8-1) -(lisp:in-package #-(or lispworks ANSI-90) "CLIM-DEFSYSTEM" - #+lispworks "PDEFSYS" - #+ANSI-90 "CLIM-DEFSYSTEM" - #-ANSI-90 :use #-ANSI-90 '("LISP") - #-ANSI-90 :nicknames #-ANSI-90 '("CLIM-DEFSYS")) +(lisp:in-package #-(or lispworks ANSI-90) :clim-defsystem + #+lispworks :pdefsys + #+ANSI-90 :clim-defsystem + #-ANSI-90 :use #-ANSI-90 '(:lisp) + #-ANSI-90 :nicknames #-ANSI-90 '(:clim-defsys)) #-ANSI-90 (export '(*current-system* @@ -97,7 +97,7 @@ undefsystem with-compiler-options with-delayed-compiler-warnings) - "CLIM-DEFSYSTEM") + :clim-defsystem) ;;; *** A temporary workaround, easier than fixing all references to ;;; *** LISP:<foo>. --RWK 20.Nov.90 @@ -109,13 +109,15 @@ (assert (not (null pack)) () "Attempting to add the name ~S to package ~S, which doesn't exist") (when (null (find-package add-name)) - (rename-package pack (package-name pack) - (list* add-name (package-nicknames pack))))))) - (fix-package "COMMON-LISP" "LISP") - (fix-package "COMMON-LISP" "CL") ;; ?? - (fix-package "COMMON-LISP-USER" "USER") - (fix-package "COMMON-LISP-USER" "CL-USER")) ;; ?? - (when (null (find-package "SYSTEM")) + (let (#+Allegro (excl::*enable-package-locked-errors* nil)) + (rename-package + pack (package-name pack) + (list* add-name (package-nicknames pack)))))))) + (fix-package :common-lisp :lisp) + (fix-package :common-lisp :cl) ;; ?? + (fix-package :common-lisp-user :user) + (fix-package :common-lisp-user :cl-user)) ;; ?? + (when (null (find-package :system)) (defpackage system))) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index f2c8ade4..fb43797a 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,8 +1,8 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.15 92/05/07 13:13:14 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.16 92/05/13 17:10:57 cer Exp Locker: cer $ -(in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." @@ -10,7 +10,7 @@ ;;; Tell the world that we're here ;;;--- These need to be in the CLIM.fasl also. -;;;--- Currently they're in excl-verification but that does not seem the best place. +;;;--- Currently they're in EXCL-VERIFICATION but that does not seem the best place. (pushnew :clim *features*) (pushnew :clim-2 *features*) (pushnew :clim-2.0 *features*) @@ -143,9 +143,10 @@ ;; Establish a uniform stream model ("clim-streams") - ("cl-stream-classes" :features (not clim-uses-lisp-stream-classes)) + (#-Cloe-Runtime "cl-stream-classes" #+Cloe-Runtime "clstrcla" + :features (not clim-uses-lisp-stream-classes)) ("minima-stream-classes" :features Minima) - ("cl-stream-functions" + (#-Cloe-Runtime "cl-stream-functions" #+Cloe-Runtime "clstrfun" :features (and (not clim-uses-lisp-stream-functions) (not Lucid))) ("lucid-stream-functions" :features Lucid) ("genera-streams" :features Genera) @@ -240,8 +241,6 @@ ("input-defs") ("input-protocol") ("output-protocol") - ("drawing-state-mixin" :features (not Silica)) - ("window-protocol" :features (not Silica)) ;; Output recording ("recording-defs" @@ -251,25 +250,18 @@ ("text-recording" :load-before-compile ("recording-protocol")) ("graphics-recording" - :load-before-compile ("recording-protocol") :features Silica) + :load-before-compile ("recording-protocol")) ;; Input editing (#-Cloe-Runtime "interactive-protocol" #+Cloe-Runtime "int-prot" :load-before-compile ("clim-defs")) ("input-editor-commands") - (#-Cloe-Runtime "protocol-intermediaries" #+Cloe-Runtime "prot-int" - :features (not Silica)) - ;; Formatted output definitions ("formatted-output-defs") ("incremental-redisplay" :load-before-compile ("clim-defs" "recording-protocol")) - ;; Graphics - ("defs-graphics-generics" :features (not Silica)) - (#-Cloe-Runtime "graphics-generics" #+Cloe-Runtime "gph-gene" :features (not Silica)) - ;; Windows ("coordinate-sorted-set") ("window-stream") @@ -277,7 +269,8 @@ ;; Presentation types ("ptypes1" :load-before-compile ("clim-defs")) - ("completer") + ("completer" + :load-before-compile ("ptypes1")) ("presentations" :load-before-compile ("ptypes1")) ("translators" @@ -302,47 +295,14 @@ ("text-formatting" :load-before-compile ("clim-defs" "incremental-redisplay")) - (#-Cloe-Runtime "graphics-internals" #+Cloe-Runtime "gph-inte" :features (not Silica)) - ;; Pointer tracking ("tracking-pointer") ("dragging-output" :load-before-compile ("tracking-pointer")) - ("vertical-string" :features (not Silica)) - - ;; CLX - ("clx-implementation" :features (and (not Silica) Xlib)) - - ;; Genera - ("genera-implementation" :features (and (not Silica) Genera)) - - ;; MCL - ;("coral-scroll" :features (and (not Silica) CCL-2)) - ;("coral-implementation" :features (and (not Silica) CCL-2)) - ;("coral-fonts" :features (and (not Silica) CCL-2)) - ;("coral-font-stuff" :features (and (not Silica) CCL-2)) - ;("coral-events" :features (and (not Silica) CCL-2)) - ;("coral-streams" :features (and (not Silica) CCL-2)) - - ;; CLOE - ;("wheader" :features (and (not Silica) Cloe-Runtime)) - ;("windows" :features (and (not Silica) Cloe-Runtime) - ; :load-before-compile ("wheader")) - ;("cloe-implementation" :features (and (not Silica) Cloe-Runtime) - ; :load-before-compile ("windows")) - ;("cloe-events" :features (and (not Silica) Cloe-Runtime) - ; :load-before-compile ("windows" "cloe-implementation")) - ;("cloe-applications" :features (and (not Silica) Cloe-Runtime)) - - ;; Postscript - ;("postscript-implementation" :features (not Silica)) - ;("laserwriter-metrics" :features (not Silica) - ; :load-before-compile ("postscript-implementation")) - ;; Gadgets - ("db-stream" :features Silica) - ("gadget-output" :features Silica) + ("db-stream") + ("gadget-output") ;; Application building substrate ("accept" @@ -355,19 +315,16 @@ :load-before-compile ("clim-defs" "command")) ("basic-translators" :load-before-compile ("ptypes2" "command")) - ("define-application" - :load-before-compile ("clim-defs" "command-processor") :features (not Silica)) - ("default-application" - :load-before-compile ("define-application") :features (not Silica)) ("frames" - :load-before-compile ("clim-defs" "command-processor") :features Silica) + :load-before-compile ("clim-defs" "command-processor")) + ("noting-progress" + :load-before-compile ("frames")) ("menus" :load-before-compile ("defresource" "clim-defs")) - ;("mac-menus" - ; :features (and (not Silica) CCL-2) :load-before-compile ("menus")) ("accept-values" - :load-before-compile ("clim-defs" "incremental-redisplay" - #-Silica "define-application" #+Silica "frames")) + :load-before-compile ("clim-defs" "incremental-redisplay" "frames")) + ("drag-and-drop" + :load-before-compile ("frames")) ("pixmap-streams" :load-before-compile ("clim-defs")) ("item-list-manager") @@ -376,10 +333,10 @@ ("stream-trampolines" :load-before-compile ("defprotocol" "stream-defprotocols")) ("lucid-after" :features lucid) - ("prefill" :features (and (not Silica) (or Genera Cloe-Runtime)))) + ("prefill" :features (or Genera Cloe-Runtime))) -#+(and Silica Genera) +#+Genera (clim-defsys:defsystem genera-clim (:default-pathname "SYS:CLIM;REL-2;GENERA;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;GENERA;" @@ -393,7 +350,7 @@ ("genera-gadgets") ("genera-activities")) -#+(and Silica CLX use-CLX) +#+(and CLX use-CLX) (clim-defsys:defsystem clx-clim (:default-pathname "SYS:CLIM;REL-2;CLX;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLX;" @@ -407,7 +364,7 @@ ("clx-gadgets")) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem xlib (:default-pathname (frob-pathname "xlib") :default-binary-pathname (frob-pathname "xlib") @@ -423,7 +380,7 @@ ("x11-keysyms" :load-before-compile ("ffi")) ("last" :load-before-compile ("load-xlib" "xlib-funs"))) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem xt-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") @@ -451,17 +408,17 @@ ("xt-classes") ("xt-init")) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem xm-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") :needed-systems (xt-tk) :load-before-compile (xt-tk)) ;; Motif specific stuff + ("load-xm") ("xm-defs") ("xm-classes") ("xm-callbacks") - ("load-xm") ("xt-funs") ;;--- This is really in tk but because of the loading ("xm-funs") ("xm-classes") @@ -470,12 +427,9 @@ ("xm-font-list") ("xm-protocols") ("convenience") - #+ignore ("examples") - - ;; More General stuff ("make-widget")) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem ol-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") @@ -483,16 +437,16 @@ :load-before-compile (xt-tk)) ;; OpenLook specific stuff ("ol-defs") - ("ol-classes") ("load-ol") ("xt-funs") ;;--- This is really in tk but because of the loading ("ol-funs") + ("ol-classes") ("ol-init") + ("ol-widgets") ("ol-callbacks") - #+ignore("ol-examples") ("make-widget")) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem motif-clim (:default-pathname (frob-pathname "tk-silica") :default-binary-pathname (frob-pathname "tk-silica") @@ -512,7 +466,7 @@ ("xt-cursor") ("xt-pixmaps")) -#+(and Silica Allegro) +#+Allegro (clim-defsys:defsystem openlook-clim (:default-pathname (frob-pathname "tk-silica") :default-binary-pathname (frob-pathname "tk-silica") @@ -531,7 +485,7 @@ ("xt-pixmaps")) -#+(and Silica CCL-2) +#+CCL-2 (clim-defsys:defsystem ccl-clim (:default-pathname "SYS:CLIM;REL-2;CCL;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CCL;" @@ -546,7 +500,7 @@ ("ccl-menus")) -#+(and Silica Cloe-Runtime) +#+Cloe-Runtime (clim-defsys:defsystem cloe-clim (:default-pathname "SYS:CLIM;REL-2;CLOE;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLOE;" @@ -563,7 +517,7 @@ ("cloe-menus")) -#+(and Silica use-PostScript) +#+use-PostScript (clim-defsys:defsystem postscript-clim (:default-pathname "SYS:CLIM;REL-2;POSTSCRIPT;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;" @@ -592,12 +546,10 @@ :pretty-name "CLIM Standalone" :default-pathname "SYS:CLIM;REL-2;CLIM;") -#+Silica (clim-defsys:import-into-sct 'genera-clim :subsystem t :pretty-name "Genera CLIM" :default-pathname "SYS:CLIM;REL-2;GENERA;") -#+Silica (clim-defsys:import-into-sct 'clx-clim :subsystem t :pretty-name "CLX CLIM" :default-pathname "SYS:CLIM;REL-2;CLX;") @@ -614,20 +566,20 @@ (:serial "clim-utils" "clim-silica" "clim-standalone" - #+Silica "genera-clim" - #+Silica "clx-clim")) + "genera-clim" + "clx-clim")) -#+(and Silica ignore) +#+++ignore (clim-defsys:import-into-sct 'motif-clim :subsystem t :pretty-name "Motif CLIM" :default-pathname "SYS:CLIM;REL-2;TK-SILICA;") -#+(and Silica ignore) +#+++ignore (clim-defsys:import-into-sct 'openlook-clim :subsystem t :pretty-name "OpenLook CLIM" :default-pathname "SYS:CLIM;REL-2;TK-SILICA;") -#+(and Silica ignore) +#+++ignore (sct:defsystem clim-tags-table (:pretty-name "CLIM Tags Table" :default-pathname "SYS:CLIM;REL-2;CLIM;" @@ -655,7 +607,6 @@ :sct-name :minima-clim-standalone :pretty-name "Minima CLIM Standalone" :default-pathname "SYS:CLIM;REL-2;CLIM;") -#+Silica (clim-defsys:import-into-sct 'clx-clim :subsystem t :sct-name :minima-clx-clim :pretty-name "CLX CLIM" :default-pathname "SYS:CLIM;REL-2;CLX;") @@ -673,7 +624,7 @@ (:serial "minima-clim-utils" "minima-clim-silica" "minima-clim-standalone" - #+Silica "minima-clx-clim")) + "minima-clx-clim")) ) diff --git a/test/chess.lisp b/test/chess.lisp index c0d4b278..e710483c 100644 --- a/test/chess.lisp +++ b/test/chess.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: clim -*- +;; -*- mode: common-lisp; package: clim-user -*- ;; ;; -[]- ;; @@ -20,10 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: chess.lisp,v 1.4 92/04/10 14:27:15 cer Exp $ +;; $fiHeader: chess.lisp,v 1.5 92/05/07 13:13:16 cer Exp Locker: cer $ -(in-package :clim) +(in-package :clim-user) (define-application-frame chess-board () ((board :initform (make-array '(8 8) @@ -32,26 +32,44 @@ (bitmaps :initform nil :allocation :class) (subprocess :initform (create-chess-subprocess))) (:command-table chess-commands) - (:pane - (scrolling () - (make-pane 'application-pane - :incremental-redisplay t - :display-function 'draw-chess-board)))) + (:panes + (board :application + :incremental-redisplay t + :scroll-bars :dynamic + :width :compute :height :compute + :max-width :compute :max-height :compute + :display-function 'draw-chess-board)) + (:layouts + (:default board))) (define-presentation-type chess-square ()) -(define-command (com-do-nothing :command-table chess-commands :menu t) () +(define-presentation-method highlight-presentation ((type chess-square) record stream state) + state + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent record)) + (with-bounding-rectangle* (left top right bottom) record + (draw-rectangle* stream + (- (+ left xoff) 2) (- (+ top yoff) 2) + (+ right xoff 2) (+ bottom yoff 2) + :line-thickness 2 + :filled nil + :ink +flipping-ink+)))) + +(define-chess-board-command (com-do-nothing :menu t) () nil) -(define-command (com-reset :command-table chess-commands :menu t) () +(define-chess-board-command (com-reset :menu t) () (with-slots (board subprocess) *application-frame* (send-command subprocess "new") (setf board (make-array '(8 8) :initial-contents - (make-chess-board-initial-state))))) + (make-chess-board-initial-state))) + (window-clear *standard-output*))) -(define-command com-move-piece +(define-chess-board-command com-move-piece ((from 'chess-square) (to 'chess-square)) (with-slots (subprocess board) *application-frame* @@ -93,7 +111,7 @@ (destructuring-bind (row col) x (coerce (list - (int-char (+ (char-int #\a) col)) + (cltl1::int-char (+ (char-int #\a) col)) (digit-char (- 8 row))) 'cltl1::string))) @@ -106,36 +124,26 @@ com-move-piece chess-commands) (object) - (list object *unsupplied-argument*)) + (list object *unsupplied-argument-marker*)) -(defmethod draw-chess-board (frame stream) - (stream-set-cursor-position* stream 0 0) - (updating-output - (stream) - (formatting-table - (stream) - (dotimes (row 8) - (formatting-row - (stream) - (dotimes (column 8) - (formatting-cell - (stream) - (let ((x (aref (slot-value frame 'board) row column))) - (updating-output - (stream - :unique-id (list row column) - :id-test #'equal - :cache-value x - :cache-test #'equal) - (with-output-as-presentation ( - :object (list row column) - :type 'chess-square - :stream stream) - (draw-piece frame - stream - (second x) - (car x) - (oddp (+ row column))))))))))))) +(defmethod draw-chess-board (frame stream &key &allow-other-keys) + (formatting-table (stream) + (dotimes (row 8) + (formatting-row (stream) + (dotimes (column 8) + (formatting-cell (stream) + (let ((x (aref (slot-value frame 'board) row column))) + (updating-output (stream + :unique-id (list row column) + :id-test #'equal + :cache-value x + :cache-test #'equal) + (with-output-as-presentation (stream (list row column) 'chess-square) + (draw-piece frame + stream + (second x) + (car x) + (oddp (+ row column)))))))))))) (defmethod draw-piece (frame stream (which (eql nil)) color square) (draw-rectangle* stream 0 0 80 80 @@ -161,11 +169,6 @@ (draw-rectangle* stream 0 0 80 80 :ink ink))) - -#+ignore -(draw-rectangle* stream 0 0 80 80 :ink pattern) - - (defun make-chess-board-initial-state () (labels ((define-pieces (color) (ecase color @@ -187,7 +190,6 @@ (make-list 4 :initial-element (make-list 8)) (define-pieces :white)))) - (defun create-chess-subprocess () (multiple-value-bind (stream something pid) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 341af84d..ed6bbfdc 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.19 92/05/07 13:13:18 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.20 92/05/13 17:10:59 cer Exp Locker: cer $ (in-package :clim-user) @@ -1247,7 +1247,6 @@ Luke Luck licks the lakes Luke's duck likes.")) (decf bottom yoff)) (draw-rectangle* stream left top right bottom :filled nil :ink +cyan+)))) - (define-table-cell-test set-cursor-position "move the cursor, output some text" (stream-set-cursor-position stream 50 50) (write-string ">Wally<" stream)) @@ -2696,17 +2695,17 @@ Luke Luck licks the lakes Luke's duck likes.")) ("Exit" :command (exit-clim-tests))))) (:command-definer nil) (:panes - (caption-pane - (outlining () - (scrolling () - (make-pane 'application-pane :height 50)))) - (display-pane - (outlining () - (scrolling () - (make-pane 'application-pane))))) - (:layout - (:default - (vertically () caption-pane display-pane)))) + (caption-pane + (outlining () + (scrolling () + (make-pane 'application-pane :height 50)))) + (display-pane + (outlining () + (scrolling () + (make-pane 'application-pane))))) + (:layouts + (:default + (vertically () caption-pane display-pane)))) (defmethod frame-standard-output ((frame clim-tests)) (get-frame-pane frame 'display-pane)) diff --git a/test/test.lisp b/test/test.lisp index 31e54da3..c490c13e 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.25 92/05/07 13:13:22 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.26 92/05/12 18:25:07 cer Exp Locker: cer $ (in-package :clim-user) @@ -52,12 +52,12 @@ (make-pane 'interactor-pane))) (:icon :name "foo" :pixmap (make-pattern - (let ((x (make-array '(48 48)))) - (dotimes (i 48) - (dotimes (j 48) - (setf (aref x i j) (random 2)))) - x) - (list +red+ +green+))) + (let ((x (make-array '(48 48)))) + (dotimes (i 48) + (dotimes (j 48) + (setf (aref x i j) (random 2)))) + x) + (list +red+ +green+))) (:geometry :width 300 :height 300)) @@ -113,8 +113,7 @@ () (window-clear *query-io*)) -(define-test-frame-command (com-quit :name t - :menu ("Quit" :documentation "foo")) +(define-test-frame-command (com-quit :name t :menu ("Quit" :documentation "Word")) () (frame-exit *application-frame*)) @@ -162,7 +161,7 @@ (e :interactor :width 300 :max-width +fill+ :height 300 :max-height +fill+)) - (:layout + (:layouts (:default (vertically () a b c e)) @@ -227,28 +226,47 @@ (write-string "gadget" stream)) (define-test-frame-command (com-make-one :name t :menu t) - () + ((what '(subset :slider :push-button :interactor :radio-box))) (let* ((stream *query-io*)) - (let ((weird (cons nil nil))) - (setf (car weird) - (with-output-as-presentation (stream weird 'some-kinda-gadget) - (surrounding-output-with-border (stream) - (with-output-as-gadget (stream) - (make-pane 'slider)))))) - (let ((weird (cons nil nil))) - (setf (car weird) - (with-output-as-presentation (stream weird 'some-kinda-gadget) - (surrounding-output-with-border (stream) - (with-output-as-gadget (stream) - (make-pane 'push-button - :label "Amazing")))))) - (let ((weird (cons nil nil))) - (setf (car weird) - (with-output-as-presentation (stream weird 'some-kinda-gadget) - (surrounding-output-with-border (stream) - (with-output-as-gadget (stream) - (scrolling () - (make-pane 'interactor-pane))))))))) + (when (member :slider what) + (let ((weird (cons nil nil))) + (setf (car weird) + (with-output-as-presentation (stream weird 'some-kinda-gadget) + (surrounding-output-with-border (stream) + (with-output-as-gadget (stream) + (make-pane 'slider))))))) + + (when (member :push-button what) + (let ((weird (cons nil nil))) + (setf (car weird) + (with-output-as-presentation (stream weird 'some-kinda-gadget) + (surrounding-output-with-border (stream) + (with-output-as-gadget (stream) + (make-pane 'push-button + :label "Amazing"))))))) + (when (member :interactor what) + (let ((weird (cons nil nil))) + (setf (car weird) + (with-output-as-presentation (stream weird 'some-kinda-gadget) + (surrounding-output-with-border (stream) + (with-output-as-gadget (stream) + (scrolling () + (make-pane + 'interactor-pane)))))))) + (when (member :radio-box what) + (let ((weird (cons nil nil))) + (setf (car weird) + (with-output-as-presentation (stream weird 'some-kinda-gadget) + (surrounding-output-with-border (stream) + (with-output-as-gadget + (stream) + (let ((gadget (make-pane 'radio-box))) + (dolist (x '(a b c) gadget) + (make-pane + 'toggle-button + :parent gadget + :label (string x)))))))))) + )) (define-test-frame-command (com-move-gadget :name t :menu t) ((weird 'some-kinda-gadget)) @@ -353,15 +371,15 @@ (defun slider-dragged-callback (slider value) (format t "~&Slider ~A dragged to ~S" (gadget-label slider) value)) - -(defun text-field-changed (tf value) - (format t "~&Text field ~A changed to ~S" tf value)) - (defun option-pane-changed-callback (tf value) - (format t "~&option menu ~A changed to ~S" tf value)) + (format t "~&Option menu ~A changed to ~S" tf value)) (defun list-pane-changed-callback (tf value) - (format t "~&list pane ~A changed to ~S" tf value)) + (format t "~&List pane ~A changed to ~S" tf value)) + + +(defun text-field-changed (tf value) + (format t "~&Text field ~A changed to ~S" tf value)) (defclass insect () ()) @@ -478,190 +496,166 @@ :value-changed-callback 'slider-changed-callback :drag-callback 'slider-dragged-callback)))))) - (define-application-frame tf988 () () - (:command-table test-frame) - (:pane - (outlining () - (horizontally () - (scrolling () - (make-pane 'text-editor - :value "lucid " - :value-changed-callback 'text-field-changed - :ncolumns 30 - :nlines 10)) - (scrolling () - (make-pane 'text-editor - :value "harlqn more" - :value-changed-callback 'text-field-changed - :ncolumns 30 - :nlines 10)))))) - - -(define-application-frame tf97 - () () - (:command-table test-frame) - (:pane - (vertically () - (horizontally () - (scrolling () - (make-pane - 'list-pane - :value "Franz" - :test 'string= - :value-changed-callback - 'list-pane-changed-callback - :items '("Franz" "Lucid" - "Harlqn" - "Symbolics"))) - :fill - (scrolling () - (make-pane - 'list-pane - :value '("Lisp" "C") - :test 'string= - :mode :nonexclusive - :value-changed-callback - 'list-pane-changed-callback - :items '("C" "Cobol" "Lisp" "Ada")))) - (make-pane 'option-pane - :items '("eenie" "meanie" "minie") - :value "minie" - :value-changed-callback - 'option-pane-changed-callback - :test 'string= - :label "moo") - (outlining () - (scrolling () - (make-pane 'text-editor - :value - "lucid are nice guys " - :value-changed-callback 'text-field-changed - :ncolumns 30 - :nlines 10)))))) - -(define-application-frame tf96 - () () - (:command-table test-frame) - (:panes - (a :application :width '(80 :character)) - (b :application :width '(50 :mm)) - (c :application :height '(10 :line)) - (d :application :height '(5 :line)) - (e :application :height '( 50 :mm))) - (:layout - (:default (vertically () - (horizontally () a b) - (vertically () c d e))))) - - - -(define-test-frame-command (com-frob-sizes :name t :menu t) - () + (:command-table test-frame) + (:pane + (outlining () + (horizontally () + (scrolling () + (make-pane 'text-editor + :value "lucid " + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)) + (scrolling () + (make-pane 'text-editor + :value "harlqn more" + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)))))) + +(define-application-frame tf97 () () + (:command-table test-frame) + (:pane + (vertically () + (horizontally () + (scrolling () + (make-pane 'list-pane + :value "Franz" + :test 'string= + :value-changed-callback 'list-pane-changed-callback + :items '("Franz" "Lucid" "Harlqn" "Symbolics"))) + :fill + (scrolling () + (make-pane 'list-pane + :value '("Lisp" "C") + :test 'string= + :mode :nonexclusive + :value-changed-callback 'list-pane-changed-callback + :items '("C" "Cobol" "Lisp" "Ada")))) + (make-pane 'option-pane + :items '("eenie" "meanie" "minie") + :value "minie" + :value-changed-callback 'option-pane-changed-callback + :test 'string= + :label "moo") + (outlining () + (scrolling () + (make-pane 'text-editor + :value "lucid are nice guys " + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)))))) + +(define-application-frame tf96 () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application :width '(50 :mm)) + (c :application :height '(10 :line)) + (d :application :height '(5 :line)) + (e :application :height '( 50 :mm))) + (:layouts + (:default + (vertically () + (horizontally () a b) + (vertically () c d e))))) + +(define-test-frame-command (com-frob-sizes :name t :menu t) () (changing-space-requirements () - (change-space-requirements - (get-frame-pane *application-frame* 'a) - :resize-frame t - :width `(,(random 60) :character)) - (change-space-requirements - (get-frame-pane *application-frame* 'b) - :resize-frame t - :width `(,(random 60) :character)) - (change-space-requirements - (get-frame-pane *application-frame* 'd) - :resize-frame t - :height `(,(random 10) :line)))) - -(define-application-frame tf95 - () () - (:command-table test-frame) - (:panes - (a :application :width '(80 :character)) - (b :application :width '(50 :mm)) - (c :application :height '(10 :line)) - (d :application :height '(5 :line)) - (e :application :height '( 50 :mm))) - (:layout - (:default (vertically - () - (1/3 (horizontally () (1/10 a) (9/10 b))) - (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) - - -(define-application-frame tf94 - () () - (:command-table test-frame) - (:panes - (a :application :width '(80 :character)) - (b :application) - (c :application :height '(10 :line)) - (d :application) - (e :application :height '( 50 :mm))) - (:layout - (:default (vertically - () - (1/3 (horizontally () (1/10 a) (:fill b))) - (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) - -(define-application-frame tf93 - () () - (:command-table test-frame) - (:panes - (a :application) - (b :application) - (c :application) - (d :application) - (e :application)) - (:layout - (:default (vertically - () - (1/3 (horizontally () (1/10 a) (9/10 b))) - (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) - -(define-application-frame tf91 - () () - (:command-table test-frame) - (:panes - (a :application) - (b :application) - (c :application) - (d :application) - (e :application)) - (:layout - (:default (vertically - () - (1/3 (horizontally () (1/10 a) (:fill b))) - (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) - -(define-application-frame tf92 () - () + (change-space-requirements + (get-frame-pane *application-frame* 'a) + :resize-frame t + :width `(,(random 60) :character)) + (change-space-requirements + (get-frame-pane *application-frame* 'b) + :resize-frame t + :width `(,(random 60) :character)) + (change-space-requirements + (get-frame-pane *application-frame* 'd) + :resize-frame t + :height `(,(random 10) :line)))) + +(define-application-frame tf95 () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application :width '(50 :mm)) + (c :application :height '(10 :line)) + (d :application :height '(5 :line)) + (e :application :height '( 50 :mm))) + (:layouts + (:default + (vertically () + (1/3 (horizontally () (1/10 a) (9/10 b))) + (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) + +(define-application-frame tf94 () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application) + (c :application :height '(10 :line)) + (d :application) + (e :application :height '( 50 :mm))) + (:layouts + (:default + (vertically () + (1/3 (horizontally () (1/10 a) (:fill b))) + (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) + +(define-application-frame tf93 () () + (:command-table test-frame) + (:panes + (a :application) + (b :application) + (c :application) + (d :application) + (e :application)) + (:layouts + (:default + (vertically () + (1/3 (horizontally () (1/10 a) (9/10 b))) + (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) + +(define-application-frame tf91 () () + (:command-table test-frame) + (:panes + (a :application) + (b :application) + (c :application) + (d :application) + (e :application)) + (:layouts + (:default + (vertically () + (1/3 (horizontally () (1/10 a) (:fill b))) + (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) + +(define-application-frame tf92 () () (:pane - (make-pane 'vbox-pane - :contents - (mapcar #'(lambda (x) - (destructuring-bind - (min max &optional (decimal-places 0)) - x - (make-pane 'slider - :label (format nil "Slider ~D,~D,~D" - min max decimal-places) - :min-value min - :max-value max - :decimal-places decimal-places - :show-value-p t - :value-changed-callback 'slider-changed-callback - :drag-callback - 'slider-dragged-callback))) - '((0 100) - (50 60) - (50 60 2) - (0.0 1.0 2)))))) + (make-pane 'vbox-pane + :contents + (mapcar #'(lambda (x) + (destructuring-bind (min max &optional (decimal-places 0)) x + (make-pane 'slider + :label (format nil "Slider ~D,~D,~D" + min max decimal-places) + :min-value min + :max-value max + :decimal-places decimal-places + :show-value-p t + :value-changed-callback 'slider-changed-callback + :drag-callback 'slider-dragged-callback))) + '((0 100) + (50 60) + (50 60 2) + (0.0 1.0 2)))))) (defun test-accepting-values (&optional (own-window t) - (gadget-dialog-view t)) + (gadget-dialog-view t)) (let* ((stream *query-io*) - (ptypes-and-prompts `( - (boolean "Finished it yet") + (ptypes-and-prompts `((boolean "Finished it yet") ((member a b c) "3 Member test") ((member a b c d e f g h) "8 Member test") ((member a b c d e f g h i @@ -676,46 +670,38 @@ ;; A big blob of text ;; token-or-type??.tim ;; Funny ones - ((or integer (member :small :large)) - "Size:") + ((or integer (member :small :large)) "Size:") )) (n (length ptypes-and-prompts)) (values (make-array n :initial-element :none))) (accepting-values (stream :own-window own-window :label "foo") - ;; Test of the member stuff - (clim-internals::letf-globally - (((stream-default-view stream) - (if gadget-dialog-view - (stream-default-view stream) - +textual-dialog-view+))) - - (dotimes (i n) - (if (eq (svref values i) :none) - (setf (svref values i) - (accept (first (nth i - ptypes-and-prompts)) - :stream stream - :prompt (second (nth i - ptypes-and-prompts)))) - (setf (svref values i) - (accept (first (nth i ptypes-and-prompts)) - :default (svref values i) - :stream stream - :prompt (second (nth i ptypes-and-prompts))))) - (terpri stream)))) + ;; Test of the member stuff + (clim-internals::letf-globally (((stream-default-view stream) + (if gadget-dialog-view + (stream-default-view stream) + +textual-dialog-view+))) + (dotimes (i n) + (if (eq (svref values i) :none) + (setf (svref values i) + (accept (first (nth i ptypes-and-prompts)) + :stream stream + :prompt (second (nth i ptypes-and-prompts)))) + (setf (svref values i) + (accept (first (nth i ptypes-and-prompts)) + :default (svref values i) + :stream stream + :prompt (second (nth i ptypes-and-prompts))))) + (terpri stream)))) values)) + ;; This was from a pkarp mail message - (defun shift-output-record (stream record dx dy) (let ((parent (output-record-parent record))) (multiple-value-bind (x-offset y-offset) - (convert-from-relative-to-absolute-coordinates - stream - parent) - (multiple-value-bind - (x y) + (convert-from-relative-to-absolute-coordinates stream parent) + (multiple-value-bind (x y) (bounding-rectangle-position record) (erase-output-record record stream) (output-record-set-position record (+ x dx) (+ y dy)) diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp index b93a211d..cda54bb0 100644 --- a/tk-silica/ol-frames.lisp +++ b/tk-silica/ol-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-frames.lisp,v 1.2 92/01/31 14:56:00 cer Exp $ +;; $fiHeader: ol-frames.lisp,v 1.3 92/02/24 13:06:06 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,3 +30,151 @@ (defmethod make-frame-manager ((port openlook-port)) (make-instance 'openlook-frame-manager :port port)) + + +(defmethod adopt-frame :after ((framem openlook-frame-manager) + (frame standard-application-frame)) + (when (frame-panes frame) + (establish-wm-protocol-callbacks framem frame))) + +(defmethod establish-wm-protocol-callbacks ((framem openlook-frame-manager) frame) + (let ((shell (frame-shell frame))) + (tk::add-ol-callback + shell + (ff::string-to-char* "wmProtocol") + :wm-protocol + 'ol-frame-wm-protocol-callback + frame))) + +(defun ol-frame-wm-protocol-callback (shell value frame) + (when (eq value :wm-delete-window) + (frame-wm-protocol-callback shell frame))) + + +(defmethod frame-manager-dialog-view ((framem openlook-frame-manager)) + +gadget-dialog-view+) + +;;;; + +(defmethod frame-manager-construct-menu + ((framem openlook-frame-manager) + items + printer + presentation-type + associated-window + default-style + label) + (declare (ignore default-style)) + (let* (value-returned + return-value + (simplep (and (null printer) + (null presentation-type))) + (port (port framem)) + (menu-shell (make-instance 'xt::menu-shell + :parent (or (and associated-window + (sheet-mirror associated-window)) + (port-application-shell port)) + :managed nil)) + (menu (tk::get-values menu-shell :menu-pane))) + + (when label + (tk::set-values menu-shell :title label)) + + (labels ((make-menu-button (item class parent &rest options) + (let ((button + (if simplep + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :managed nil + :label (string (menu-item-display item)) + options) + (let* ((pixmap (pixmap-from-menu-item + associated-window + item + printer + presentation-type)) + (image (tk::image-from-pixmap pixmap)) + (button + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :label-type :image + :label-image image + options))) + (xt::add-widget-cleanup-function + button + #'tk::destroy-image image) + button)))) + #+dunno + (when (clim-internals::menu-item-documentation item) + (tk::add-callback button + :help-callback + 'display-motif-help + port + (clim-internals::menu-item-documentation item))) + button)) + (construct-menu-from-items (menu items) + (map nil #'(lambda (item) + (ecase (clim-internals::menu-item-type item) + (:separator + #+dunno + (make-instance 'tk::xm-separator + :managed nil + :parent menu)) + (:label + (make-instance 'xt::static-text + :parent menu + :managed nil + :string (string + (menu-item-display item)))) + (:item + (if (clim-internals::menu-item-item-list item) + (let* ((menu-button + (make-menu-button item + 'xt::menu-button + menu)) + (submenu (tk::get-values menu-button :menu-pane))) + (construct-menu-from-items + submenu + (clim-internals::menu-item-item-list item))) + (let ((menu-button + (make-menu-button item 'xt::oblong-button menu)) + (value (menu-item-value item))) + (tk::add-callback + menu-button + :select + #'(lambda (&rest args) + (declare (ignore args)) + (setq return-value (list value item) + value-returned t)))))))) + items) + ;; + (tk::manage-children (tk::widget-children menu)))) + + (construct-menu-from-items menu items)) + (tk::add-callback menu-shell + :popdown-callback + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (setq value-returned t))) + (values menu-shell + #'(lambda (&optional init) + (if init + (setf value-returned nil return-value nil) + (values value-returned return-value)))))) + +(defmethod framem-enable-menu ((framem openlook-frame-manager) menu) + (tk::ol_menu_post menu)) + +(defmethod framem-destroy-menu ((framem openlook-frame-manager) menu) + (tk::destroy-widget menu)) + +(defmethod framem-popdown-menu ((framem openlook-frame-manager) menu) + (tk::ol_menu_popdown menu)) + +(defmethod framem-menu-active-p ((framem openlook-frame-manager) menu) + (declare (ignore t)) + t) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 82135e09..2a157c04 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.11 92/05/07 13:13:51 cer Exp Locker: cer $ +;; $fiHeader: ol-gadgets.lisp,v 1.12 92/05/13 17:11:12 cer Exp Locker: cer $ (in-package :xm-silica) @@ -32,24 +32,15 @@ (push-button openlook-push-button) (label-pane openlook-label-pane) (text-field openlook-text-field) + (text-editor openlook-text-editor) (toggle-button openlook-toggle-button) (menu-bar openlook-menu-bar) (viewport ol-viewport) (radio-box openlook-radio-box) (frame-pane openlook-frame-pane) (top-level-sheet openlook-top-level-sheet) - ;; One day - (line-editor-pane) - (label-button-pane) - (radio-button-pane) - (horizontal-divider-pane) - (vertical-divider-pane) - (label-pane) - ;; - (list-pane) - (caption-pane) - (cascade-button) - )))) + (list-pane openlook-list-pane) + (option-pane openlook-option-pane))))) ;;;;;;;;;;;;;;;;;;;; @@ -62,7 +53,7 @@ (parent t) (sheet openlook-scroll-bar)) (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::scroll-bar + (values 'tk::scrollbar (list :orientation orientation)))) (defmethod (setf silica::scroll-bar-size) (nv (sb openlook-scroll-bar)) @@ -73,14 +64,17 @@ (tk::set-values (sheet-direct-mirror sb) :slider-value nv) nv) -(defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &rest args - &key slider-size value) - (declare (ignore args)) - (tk::set-values - (sheet-direct-mirror sb) - :proportion-length slider-size - :slider-value value)) +(defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &key slider-size value) + (let ((mirror (sheet-direct-mirror sb))) + (multiple-value-bind + (mmin mmax) (tk::get-values mirror :slider-min :slider-max) + (multiple-value-bind + (real-value real-size) (compute-new-scroll-bar-values sb mmin mmax value slider-size) + (tk::set-values + mirror + :proportion-length real-size + :slider-value real-value))))) (defmethod add-sheet-callbacks ((port openlook-port) (sheet openlook-scroll-bar) (widget t)) (tk::add-callback widget @@ -90,14 +84,18 @@ (defmethod scroll-bar-changed-callback-1 ((widget t) (sheet openlook-scroll-bar)) (multiple-value-bind - (value size) - (tk::get-values widget :slider-value :proportion-length) - (scroll-bar-value-changed-callback - sheet - (gadget-client sheet) - (gadget-id sheet) - value - size))) + (smin smax) (gadget-range* sheet) + (multiple-value-bind + (value size mmin mmax) + (tk::get-values widget :slider-value :proportion-length :slider-min :slider-max) + (scroll-bar-value-changed-callback + sheet + (gadget-client sheet) + (gadget-id sheet) + (compute-symmetric-value + mmin mmax value smin smax) + (compute-symmetric-value + mmin mmax size smin smax))))) (defmethod compose-space ((m openlook-scroll-bar) &key width height) (let ((x 16)) @@ -162,8 +160,8 @@ ;; OpenLook viewport (defclass ol-viewport - (viewport - mirrored-sheet-mixin) + (mirrored-sheet-mixin + viewport) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) @@ -291,9 +289,8 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-push-button)) - (declare (ignore port)) (with-accessors ((label gadget-label)) sheet - (values 'tk::menu-button + (values 'tk::oblong-button (and label (list :label label))))) ;; @@ -307,7 +304,8 @@ 'queue-active-event-ol sheet)) -(defmethod queue-active-event-ol ((widget openlook-action-pane) sheet) +(defmethod queue-active-event-ol (widget (sheet openlook-action-pane)) + (declare (ignore widget)) (distribute-event (port sheet) (make-instance 'activate-gadget-event @@ -361,3 +359,324 @@ (make-instance 'value-changed-gadget-event :gadget sheet :value (gadget-value sheet)))) + +;;; + +(defclass openlook-labelled-gadget () ()) + +(defmethod find-widget-class-and-initargs-for-sheet + :around ((port openlook-port) + (parent t) + (sheet openlook-labelled-gadget)) + (multiple-value-bind + (class initargs) + (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))))) + (values class initargs))) + +(defmethod (setf gadget-label) :after (nv (sheet openlook-labelled-gadget)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :label (or nv "")))) + +(defmethod (setf gadget-alignment) :after (nv (sheet openlook-labelled-gadget)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) + :label-justify (ecase nv + (:center nv) + ((:left :right) nv))))) + +;; Toggle button + +(defclass openlook-toggle-button (toggle-button + openlook-labelled-gadget + openlook-value-pane + xt-leaf-pane) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-toggle-button)) + (with-accessors ((set gadget-value) + (indicator-type gadget-indicator-type)) sheet + (values (typecase (sheet-parent sheet) + (openlook-radio-box 'xt::rect-button) + (openlook-check-box 'xt::rect-button) + (t 'xt::check-box)) + (append (list :set set) + #+dunno + (list :indicator-type + (ecase indicator-type + (:one-of :one-of-many) + (:some-of :n-of-many))))))) + +;; check-box, rect select, unselect callback, :set resource + +(defmethod add-sheet-callbacks :after ((port openlook-port) + (sheet openlook-toggle-button) + (widget t)) + (tk::add-callback widget + :select + 'queue-value-changed-event + sheet) + (tk::add-callback widget + :unselect + 'queue-value-changed-event + sheet)) + +(defmethod gadget-value ((gadget openlook-toggle-button)) + (if (sheet-direct-mirror gadget) + (tk::get-values (sheet-mirror gadget) :set) + (call-next-method))) + +(defmethod (setf gadget-value) (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))) + + + + +;;; + +;; Openlook-orriented-gadget + +(defclass openlook-oriented-gadget () ()) + +(defmethod find-widget-class-and-initargs-for-sheet :around ((port openlook-port) + (parent t) + (sheet openlook-oriented-gadget)) + (multiple-value-bind + (class initargs) + (call-next-method) + (with-accessors ((orientation gadget-orientation)) sheet + (unless (getf initargs :orientation) + (setf (getf initargs :orientation) orientation))) + (values class initargs))) + +(defmethod (setf gadget-orientation) :after (nv (gadget openlook-oriented-gadget)) + (when (sheet-direct-mirror gadget) + (tk::set-values (sheet-direct-mirror gadget) :orientation nv))) + + +;; + +(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 + ask-widget-for-size-mixin + pane) + ()) + +(defmethod sheet-adopt-child :after ((gadget openlook-radio-box) child) + (setf (gadget-client child) gadget)) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-radio-box)) + (values 'xt::exclusives nil)) + +(defmethod value-changed-callback :around ((v gadget) + (client openlook-radio-box) + (id t) + (value t)) + (when (eq value t) + (setf (radio-box-current-selection client) v) + (value-changed-callback client + (gadget-client client) + (gadget-id client) + v)) + (call-next-method)) + +(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))) + (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))) +;;; + + +(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 + ask-widget-for-size-mixin + pane) + ()) + +(defmethod sheet-adopt-child :after ((gadget openlook-check-box) child) + (setf (gadget-client child) gadget)) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-check-box)) + + (values 'xt::nonexclusives nil)) + +(defmethod value-changed-callback :around ((v gadget) + (client openlook-check-box) + (id t) + (value t)) + (if (eq value t) + (push v (check-box-current-selection client)) + (setf (check-box-current-selection client) + (delete v (check-box-current-selection client)))) + (value-changed-callback client + (gadget-client client) + (gadget-id client) + (check-box-current-selection client)) + (call-next-method)) + +;; + +;; Openlook-orriented-gadget + + +(defclass openlook-slider (#+ignore openlook-range-pane + #+ignore openlook-oriented-gadget + xt-leaf-pane + slider) + ()) + + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-slider)) + (with-accessors ((label gadget-label) + (show-value-p gadget-show-value-p) + (value gadget-value) + (orientation gadget-orientation)) sheet + (multiple-value-bind + (smin smax) (gadget-range* sheet) + (let ((mmin 0) + (mmax 100)) + (values 'tk::slider + (append + (list :orientation orientation) + #+dunno + (and label (list :title-string label)) + (list :slider-min mmin + :slider-max mmax) + (and value + (list :slider-value + (fix-coordinate + (compute-symmetric-value + smin smax value mmin + mmax)))))))))) + +(defmethod compose-space ((m openlook-slider) &key width height) + (declare (ignore width height)) + (let ((sr (copy-space-requirement (call-next-method)))) + (ecase (gadget-orientation m) + (:vertical + (setf (space-requirement-max-height sr) +fill+)) + (:horizontal + (setf (space-requirement-max-width sr) +fill+))) + sr)) + +#+dunno +(defmethod (setf gadget-show-value-p) :after (nv (sheet openlook-slider)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :show-value nv))) + +#+dunno +(defmethod (setf gadget-label) :after (nv (sheet openlook-slider)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv "")))) + +;;; + +(defclass openlook-text-editor (openlook-value-pane + openlook-action-pane + text-editor + xt-leaf-pane) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet + openlook-text-editor)) + (with-accessors ((value gadget-value) + (ncolumns silica::gadget-columns) + (nlines silica::gadget-lines)) sheet + (values 'tk::text + (append + (list :edit-mode :multi-line) + (and ncolumns (list :columns ncolumns)) + (and nlines (list :rows nlines)) + (and value `(:value ,value)))))) + +(defmethod compose-space ((te openlook-text-editor) &key width height) + (declare (ignore width height)) + (let ((sr (call-next-method))) + (setq sr (copy-space-requirement sr)) + ;;-- What it the correct thing to do??? + (setf (space-requirement-max-width sr) +fill+ + (space-requirement-max-height sr) +fill+) + sr)) + +(defmethod silica::gadget-supplied-scrolling (frame-manager frame + (contents openlook-text-editor) + &rest ignore) + (declare (ignore ignore)) + (with-look-and-feel-realization (frame-manager frame) + (make-pane 'openlook-scrolling-window :contents contents))) + +;;; +;;;--- This code is so much like the motif one I think we could share +;;;--- code. + +(defclass openlook-scrolling-window (openlook-geometry-manager + ask-widget-for-size-mixin + mirrored-sheet-mixin + sheet-single-child-mixin + sheet-permanently-enabled-mixin + pane) + ;;-- probably one of the options is whether to have vertical + ;;-- and/or horizontal scrollbars + ()) + +(defmethod initialize-instance :after ((pane openlook-scrolling-window) &key contents) + (sheet-adopt-child pane contents)) + +(defmethod compose-space ((fr openlook-scrolling-window) &key width height) + (declare (ignore width height)) + ;;--- This is not quite right because I think scrollbars are a bit + ;;--- bigger than this. But atleast its a start + (let ((fudge-factor (+ 16 + #+ignore + (tk::get-values (sheet-mirror fr) + :spacing))) + (sr (copy-space-requirement (compose-space (sheet-child fr))))) + (incf (space-requirement-width sr) fudge-factor) + (incf (space-requirement-height sr) fudge-factor) + ;;--- Is this the correct thing to do??? + (setf (space-requirement-min-width sr) fudge-factor + (space-requirement-min-height sr) fudge-factor) + sr)) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-scrolling-window)) + (values 'xt::scrolled-window nil)) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 5b4cf3af..c39da7bb 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,17 +20,18 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.7 92/03/24 19:37:03 cer Exp Locker: cer $ +;; $fiHeader: ol-silica.lisp,v 1.8 92/04/03 12:04:50 cer Exp $ (in-package :xm-silica) -(defclass openlook-port (xt-port) - ((type :allocation :class - :initform :openlook :reader port-type))) +(defclass openlook-port (xt-port) ()) (defmethod find-port-type ((type (eql :openlook))) 'openlook-port) +(defmethod port-type ((port openlook-port)) + ':openlook) + (warn "Changing the default server path to ~S" (setq *default-server-path* '(:openlook))) @@ -41,3 +42,47 @@ :height 11 :managed t)) +(defmethod port-note-cursor-change :after ((port openlook-port) + cursor stream type old new) + (declare (ignore old type cursor)) + (when new + (let ((mirror (sheet-mirror stream))) + (when mirror + (let ((window (tk::widget-window mirror))) + (when (eq (tk::window-map-state window) :viewable) + ;;--- There could very well be a race condition involving + ;;--- a couple of processes. Another process could have made + ;;--- this window go away at this point + (tk::ol_set_input_focus + mirror + 2 ; RevertToParent + 0))))))) + +(defmethod change-widget-geometry ((parent tk::draw-area) child + &rest args + &key x y width height) + (declare (ignore x y width height)) + (apply #'tk::configure-widget child args)) + +;;;--- Why have this class + +(defclass openlook-geometry-manager (xt-geometry-manager) ()) + +(defmethod find-shell-class-and-initargs ((port openlook-port) sheet) + (declare (ignore port)) + (cond ( ;;--- hack alert + (popup-frame-p sheet) + (values 'tk::transient-shell + (append + (let ((x (find-shell-of-calling-frame sheet))) + (and x `(:transient-for ,x))) + '(:keyboard-focus-policy :pointer)))) + (t + (call-next-method)))) + +(defmethod enable-xt-widget ((parent tk::transient-shell) (mirror t)) + (manage-child mirror) + (popup parent)) + +(defmethod disable-xt-mirror ((parent xt::transient-shell) (mirror t)) + (tk::popdown parent)) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index b6f2b5a5..7a0e3007 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.16 92/05/06 15:37:53 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.17 92/05/13 17:11:14 cer Exp Locker: cer $ (in-package :xm-silica) @@ -44,95 +44,6 @@ 'frame-wm-protocol-callback frame))) -;;; Definitions of the individual classes - -;; This looks like garbage?? - -;(defclass motif-main-window (motif-composite-pane) -; ( -; (contents :accessor main-window-contents :initform nil) -; (command-window :initform nil :accessor main-window-command-window) -; command-window-location -; menu-bar -; message-window -; )) -; -;(defmethod initialize-instance :after ((mw motif-main-window) -; &key -; command-window -; command-window-location -; menu-bar -; message-window -; contents) -; (when contents -; (setf (main-window-contents mw) contents)) -; (when command-window -; (setf (main-window-command-window mw) command-window)) -; (when message-window -; (setf (main-window-message-window mw) message-window))) -; -;(defmethod (setf main-window-contents) :after (nv (mw motif-main-window)) -; (unless (sheet-parent nv) -; (sheet-adopt-child mw nv))) -; -;(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window)) -; (unless (sheet-parent nv) -; (sheet-adopt-child mw nv))) -; -;#+ignore -;(defmethod realize-mirror :around (port (motif-main-window)) -; (let ((m (call-next-method))) -; (tk::xm_set_main_window_areas -; m -; .. -; (and command-window (realize-mirror port command-window)) -; .. -; (and message-window (realize-mirror port message-window)) -; ...))) - -;;;; Drawing area -; -;#+ignore -;(defclass motif-drawing-area (motif-composite-pane) ()) -; -;;;; Row colum -; -;(defclass motif-row-colum (motif-composite-pane) ()) -; -;;;; Push button - -;#+ignore -;(defclass motif-push-button (motif-leaf-pane) ()) - -;;; Menu bar - -;(defclass motif-menu-bar (motif-composite-pane) ()) -;(defclass motif-pulldown-menu (motif-composite-pane) ()) -; -;(defclass motif-cascade-button (motif-composite-pane) -; ((submenu :accessor cascade-button-submenu :initform nil)) -; ) -; -;(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button)) -; (let ((m (call-next-method))) -; (when (cascade-button-submenu sheet) -; (tk::set-values m :sub-menu-id -; (realize-mirror port (cascade-button-submenu sheet)))) -; m)) - -(defmethod handle-event (sheet (event window-manager-delete-event)) - (frame-exit *application-frame*)) - -(defun frame-wm-protocol-callback (widget frame) - ;; Invoked when the Wm close function has been selected - ;; We want to queue an "event" somewhere so that we can - ;; synchronously quit from the frame - (distribute-event - (port frame) - (make-instance 'window-manager-delete-event - :sheet (frame-top-level-sheet frame)))) - - (defclass motif-menu-bar (xt-leaf-pane) ((command-table :initarg :command-table))) @@ -279,18 +190,18 @@ mirror)) (defun display-motif-help (widget port documentation) - (port-notify-user - port + (frame-manager-notify-user + (find-frame-manager :port port) ;--- frame manager should be passed in documentation :associated-window widget)) -(defmethod port-dialog-view ((port motif-port)) +(defmethod frame-manager-dialog-view ((framem motif-frame-manager)) +gadget-dialog-view+) -;;--- Should "ungray" the command button, if there is one ;;--- If the command button is visible, right now since everything is ;;--- in a menu we do not have a problem with this. +;;--- Should "ungray" the command button, if there is one (defmethod note-command-enabled ((framem motif-frame-manager) frame command) (declare (ignore frame command))) @@ -338,3 +249,136 @@ (tk::set-values shell :clip-mask (decode-pixmap clipping-mask)))))))) +;;; + +(defmethod frame-manager-construct-menu + ((framem motif-frame-manager) + items + printer + presentation-type + associated-window + default-style + label) + (declare (ignore default-style)) + (let* (value-returned + return-value + (simplep (and (null printer) + (null presentation-type))) + (port (port framem)) + (menu (make-instance 'tk::xm-popup-menu + :parent (or (and associated-window + (sheet-mirror associated-window)) + (port-application-shell port)) + :managed nil))) + (when label + (make-instance 'tk::xm-label + :parent menu + :managed nil + :label-string label) + (make-instance 'tk::xm-separator + :managed nil + :separator-type :double-line + :parent menu)) + (labels ((make-menu-button (item class parent &rest options) + (let ((button + (if simplep + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :managed nil + :label-string (string (menu-item-display item)) + options) + (let* ((pixmap (pixmap-from-menu-item + associated-window + item + printer + presentation-type)) + (button + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :label-type :pixmap + :label-pixmap pixmap + options))) + (xt::add-widget-cleanup-function + button + #'tk::destroy-pixmap pixmap) + button)))) + (when (clim-internals::menu-item-documentation item) + (tk::add-callback button + :help-callback + 'display-motif-help + port + (clim-internals::menu-item-documentation item))) + button)) + (construct-menu-from-items (menu items) + (map nil #'(lambda (item) + (ecase (clim-internals::menu-item-type item) + (:separator + (make-instance 'tk::xm-separator + :managed nil + :parent menu)) + (:label + (make-instance 'tk::xm-label + :parent menu + :managed nil + :label-string (string + (menu-item-display item)))) + (:item + (if (clim-internals::menu-item-item-list item) + (let* ((submenu (make-instance + 'tk::xm-pulldown-menu + :managed nil + :parent menu)) + (menu-button + (make-menu-button item + 'tk::xm-cascade-button + menu + :sub-menu-id submenu))) + (declare (ignore menu-button)) + (construct-menu-from-items + submenu + (clim-internals::menu-item-item-list item))) + (let ((menu-button + (make-menu-button item + 'tk::xm-push-button + menu)) + (value (menu-item-value item))) + (tk::add-callback + menu-button + :activate-callback + #'(lambda (&rest args) + (declare (ignore args)) + (setq return-value (list value item) + value-returned t)))))))) + items) + ;; + (tk::manage-children (tk::widget-children menu)))) + + (construct-menu-from-items menu items)) + (tk::add-callback (widget-parent menu) + :popdown-callback + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (setq value-returned t))) + (values menu + #'(lambda (&optional init) + (if init + (setf value-returned nil return-value nil) + (values value-returned return-value)))))) + +(defmethod framem-enable-menu ((framem motif-frame-manager) menu) + (tk::manage-child menu)) + +(defmethod framem-destroy-menu ((framem motif-frame-manager) menu) + (tk::destroy-widget (tk::widget-parent menu))) + +(defmethod framem-popdown-menu ((framem motif-frame-manager) menu) + ;; Should be already popped down + nil) + + +(defmethod framem-menu-active-p ((framem motif-frame-manager) menu) + (not (tk::is-managed-p menu))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 120fc766..5b201a03 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.29 92/05/12 18:25:22 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.30 92/05/13 17:11:16 cer Exp Locker: cer $ (in-package :xm-silica) @@ -38,7 +38,7 @@ (menu-bar motif-menu-bar) (viewport xm-viewport) (radio-box motif-radio-box) - (clim-internals::check-box motif-check-box) + (check-box motif-check-box) (frame-pane motif-frame-pane) (top-level-sheet motif-top-level-sheet) (list-pane motif-list-pane) @@ -65,7 +65,7 @@ (defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key invoke-callback) (declare (ignore invoke-callback)) - (when (sheet-mirror gadget) + (when (sheet-direct-mirror gadget) (tk::set-values (sheet-mirror gadget) :value nv))) (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet))) @@ -159,7 +159,6 @@ (sheet motif-label-pane)) (values 'tk::xm-label nil)) - ;;; Push button (defclass motif-push-button (push-button @@ -268,7 +267,6 @@ (value gadget-value)) sheet (multiple-value-bind (smin smax) (gadget-range* sheet) - (let ((mmin 0) (mmax 100) (decimal-points 0) @@ -308,6 +306,7 @@ (when (sheet-direct-mirror sheet) (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv "")))) + (defmethod compose-space ((m motif-slider) &key width height) (declare (ignore width height)) (multiple-value-bind @@ -355,20 +354,16 @@ (defmethod change-scroll-bar-values ((sb motif-scroll-bar) &key slider-size value) (let ((mirror (sheet-direct-mirror sb))) (multiple-value-bind - (smin smax) (gadget-range* sb) + (mmin mmax) (tk::get-values mirror :minimum :maximum) (multiple-value-bind - (mmin mmax) (tk::get-values mirror :minimum :maximum) + (real-value real-size) (compute-new-scroll-bar-values sb mmin mmax value slider-size) (tk::set-values mirror - :slider-size - (fix-coordinate - (compute-symmetric-value - smin smax slider-size mmin mmax)) - :value (fix-coordinate - (compute-symmetric-value - smin smax value mmin mmax))))))) + :slider-size real-size + :value real-value))))) + (defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scroll-bar) (widget t)) (tk::add-callback widget :value-changed-callback @@ -376,9 +371,9 @@ sheet)) -(defun scroll-bar-changed-callback-1 (widget sheet) +(defmethod scroll-bar-changed-callback-1 ((widget t) (sheet motif-scroll-bar)) (multiple-value-bind - (smin smax) (silica::gadget-range* sheet) + (smin smax) (gadget-range* sheet) (multiple-value-bind (value size mmin mmax) (tk::get-values widget :value :slider-size :minimum :maximum) @@ -386,9 +381,9 @@ sheet (gadget-client sheet) (gadget-id sheet) - (silica::compute-symmetric-value + (compute-symmetric-value mmin mmax value smin smax) - (silica::compute-symmetric-value + (compute-symmetric-value mmin mmax size smin smax))))) @@ -635,8 +630,8 @@ sheet)) (defclass motif-radio-box (motif-geometry-manager - motif-oriented-gadget mirrored-sheet-mixin + motif-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin radio-box @@ -650,26 +645,28 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-radio-box)) - (values 'tk::xm-radio-box nil)) -(defmethod value-changed-callback :after ((v gadget) - (client motif-radio-box) - (id t) - (value t)) +(defmethod value-changed-callback :around ((v gadget) + (client motif-radio-box) + (id t) + (value t)) + ;; This and the one below have to be around because of the user has + ;; specified a callback function only arounds ever get executed. (when (eq value t) (setf (radio-box-current-selection client) v) (value-changed-callback client (gadget-client client) (gadget-id client) - v))) + v)) + (call-next-method)) (defclass motif-check-box (motif-geometry-manager - motif-oriented-gadget mirrored-sheet-mixin + motif-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin - silica::check-box + check-box ask-widget-for-size-mixin pane) ()) @@ -683,18 +680,21 @@ (values 'tk::xm-row-column nil)) -(defmethod value-changed-callback :after ((v gadget) - (client motif-check-box) - (id t) - (value t)) +(defmethod value-changed-callback :around ((v gadget) + (client motif-check-box) + (id t) + (value t)) + ;; This and the one below have to be around because of the user has + ;; specified a callback function only arounds ever get executed. (if (eq value t) - (push v (silica::check-box-current-selection client)) - (setf (silica::check-box-current-selection client) - (delete v (silica::check-box-current-selection client)))) + (push v (check-box-current-selection client)) + (setf (check-box-current-selection client) + (delete v (check-box-current-selection client)))) (value-changed-callback client (gadget-client client) (gadget-id client) - (silica::check-box-current-selection client))) + (check-box-current-selection client)) + (call-next-method)) ;; Frame-viewport that we need because a sheet can have @@ -784,8 +784,7 @@ (let ((fudge-factor (+ 16 (tk::get-values (sheet-mirror fr) :spacing))) - (sr (copy-space-requirement (compose-space - (sheet-child fr))))) + (sr (copy-space-requirement (compose-space (sheet-child fr))))) (incf (space-requirement-width sr) fudge-factor) (incf (space-requirement-height sr) fudge-factor) ;;--- Is this the correct thing to do??? @@ -922,7 +921,6 @@ (declare (ignore count)) (queue-value-changed-event widget sheet value)) - (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback) (declare (ignore invoke-callback)) (set-option-menu-value gadget nv)) @@ -944,22 +942,22 @@ (tk::set-values (tk::intern-widget (tk::xm_option_button_gadget widget)) :label-string (funcall name-key (nth x items)))))))) -(defmethod port-notify-user ((port motif-port) - message-string - &key - (style :inform) - (frame nil frame-p) - (associated-window - (if frame-p - (frame-top-level-sheet frame) - (find-graft :port port))) - (title "Notify user") - documentation - (exit-boxes - '(:exit - :abort - :help)) - (name title)) +(defmethod frame-manager-notify-user ((framem motif-frame-manager) + message-string + &key + (style :inform) + (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Notify user") + documentation + (exit-boxes + '(:exit + :abort + :help)) + (name title)) (let ((dialog (make-instance (ecase style (:inform 'tk::xm-information-dialog) (:error 'tk::xm-error-dialog) @@ -983,8 +981,8 @@ (setq result (list r))) (display-help (widget ignore) (declare (ignore widget ignore)) - (port-notify-user - port + (frame-manager-notify-user + framem documentation :associated-window associated-window))) (tk::add-callback dialog :ok-callback #'set-it t) @@ -1010,21 +1008,12 @@ (progn (tk::manage-child dialog) (wait-for-callback-invocation - port + (port framem) #'(lambda () (or result (not (tk::is-managed-p dialog)))) "Waiting for dialog")) (tk::destroy-widget dialog)) (car result))))) - -(defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback")) - (if (eq mp:*current-process* (port-process port)) - (progn - (loop - (when (funcall predicate) (return nil)) - (process-next-event port))) - (mp:process-wait whostate predicate))) - (defun get-message-box-child (widget &rest children) (values-list (mapcar #'(lambda (child) @@ -1073,23 +1062,20 @@ ;;; File Selection -(defmethod port-select-file ((port motif-port) &rest options - &key - (frame nil frame-p) - (associated-window - (if frame-p - (frame-top-level-sheet frame) - (find-graft :port port))) - (title "Select File") - documentation - file-search-proc - directory-list-label - file-list-label - (exit-boxes - '(:exit - :abort - :help)) - (name title)) +(defmethod frame-manager-select-file + ((framem motif-frame-manager) &rest options + &key (frame nil frame-p) + (associated-window + (if frame-p + (frame-top-level-sheet frame) + (graft framem))) + (title "Select File") + documentation + file-search-proc + directory-list-label + file-list-label + (exit-boxes '(:exit :abort :help)) + (name title)) (let ((dialog (make-instance 'tk::xm-file-selection-dialog @@ -1171,3 +1157,5 @@ (push (cons :file-search-proc file-search-proc) (tk::widget-callback-data dialog)) *file-search-proc-callback-address*) + +;;; diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp index 45a6606e..ddffd18b 100644 --- a/tk-silica/xm-menus.lisp +++ b/tk-silica/xm-menus.lisp @@ -18,221 +18,14 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-menus.lisp,v 1.11 92/05/06 15:37:58 cer Exp Locker: cer $ +;; $fiHeader: xm-menus.lisp,v 1.12 92/05/07 13:13:54 cer Exp $ (in-package :xm-silica) -;;-- This is generic and should be specialized on xt-port +;;-- This is generic and should be specialized on xt-frame-manager + -(defmethod port-menu-choose ((port motif-port) items &rest keys - &key printer - presentation-type - associated-window - default-style label - cache - (unique-id items) - (id-test 'equal) - (cache-value items) - (cache-test #'equal)) - (declare (ignore keys)) - (declare (values value chosen-item gesture)) - (let (menu closure) - (when cache - (let ((x (assoc unique-id - (port-menu-cache port) - :test id-test))) - (when x - (destructuring-bind - (menu-cache-value amenu aclosure) x - (if (funcall cache-test cache-value menu-cache-value) - (setq menu amenu closure aclosure) - (progn - (setf (port-menu-cache port) - (delete x (port-menu-cache port))) - (tk::destroy-widget (tk::widget-parent amenu)))))))) - - (unless menu - (multiple-value-setq - (menu closure) - (port-construct-menu port - items - printer - presentation-type - associated-window - default-style - label)) - (when cache - (push (list unique-id menu closure) - (port-menu-cache port)))) - - ;; initialize the closure - (funcall closure t) - ;; - (multiple-value-bind - (ignore win1 win2 x y root-x root-y) - (tk::query-pointer (tk::display-root-window - (port-display port))) - (declare (ignore ignore win1 win2 x y)) - (tk::set-values menu :x root-x :y root-y) - (loop - (when (funcall closure) (return nil)) - (tk::manage-child menu) - ;; Now we have to wait - (port-force-output port) - (wait-for-callback-invocation - port - #'(lambda () - ;;-- This is to deal - ;;-- with the race - ;;-- condition where - ;;-- the menu go down - ;;-- to quick - (or (funcall closure) - (not (tk::is-managed-p menu)))) - "Returned value")) - (unless cache - (tk::destroy-widget (tk::widget-parent menu))) - - (values-list (nth-value 1 (funcall closure)))))) -(defmethod port-construct-menu ((port motif-port) - items - printer - presentation-type - associated-window - default-style - label) - (declare (ignore default-style)) - (let (value-returned - return-value - (simplep (and (null printer) - (null presentation-type))) - (menu (make-instance 'tk::xm-popup-menu - :parent (or (and associated-window - (sheet-mirror associated-window)) - (port-application-shell - port)) - :managed nil))) - (when label - (make-instance 'tk::xm-label - :parent menu - :managed nil - :label-string label) - (make-instance 'tk::xm-separator - :managed nil - :separator-type :double-line - :parent menu)) - (labels ((make-menu-button (item class parent &rest options) - (let ((button - (if simplep - (apply #'make-instance - class - :sensitive (clim-internals::menu-item-active item) - :parent parent - :managed nil - :label-string (string (menu-item-display item)) - options) - (let* ((pixmap (pixmap-from-menu-item - associated-window - item - printer - presentation-type)) - (button - (apply #'make-instance - class - :sensitive (clim-internals::menu-item-active item) - :parent parent - :label-type :pixmap - :label-pixmap pixmap - options))) - (xt::add-widget-cleanup-function - button - #'tk::destroy-pixmap pixmap) - button)))) - (when (clim-internals::menu-item-documentation item) - (tk::add-callback button - :help-callback - 'display-motif-help - port - (clim-internals::menu-item-documentation item))) - button)) - (construct-menu-from-items (menu items) - (map nil #'(lambda (item) - (ecase (clim-internals::menu-item-type item) - (:separator - (make-instance 'tk::xm-separator - :managed nil - :parent menu)) - (:label - (make-instance 'tk::xm-label - :parent menu - :managed nil - :label-string (string - (menu-item-display item)))) - (:item - (if (clim-internals::menu-item-item-list item) - (let* ((submenu (make-instance - 'tk::xm-pulldown-menu - :managed nil - :parent menu)) - (menu-button - (make-menu-button item - 'tk::xm-cascade-button - menu - :sub-menu-id submenu))) - (declare (ignore menu-button)) - (construct-menu-from-items - submenu - (clim-internals::menu-item-item-list item))) - (let ((menu-button - (make-menu-button item - 'tk::xm-push-button - menu)) - (value (menu-item-value item))) - (tk::add-callback - menu-button - :activate-callback - #'(lambda (&rest args) - (declare (ignore args)) - (setq return-value (list value item) - value-returned t)))))))) - items) - ;; - (tk::manage-children (tk::widget-children menu)))) - - (construct-menu-from-items menu items)) - (tk::add-callback (widget-parent menu) - :popdown-callback - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (setq value-returned t))) - (values menu - #'(lambda (&optional init) - (if init - (setf value-returned nil return-value nil) - (values value-returned return-value)))))) - -(defun pixmap-from-menu-item (associated-window menu-item printer presentation-type) - (with-menu (menu associated-window) - (setf (stream-text-margin menu) 1000) - (let ((rec (with-output-recording-options (menu :draw nil :record t) - (with-output-to-output-record (menu) - (handler-case - (if presentation-type - (present menu-item presentation-type :stream menu) - (funcall printer menu-item menu)) - (error (c) - (write-string "Error in printer" menu))))))) - (multiple-value-bind - (width height) - (bounding-rectangle-size rec) - (with-output-to-pixmap (s associated-window :width width :height height) - (multiple-value-call #'draw-rectangle* - s 0 0 (bounding-rectangle-size s) :ink +background-ink+) - (replay-output-record - rec s +everywhere+ - (- (bounding-rectangle-min-x rec)) - (- (bounding-rectangle-min-y rec)))))))) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index a6bba1a2..7892c0f6 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,19 +18,19 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.17 92/04/30 09:09:53 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.18 92/05/13 17:11:20 cer Exp Locker: cer $ (in-package :xm-silica) ;; Motif specific stuff -(defclass motif-port (xt-port) - ((type :allocation :class - :initform :motif :reader port-type))) +(defclass motif-port (xt-port) ()) (defmethod find-port-type ((type (eql ':motif))) 'motif-port) +(defmethod port-type ((port motif-port)) + ':motif) (defmethod change-widget-geometry ((parent tk::xm-my-drawing-area) child &rest args @@ -51,40 +51,9 @@ ;;-- shells decide where windows are positioned! (tk::set-values child :width width :height height)) -(defclass motif-geometry-manager () - ;; --- This is probably all - ;; composites excepts drawing-area and shell - () - (:documentation "These are all parents that have strong feelings -about their children")) +(defclass motif-geometry-manager (xt-geometry-manager) ()) -(defmethod update-mirror-transformation-1 ((port port) sheet - (parent motif-geometry-manager)) - nil) - -(defmethod update-mirror-region-1 ((port port) sheet - (parent motif-geometry-manager)) - nil) - - -(defmethod update-mirror-transformation-1 :after ((port port) - (sheet motif-geometry-manager) - (parent t)) - (update-geo-manager-sheet-children sheet)) - - -(defmethod update-mirror-region-1 :after ((port port) - (sheet motif-geometry-manager) - (parent t)) - (update-geo-manager-sheet-children sheet)) - -(defmethod update-geo-manager-sheet-children (geo-manager) - (dolist (child (sheet-children geo-manager)) - ;;--- Yuck! - (when (typep child 'mirrored-sheet-mixin) - (mirror-region-updated (port geo-manager) child)))) - (defmethod find-shell-class-and-initargs ((port motif-port) sheet) (declare (ignore port)) (cond ( ;;--- hack alert @@ -112,3 +81,10 @@ about their children")) ; (declare (ignore old type cursor)) ; (when new ; (xmprocesstraversal (sheet-mirror stream) 0))) + +(defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t)) + ;; this is a nasty hack just to make sure that the child is managed. + ;; top-level-sheets are created unmanaged because they are + ;; disabled to we have to do not! + (manage-child mirror) + (popup (widget-parent mirror))) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 4ee2af97..990cef2c 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.9 92/04/21 16:13:34 cer Exp Locker: cer $ +;; $fiHeader: xt-frames.lisp,v 1.10 92/05/07 13:13:56 cer Exp $ (in-package :xm-silica) @@ -28,7 +28,10 @@ ;; Basic intrinsics frame-manager (defclass xt-frame-manager (standard-frame-manager) - ()) + ((menu-cache + :initform nil + :accessor frame-manager-menu-cache) + )) (defmethod frame-wrapper ((framem xt-frame-manager) (frame standard-application-frame) pane) @@ -88,3 +91,126 @@ :value (second item)))) +(defun frame-wm-protocol-callback (widget frame) + ;; Invoked when the Wm close function has been selected + ;; We want to queue an "event" somewhere so that we can + ;; synchronously quit from the frame + (distribute-event + (port frame) + (make-instance 'window-manager-delete-event + :sheet (frame-top-level-sheet frame)))) + +(defmethod handle-event (sheet (event window-manager-delete-event)) + (frame-exit *application-frame*)) + +;;; Menu code + +(defmethod frame-manager-menu-choose + ((framem xt-frame-manager) items &rest keys + &key printer + presentation-type + (associated-window (frame-top-level-sheet *application-frame*)) + default-style label + cache + (unique-id items) + (id-test 'equal) + (cache-value items) + (cache-test #'equal)) + (declare (ignore keys)) + (declare (values value chosen-item gesture)) + (let ((port (port framem)) + menu closure) + (when cache + (let ((x (assoc unique-id + (frame-manager-menu-cache framem) + :test id-test))) + (when x + (destructuring-bind + (menu-cache-value amenu aclosure) x + (if (funcall cache-test cache-value menu-cache-value) + (setq menu amenu closure aclosure) + (progn + (setf (frame-manager-menu-cache framem) + (delete x (frame-manager-menu-cache framem))) + (tk::destroy-widget (tk::widget-parent amenu)))))))) + + (unless menu + (multiple-value-setq + (menu closure) + (frame-manager-construct-menu framem + items + printer + presentation-type + associated-window + default-style + label)) + (when cache + (push (list unique-id menu closure) + (frame-manager-menu-cache framem)))) + + ;; initialize the closure + (funcall closure t) + ;; + (multiple-value-bind + (ignore win1 win2 x y root-x root-y) + (tk::query-pointer (tk::display-root-window + (port-display port))) + (declare (ignore ignore win1 win2 x y)) + (tk::set-values menu :x root-x :y root-y) + (loop + (when (funcall closure) (return nil)) + (framem-enable-menu framem menu) + ;; Now we have to wait + (port-force-output port) + (wait-for-callback-invocation + port + #'(lambda () + ;;-- This is to deal + ;;-- with the race + ;;-- condition where + ;;-- the menu go down + ;;-- to quick + (or (funcall closure) + (not (framem-menu-active-p framem menu)))) + "Returned value")) + + (framem-popdown-menu framem menu) + + (unless cache + (framem-destroy-menu framem menu)) + + (values-list (nth-value 1 (funcall closure)))))) + + +(defun pixmap-from-menu-item (associated-window menu-item printer presentation-type) + (with-menu (menu associated-window) + (setf (stream-text-margin menu) 1000) + (let ((rec (with-output-recording-options (menu :draw nil :record t) + (with-output-to-output-record (menu) + (handler-case + (if presentation-type + (present menu-item presentation-type :stream menu) + (funcall printer menu-item menu)) + (error (c) + (write-string "Error in printer" menu))))))) + (multiple-value-bind + (width height) + (bounding-rectangle-size rec) + (with-output-to-pixmap (s associated-window :width width :height height) + (multiple-value-call #'draw-rectangle* + s 0 0 (bounding-rectangle-size s) :ink +background-ink+) + (replay-output-record + rec s +everywhere+ + (- (bounding-rectangle-min-x rec)) + (- (bounding-rectangle-min-y rec)))))))) + + +;;; + +(defmethod clim-internals::frame-manager-exit-box-labels ((frame t) (framem xt-frame-manager)) + '( + (:exit "Ok") + (:abort "Cancel"))) + +(defmethod clim-internals::frame-manager-default-exit-boxes ((framem xt-frame-manager)) + '((:exit) (:abort))) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index bf362ccf..13cc880a 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.12 92/05/07 13:13:57 cer Exp Locker: cer $ +;; $fiHeader: xt-gadgets.lisp,v 1.13 92/05/12 18:25:28 cer Exp Locker: cer $ (in-package :xm-silica) @@ -136,7 +136,27 @@ ;;--- This isn't really right. Genera and CLX ports have kludges ;;--- for the time being, too. + (defmethod sheet-shell (sheet) (do ((w (sheet-mirror sheet) (tk::widget-parent w))) ((typep w '(or tk::shell null)) w))) + +(defun compute-new-scroll-bar-values (scroll-bar mmin mmax value slider-size) + (multiple-value-bind + (smin smax) (gadget-range* scroll-bar) + (values + (fix-coordinate + (compute-symmetric-value + smin smax value mmin mmax)) + (fix-coordinate + (compute-symmetric-value + smin smax slider-size mmin mmax))))) + +(defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback")) + (if (eq mp:*current-process* (port-process port)) + (progn + (loop + (when (funcall predicate) (return nil)) + (process-next-event port))) + (mp:process-wait whostate predicate))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 67169a47..fda8cdff 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.21 92/05/13 17:11:23 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.22 92/05/14 11:04:02 cer Exp Locker: cer $ (in-package :tk-silica) @@ -260,7 +260,7 @@ (defmethod decode-ink ((ink color) (medium xt-medium)) (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable - color-p ink-table) + color-p) medium (or (gethash ink ink-table) (let ((drawable (or drawable @@ -271,7 +271,6 @@ (decode-color medium ink))) (t (multiple-value-bind (r g b) (color-rgb ink) - ;; The luminance formula isn't really right. XXX (let* ((luminance (color-luminosity r g b)) (color (decode-luminance luminance t))) (cond ((eq color 1) @@ -317,7 +316,7 @@ and on color servers, unless using white or black") (tk::gcontext-fill-style new-gc) :stippled) (setf (gethash key ink-table) new-gc)))))) - + (defmethod decode-ink ((ink contrasting-ink) stream) (decode-ink (make-color-for-contrasting-ink ink) stream)) @@ -957,34 +956,6 @@ and on color servers, unless using white or black") to-left to-top)) - -;;--- Is this used any more? -(defmethod port-write-string-1 ((port xt-port) medium - glyph-buffer start end - x-font color x y) - (break "is this used anymore") - (unless (= start end) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (window (medium-drawable medium)) - (font x-font)) - ;; At one point we checked to see whether the widget is unrealized - ;; or not. Can we draw on disabled sheets? - (convert-to-device-coordinates transform x y) - (incf y (tk::font-ascent font)) - (when (medium-drawable medium) - (let ((gc (decode-ink (medium-ink medium) medium))) - (setf (tk::gcontext-font gc) font) - (etypecase glyph-buffer - ((simple-array (unsigned-byte 16)) - (x11::xdrawstring16 - (tk::object-display window) - window - gc - x y - glyph-buffer (- end start))))))))) - - (defmethod port-beep ((port xt-port) (sheet t)) (x11:xbell (port-display port) 100)) @@ -1042,4 +1013,4 @@ and on color servers, unless using white or black") to-drawable seq-no '(:graphics-expose) :block nil)) (unless event - (return)))))))))))))) + (return)))))))))))))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index b80bc42a..faeee8bc 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.26 92/05/12 18:25:31 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.27 92/05/13 17:11:24 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,17 +30,15 @@ (context :reader port-context) (copy-gc :initform nil) (opacities :initform nil) - (type :allocation :class - :initform :xt :reader port-type) (event-lock :initform (clim-sys:make-lock "port event lock") :reader port-event-lock) - (menu-cache - :initform nil - :accessor port-menu-cache) (rotated-font-cache :initform nil :accessor port-rotated-font-cache)) (:default-initargs :allow-loose-text-style-size-mapping t) (:documentation "The port for X intrinsics based ports")) +(defmethod port-type ((port xt-port)) + ':xt) + (defmethod port-copy-gc ((port xt-port)) (with-slots (copy-gc display) port (or copy-gc @@ -49,7 +47,7 @@ :display display :graphics-exposures :on :foreign-address (x11:screen-default-gc - (x11:xdefaultscreenofdisplay display))))))) + (x11:xdefaultscreenofdisplay display))))))) @@ -78,14 +76,21 @@ ,@body))) (defmethod initialize-instance :after ((port xt-port) &key server-path) - (destructure-x-server-path (:display display) server-path - (declare (ignore ignore)) - (multiple-value-bind (context display application-shell) - (initialize-motif-toolkit display) - (setf (slot-value port 'application-shell) application-shell - (slot-value port 'context) context - (slot-value port 'display) display) - (initialize-xlib-port port display)))) + (destructuring-bind + (&key (display nil display-p) + (application-name nil application-name-p) + (application-class nil application-class-p)) + (cdr server-path) + (let ((args nil)) + (when display-p (setf (getf args :host) display)) + (when application-name-p (setf (getf args :application-name) application-name)) + (when application-class-p (setf (getf args :application-class) application-class)) + (multiple-value-bind (context display application-shell) + (apply #'tk::initialize-toolkit args) + (setf (slot-value port 'application-shell) application-shell + (slot-value port 'context) context + (slot-value port 'display) display) + (initialize-xlib-port port display))))) (defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*") (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*") @@ -565,29 +570,27 @@ ,@initargs)))) (defmethod enable-mirror ((port xt-port) sheet) - (declare (ignore port)) (let ((mirror (sheet-mirror sheet))) - (typecase (widget-parent mirror) - (null) - ((or top-level-shell tk::xm-dialog-shell) - ;; this is a nasty hack just to make sure that the child is managed. - ;; top-level-sheets are created unmanaged because they are - ;; disabled to we have to do not! - (manage-child mirror) - (popup (widget-parent mirror))) - (t - (manage-child mirror))))) + (enable-xt-widget (widget-parent mirror) mirror))) + +(defmethod enable-xt-widget ((parent t) (mirror t)) + (manage-child mirror)) + +(defmethod enable-xt-widget ((parent top-level-shell) (mirror t)) + (manage-child mirror) + (popup (widget-parent mirror))) (defmethod disable-mirror ((port xt-port) sheet) (declare (ignore port)) (let ((mirror (sheet-mirror sheet))) (when mirror - (typecase (widget-parent mirror) - (null) - (top-level-shell - (tk::popdown (widget-parent mirror))) - (t - (tk::unmanage-child mirror)))))) + (disable-xt-mirror (widget-parent mirror) mirror)))) + +(defmethod disable-xt-mirror ((parent t) (mirror t)) + (tk::unmanage-child mirror)) + +(defmethod disable-xt-mirror ((parent top-level-shell) (mirror t)) + (tk::popdown parent)) (defmethod realize-graft ((port xt-port) graft) ;; Set the width etc etc @@ -606,14 +609,13 @@ silica::pixels-per-point (float (/ silica::pixel-width (* 72 (/ silica::mm-width 25.4))))) ;;--- Mess with the region - (warn "Do something about the graft") (setf (sheet-region graft) (ecase (graft-units graft) ((:device :pixel) (make-bounding-rectangle 0 0 silica::pixel-width silica::pixel-height)))) ;;-- what about the transformation - ))) + (setf (sheet-native-transformation graft) +identity-transformation+)))) (defmethod mirror-region* ((port xt-port) sheet) (when (sheet-mirror sheet) @@ -699,9 +701,7 @@ :timeout timeout)) (tk::process-one-event context mask reason)))))) -(defmethod port-force-output ((port xt-port)) - ;;--- move to tk - (x11::xflush (port-display port))) + (defmethod port-glyph-for-character ((port xt-port) character text-style @@ -994,6 +994,10 @@ (pane clim-internals::output-protocol-mixin)) (default-from-mirror-resources port pane)) +(defmethod engraft-medium :before ((medium t) (port xt-port) (pane viewport)) + (default-from-mirror-resources port pane)) + + ;;-- What do we do about pixmap streams. I guess they should inherit ;;-- properties from the parent. @@ -1007,29 +1011,30 @@ (unless (and (medium-foreground pane) (medium-background pane)) (let* ((w (sheet-mirror pane)) - (dap (typep w 'tk::xm-drawing-area))) - - ;;-- What about the case when there is a pixmap - (multiple-value-bind - (foreground background) - (if dap - (tk::get-values w :foreground :background) - (values nil (tk::get-values w :background))) - ;; Now we have to convert into CLIM colors. - (flet ((ccm (x) - (multiple-value-bind - (r g b) - (tk::query-color (tk::default-colormap (port-display port)) x) - (let ((x #.(1- (ash 1 16)))) - (make-rgb-color - (/ r x) - (/ g x) - (/ b x)))))) - (when foreground - (unless (medium-foreground pane) - (setf (medium-foreground pane) (ccm foreground)))) - (unless (medium-background pane) - (setf (medium-background pane) (ccm background)))))))) + (shellp (typep w 'tk::shell))) + ;;; Make sure we dont have a pixmp + (when (typep w 'xt::xt-root-class) + ;;-- What about the case when there is a pixmap + (multiple-value-bind + (foreground background) + (if shellp + (values nil (tk::get-values w :background)) + (tk::get-values w :foreground :background)) + ;; Now we have to convert into CLIM colors. + (flet ((ccm (x) + (multiple-value-bind + (r g b) + (tk::query-color (tk::default-colormap (port-display port)) x) + (let ((x #.(1- (ash 1 16)))) + (make-rgb-color + (/ r x) + (/ g x) + (/ b x)))))) + (when foreground + (unless (medium-foreground pane) + (setf (medium-foreground pane) (ccm foreground)))) + (unless (medium-background pane) + (setf (medium-background pane) (ccm background))))))))) ;;;--- Gadget activation deactivate @@ -1040,5 +1045,44 @@ widget)) +(defmethod port-force-output ((port xt-port)) + (x11:xflush (port-display port))) + + + +;;; + + +(defclass xt-geometry-manager () + ;; --- This is probably all + ;; composites excepts drawing-area and shell + () + (:documentation "These are all parents that have strong feelings +about their children")) + + +(defmethod update-mirror-transformation-1 ((port port) sheet + (parent xt-geometry-manager)) + nil) + +(defmethod update-mirror-region-1 ((port port) sheet + (parent xt-geometry-manager)) + nil) + + +(defmethod update-mirror-transformation-1 :after ((port port) + (sheet xt-geometry-manager) + (parent t)) + (update-geo-manager-sheet-children sheet)) + +(defmethod update-mirror-region-1 :after ((port port) + (sheet xt-geometry-manager) + (parent t)) + (update-geo-manager-sheet-children sheet)) +(defmethod update-geo-manager-sheet-children (geo-manager) + (dolist (child (sheet-children geo-manager)) + ;;--- Yuck! + (when (typep child 'mirrored-sheet-mixin) + (mirror-region-updated (port geo-manager) child)))) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 72ca6a18..80c14fde 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.12 92/05/07 13:10:47 cer Exp Locker: cer $ +;; $fiHeader: callbacks.lisp,v 1.13 92/05/13 17:10:11 cer Exp Locker: cer $ (in-package :tk) @@ -122,6 +122,7 @@ ;; OpenLook Callbacks ("sliderMoved" slider-moved) ("select") + ("unselect") ))) (defun convert-callback-name (x) diff --git a/tk/event.lisp b/tk/event.lisp index a66e382a..0c13a2c3 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -1,4 +1,4 @@ -;; -*- mode: common-lisp; package: tk -*- + ;; -*- mode: common-lisp; package: tk -*- ;; ;; -[]- ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.8 92/04/15 11:44:40 cer Exp Locker: cer $ +;; $fiHeader: event.lisp,v 1.9 92/04/21 20:27:28 cer Exp $ (in-package :tk) @@ -84,7 +84,6 @@ 1 0))) - (defparameter *match-event-sequence-and-types-address* (register-function 'match-event-sequence-and-types)) diff --git a/tk/font.lisp b/tk/font.lisp index 4b830eb9..5d92d415 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: font.lisp,v 1.10 92/04/21 20:27:29 cer Exp Locker: cer $ +;; $fiHeader: font.lisp,v 1.11 92/04/28 09:25:00 cer Exp $ (in-package :tk) @@ -50,12 +50,11 @@ (defmethod font-width (font) (x11::xfontstruct-max-bounds-width font)) - + (defmethod font-height (font) (+ (font-ascent font) (font-descent font))) - (defmethod font-ascent (font) (x11:xfontstruct-ascent font)) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index f8e0a867..92d77173 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign.lisp,v 1.10 92/04/21 20:27:30 cer Exp $ +;; $fiHeader: foreign.lisp,v 1.11 92/05/13 17:10:13 cer Exp Locker: cer $ (in-package :tk) @@ -54,23 +54,21 @@ (defun open-display (&key (context (create-application-context)) (host nil) - (name "clim") - (class "Clim") + (application-name "clim") + (application-class "Clim") (options 0) (num-options 0) (argc 0) (argv 0)) (let ((d (with-ref-par ((argc argc)) (xt_open_display context - (if host - host - 0) - name - class - options - num-options - argc - argv)))) + (or host 0) + application-name + application-class + options + num-options + argc + argv)))) (if (zerop d) (error "cannot open the display: ~A" host) d))) diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 11e1ad82..0d9d30c3 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.14 92/05/12 18:24:17 cer Exp Locker: cer $ +;; $fiHeader: gcontext.lisp,v 1.15 92/05/13 17:10:17 cer Exp Locker: cer $ (in-package :tk) @@ -51,7 +51,6 @@ (dash-offset :int) (dashes :char))) - (defconstant *gcontext-bit-mask* '(function plane-mask foreground background line-width line-style cap-style join-style fill-style @@ -60,6 +59,7 @@ arc-mode))) + (eval-when (compile eval) #+ignore (defun gcontext-component-to-slot-definition (x) @@ -177,7 +177,6 @@ (intern (substitute #\_ #\- (symbol-name (lispify-tk-name name))))) - ;;; Accessors for the gc (define-gc-accessor function (encode-function decode-function)) @@ -262,11 +261,11 @@ (define-gc-accessor subwindow-mode (encode-enum decode-enum) '(:clip-by-children :include-inferiors)) - (define-gc-accessor graphics-exposures (encode-enum decode-enum) '(:off :on)) (define-gc-accessor clip-x-origin (encode-int16 decode-int16)) (define-gc-accessor clip-y-origin (encode-int16 decode-int16)) + (define-gc-accessor dash-offset (encode-card16 decode-card16)) (define-gc-accessor arc-mode (encode-enum decode-enum) '(:chord :pie-slice)) @@ -314,7 +313,6 @@ gc nv)) - (defmethod (setf gcontext-clip-mask) ((nv cons) (gc gcontext)) (let ((r (x11:make-xrectangle))) (setf (x11:xrectangle-x r) (first nv) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 89c12f44..5973ba89 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,12 +20,12 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.8 92/04/03 12:03:58 cer Exp $ +;; $fiHeader: load-ol.lisp,v 1.9 92/05/07 13:10:50 cer Exp Locker: cer $ (in-package :tk) -(defvar *libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") -(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") +(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a") +(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") (defun load-from-ol () (x11::load-undefined-symbols-from-library @@ -45,9 +45,9 @@ "_class_extended" "__unpack_integer" ) - (list *libxol-pathname* - *libxt-pathname* - x11::*libx11-pathname*))) + (list sys::*libxol-pathname* + sys::*libxt-pathname* + sys::*libx11-pathname*))) (load-from-ol) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index bdab8e7d..b77b098c 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,22 +20,23 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.11 92/05/07 13:10:51 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.12 92/05/13 17:10:19 cer Exp Locker: cer $ (in-package :tk) ;;;; -(defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") -(defvar *libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") -(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") + +(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a") +(defvar sys::*libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a") (defun load-from-xm () (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")) (load "MyDrawingA.o" - :system-libraries (list *libxm-pathname* *libxt-pathname* - x11::*libx11-pathname*) + :system-libraries (list sys::*libxm-pathname* + sys::*libxt-pathname* + sys::*libx11-pathname*) :print t)) (x11::load-undefined-symbols-from-library "stub-motif.o" @@ -53,9 +54,9 @@ "_class_extended" "__unpack_integer" ) - (list *libxm-pathname* - *libxt-pathname* - x11::*libx11-pathname*))) + (list sys::*libxm-pathname* + sys::*libxt-pathname* + sys::*libx11-pathname*))) (load-from-xm) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index d9660d49..840730d4 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.16 92/05/07 13:10:52 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.17 92/05/13 17:10:22 cer Exp Locker: cer $ (in-package :tk) diff --git a/tk/ol-callbacks.lisp b/tk/ol-callbacks.lisp index 05e867dc..ad73f4ab 100644 --- a/tk/ol-callbacks.lisp +++ b/tk/ol-callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-callbacks.lisp,v 1.5 92/03/09 17:40:50 cer Exp $ +;; $fiHeader: ol-callbacks.lisp,v 1.6 92/04/21 20:27:35 cer Exp Locker: cer $ (in-package :tk) @@ -57,3 +57,18 @@ (defmethod spread-callback-data (widget data (type (eql 'slider-moved))) (values)) + +(defun add-ol-callback (widget name type function &rest args) + (ol_add_callback widget name *callback-handler-address* + (caar (push + (list (new-callback-id) (cons function args) type) + (widget-callback-data widget))))) + + +(defmethod spread-callback-data ((widget shell) data (type (eql :wm-protocol))) + ;;; I dunno why this works but it does + (ecase (logand 15 (ol-wm-protocol-verify-message-type data)) + (1 :wm-delete-window) ; 80000001 + (2 :wm-save-yourself) ; 80000002 + (4 :wm-take-focus) ; 80000004 + )) diff --git a/tk/ol-defs.lisp b/tk/ol-defs.lisp index edbd5247..12ca3bf4 100644 --- a/tk/ol-defs.lisp +++ b/tk/ol-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-defs.lisp,v 1.1 92/04/21 16:40:05 cer Exp Locker: cer $ +;; $fiHeader: ol-defs.lisp,v 1.2 92/04/21 20:27:36 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -43,3 +43,6 @@ (width xt-dimension) (height xt-dimension)) +(def-c-type (ol-wm-protocol-verify :no-defuns) :struct + (message-type :int) + (event * x11:xevent)) diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp index 038ae3dd..8a279ce8 100644 --- a/tk/ol-funs.lisp +++ b/tk/ol-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-funs.lisp,v 1.1 92/04/21 16:40:06 cer Exp Locker: cer $ +;; $fiHeader: ol-funs.lisp,v 1.2 92/04/21 20:27:37 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -42,3 +42,9 @@ (defforeign 'ol_set_va_display_warning_msg_handler :entry-point "_OlSetVaDisplayWarningMsgHandler") +(defforeign 'ol_add_callback :entry-point "_OlAddCallback") + +(defforeign 'ol_set_input_focus :entry-point "_OlSetInputFocus") + +(defforeign 'ol_menu_post :entry-point "_OlMenuPost") +(defforeign 'ol_menu_popdown :entry-point "_OlMenuPopdown") diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index 0730f80f..04648db7 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.11 92/04/21 20:27:38 cer Exp Locker: cer $ +;; $fiHeader: ol-init.lisp,v 1.12 92/05/07 13:10:58 cer Exp Locker: cer $ (in-package :tk) @@ -69,6 +69,7 @@ (defvar *ol-done* nil) (unless *ol-done* + (compile-file "test/test") (ol-initialize) (xt-initialize) (define-toolkit-classes diff --git a/tk/resources.lisp b/tk/resources.lisp index 259acd0d..c4d89de4 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.20 92/05/07 13:10:59 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.21 92/05/13 17:10:25 cer Exp Locker: cer $ (in-package :tk) @@ -606,3 +606,11 @@ ;;-- Should check to see if its registered (integer value))) + +;;;--- Dont ask this is what OLIT sez the label-image of a oblong +;;;--- button is. I know why! its because its a f*cking image (rather +;;;--- than a pixmap + +(defmethod convert-resource-out ((parent t) (typep (eql 'pointer)) value) + value) + diff --git a/tk/widget.lisp b/tk/widget.lisp index f7a26e83..4f264103 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.18 92/04/21 20:27:42 cer Exp $ +;; $fiHeader: widget.lisp,v 1.19 92/05/13 17:10:27 cer Exp Locker: cer $ (in-package :tk) @@ -89,9 +89,7 @@ (xt_destroy_widget widget)) (defun popup (shell) - (xt_popup shell - 0)) - + (xt_popup shell 0)) (defun popdown (shell) (xt_popdown shell)) @@ -248,15 +246,12 @@ ;; Could not think of anywhere better! -(defun setup (&optional (hostspec "localhost:0")) +(defun initialize-toolkit (&rest args) (let* ((context (create-application-context)) - (display (make-instance 'display - :host hostspec - :context context)) + (display (apply #'make-instance 'display + :context context + args)) (app (app-create-shell :display display :widget-class 'application-shell))) (values context display app))) -(defun initialize-motif-toolkit (hostspec) - (setup hostspec)) - diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 9cb872e6..18047c8a 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.16 92/04/21 20:27:43 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.17 92/05/13 17:10:28 cer Exp Locker: cer $ (in-package :tk) @@ -121,6 +121,18 @@ attrs) (x11:xwindowattributes-depth attrs))) + +(defmethod window-map-state ((window window)) + (let ((attrs (x11:make-xwindowattributes))) + (x11:xgetwindowattributes (object-display window) + window + attrs) + (ecase (x11:xwindowattributes-map-state attrs) + (0 :unmapped) + (1 :unviewable) + (2 :viewable)))) + + (defmethod drawable-width ((window window)) (window-width window)) (defmethod drawable-height ((window window)) @@ -488,3 +500,17 @@ dest-y (image-width image) (image-height image)))) + +(defun image-from-pixmap (pixmap) + (x11:xgetimage + (object-display pixmap) + pixmap + 0 + 0 + (pixmap-width pixmap) + (pixmap-height pixmap) + #xff ; plane-mask + x11:xypixmap)) + +(defun destroy-image (image) + (x11:xdestroyimage image)) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index d4ecf1a1..e6a1c95b 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.3 92/04/21 20:27:51 cer Exp Locker: cer $ +;; $fiHeader: xt-funs.lisp,v 1.4 92/05/07 13:11:03 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp index 534b33d6..b55e7219 100644 --- a/tk/xt-init.lisp +++ b/tk/xt-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-init.lisp,v 1.5 92/04/21 20:27:52 cer Exp Locker: cer $ +;; $fiHeader: xt-init.lisp,v 1.6 92/05/07 13:11:04 cer Exp Locker: cer $ (in-package :tk) @@ -30,6 +30,5 @@ (defun xt-initialize () (unless *xt-done* (xt_toolkit_initialize) - (define-toolkit-classes *intrinsic-classes*) (setq *xt-done* t))) diff --git a/utils/autoconstructor.lisp b/utils/autoconstructor.lisp index ea6f60fd..f7d87e25 100644 --- a/utils/autoconstructor.lisp +++ b/utils/autoconstructor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: autoconstructor.lisp,v 1.2 92/01/31 14:52:23 cer Exp $ +;; $fiHeader: autoconstructor.lisp,v 1.3 92/02/24 13:05:05 cer Exp $ ;;; ;;; Copyright (c) 1990 by Xerox Corporation. All rights reserved. @@ -96,7 +96,7 @@ (eval-when (compile load eval) (proclaim '(notinline ,name)) (proclaim '(function ,name))) - #+Ignore ;; See if FUNCTION proclamation is sufficient. + #+++ignore ;; See if FUNCTION proclamation is sufficient. (defun ,name (&rest args) (declare (dynamic-extent args) (ignore args)) @@ -196,7 +196,7 @@ ;; Can't use PCL's iterate tool (dorest (sublist supplied-initargs cddr) (collect (first sublist))) - #+ignore + #+++ignore (iterate ((name (pcl::*list-elements supplied-initargs :by #'cddr))) (collect name)))))) diff --git a/utils/cl-stream-classes.lisp b/utils/cl-stream-classes.lisp index 60ae5d1a..583ab9e6 100644 --- a/utils/cl-stream-classes.lisp +++ b/utils/cl-stream-classes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cl-stream-classes.lisp,v 1.2 92/01/31 15:07:17 cer Exp $ +;; $fiHeader: cl-stream-classes.lisp,v 1.3 92/02/24 13:05:09 cer Exp $ (in-package :clim-utils) @@ -74,6 +74,7 @@ (define-class-and-predicate fundamental-binary-output-stream nil (fundamental-output-stream fundamental-binary-stream)) +#-Cloe-Runtime ;not there yet (define-stream-predicate-trampoline open-stream-p nil ;;--- For now. PW will dig up the right predicate :lucid-kludge (lambda (stream) (streamp stream))) diff --git a/utils/clos.lisp b/utils/clos.lisp index efc8389e..23a5e2b9 100644 --- a/utils/clos.lisp +++ b/utils/clos.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clos.lisp,v 1.4 92/03/04 16:20:08 cer Exp $ +;; $fiHeader: clos.lisp,v 1.5 92/04/15 11:45:25 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -147,7 +147,7 @@ ;;; DEFGENERIC ... because it isn't there. ;;; -#+ignore +#+++ignore (defmacro defgeneric (function-specifier lambda-list &rest options) (declare (ignore lambda-list)) (let ((expansion nil) @@ -201,7 +201,7 @@ (defun collect-root-classes (&optional package) (w::with-collection (let ((classes (mapcar #'find-class (classes-in-package - (or package 'silica) t)))) + (or package :silica) t)))) (dolist (class classes) (if (not (intersection (pcl::class-local-supers class) classes)) diff --git a/utils/defpackage.lisp b/utils/defpackage.lisp index 6109d31b..748053a5 100644 --- a/utils/defpackage.lisp +++ b/utils/defpackage.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: (CLIM-LISP :USE LISP :COLON-MODE :EXTERNAL); Base: 10; Lowercase: Yes -*- -;; $fiHeader: defpackage.lisp,v 1.4 92/03/04 16:20:11 cer Exp $ +;; $fiHeader: defpackage.lisp,v 1.5 92/03/10 10:11:49 cer Exp $ "Copyright (c) 1989, 1990, 1991 by International Lisp Associates. All Rights Reserved." @@ -83,7 +83,7 @@ :export #'(lambda (option-arg) `(export-1 ',option-arg ,package-var) - #+ignore + #+++ignore `(progn ,@(mapcar #'(lambda (x) `(export (list (intern ',x ,package-var)) ,package-var)) diff --git a/utils/defun.lisp b/utils/defun.lisp index 8e84284b..1168d47b 100644 --- a/utils/defun.lisp +++ b/utils/defun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: defun.lisp,v 1.3 92/02/24 13:05:32 cer Exp $ +;; $fiHeader: defun.lisp,v 1.4 92/03/04 16:20:14 cer Exp $ (in-package :clim-utils) @@ -273,8 +273,8 @@ ,@documentation ,@new-body)))) (lisp:defun generate-dynamic-function-declarations (functions) - #-Ignore (declare (ignore functions)) - #+Ignore `((declare (dynamic-extent ,@(mapcar #'(lambda (fn) `#',fn) functions))))) + #---ignore (declare (ignore functions)) + #+++ignore `((declare (dynamic-extent ,@(mapcar #'(lambda (fn) `#',fn) functions))))) (defmacro flet (functions &body body &environment env) (construct-local-function-body 'lisp:flet functions body env)) diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 4dc186d8..5751f826 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -20,11 +20,12 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: excl-verification.lisp,v 1.8 92/04/03 12:04:19 cer Exp Locker: cer $ +;; $fiHeader: excl-verification.lisp,v 1.9 92/04/10 14:26:41 cer Exp Locker: cer $ (in-package :sys) -(assert (eq excl::*current-case-mode* :case-insensitive-lower)) +(eval-when (compile) + (assert (member excl::*current-case-mode* '(:case-insensitive-lower :case-insensitive-upper)))) (eval-when (compile load eval) (pushnew :clim *features*) @@ -58,4 +59,4 @@ You do not have patches ~{~S ~}" (si::rcsnote "CLIM 2.0.alpha.0" - "$fiHeader: $") + "$fiHeader: excl-verification.lisp,v 1.9 92/04/10 14:26:41 cer Exp Locker: cer $") diff --git a/utils/lisp-package-fixups.lisp b/utils/lisp-package-fixups.lisp index c07444ba..0c074422 100644 --- a/utils/lisp-package-fixups.lisp +++ b/utils/lisp-package-fixups.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10 -*- -;; $fiHeader: lisp-package-fixups.lisp,v 1.3 92/02/16 20:55:12 cer Exp $ +;; $fiHeader: lisp-package-fixups.lisp,v 1.4 92/02/24 13:05:39 cer Exp $ #+ANSI-90 (in-package :cl-user) @@ -63,12 +63,11 @@ (old-name (package-name package)) (old-nicknames (package-nicknames package))) (let (#+Allegro (excl::*enable-package-locked-errors* nil)) - (rename-package - package primary-name - (remove primary-name - (union (cons old-name old-nicknames) required-nicknames - :test #'string-equal) - :test #'string-equal)))))) + (rename-package + package old-name + (union (list* primary-name old-nicknames) + required-nicknames + :test #'string-equal)))))) (clean-up-package "LISP" "COMMON-LISP" '("CL")) (clean-up-package "USER" "COMMON-LISP-USER" '("CL-USER"))) ) ;eval-when diff --git a/utils/lucid-stream-functions.lisp b/utils/lucid-stream-functions.lisp index 400df62f..4e7273e8 100644 --- a/utils/lucid-stream-functions.lisp +++ b/utils/lucid-stream-functions.lisp @@ -5,7 +5,7 @@ "Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved. Portions copyright (c) 1989, 1990 International Lisp Associates." -;;; $fiHeader: lucid-stream-functions.lisp,v 1.3 92/02/24 13:34:13 cer Exp $ +;;; $fiHeader: lucid-stream-functions.lisp,v 1.4 92/03/04 16:20:18 cer Exp $ ;;; All of this is taken from the STREAM-DEFINITION-BY-USER proposal to ;;; the X3J13 committee, made by David Gray of TI on 22 March 1989. No ;;; Lisp implementation yet supports this proposal, so we implement it @@ -238,8 +238,8 @@ (defmacro %string-stream (stream &body body) `(let (result - (new-stream (cond ((typep ,stream 'clim-internals::accept-values-stream) - (slot-value ,stream 'clim-internals::stream)) + (new-stream (cond ((encapsulating-stream-p ,stream) + (encapsulating-stream-stream ,stream)) ((typep ,stream 'fundamental-stream) ,stream) (t @@ -263,8 +263,8 @@ (redefine-lucid-io-function lcl:underlying-stream (stream &optional direction (recurse t) exact-same) - (if (typep stream 'clim-internals::accept-values-stream) - (slot-value stream 'clim-internals::stream) + (if (encapsulating-stream-p stream) + (encapsulating-stream-stream stream) stream)) (redefine-lucid-io-function lisp:prin1 (object &optional (stream *standard-output*)) @@ -359,8 +359,8 @@ (lcl:defadvice (lisp:y-or-n-p stream-wrapper) (&optional format-string &rest args) (declare (dynamic-extent args)) - (if (and (system:standard-object-p *QUERY-IO*) - (typep *QUERY-IO* 'fundamental-stream)) + (if (and (system:standard-object-p *query-io*) + (typep *query-io* 'fundamental-stream)) (clim:accept 'clim:boolean :prompt (apply #'lisp::format nil format-string args)) (lcl:apply-advice-continue format-string args))) @@ -381,6 +381,6 @@ (let ((stream (if (eq stream t) *standard-output* stream))) (if (and (system:standard-object-p stream) (typep stream 'fundamental-stream)) - (apply #'clim:format stream control-string args) + (apply #'clim:format stream control-string args) (lcl:apply-advice-continue stream control-string args)))) diff --git a/utils/packages.lisp b/utils/packages.lisp index 14b42b31..9a0ca744 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.15 92/05/07 13:11:40 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.16 92/05/13 17:10:42 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1485,12 +1485,6 @@ area areap coordinate - - check-box - check-box-current-selection - check-box-pane - check-box-selections - ellipse ellipse-center-point ellipse-center-point* @@ -1743,7 +1737,6 @@ note-sheet-grafted note-sheet-region-changed note-sheet-transformation-changed - note-viewport-position-changed permanent-medium-sheet-output-mixin pointer-button-event pointer-button-hold-event @@ -1765,8 +1758,6 @@ poll-pointer port port-keyboard-input-focus - port-notify-user - port-select-file port-properties port-server-path port-type @@ -2268,7 +2259,6 @@ form frame-document-highlighted-presentation funcall-presentation-generic-function - gadget-active-p gadget-dialog-view gadget-menu-view gadget-view @@ -2290,7 +2280,6 @@ or pathname pointer-documentation-view - port-dialog-view present present-method present-to-string @@ -2399,13 +2388,13 @@ ;; Menus draw-standard-menu + frame-manager-menu-choose menu-choose menu-choose-from-drawer menu-item menu-item-display menu-item-options menu-item-value - port-menu-choose print-menu-item with-menu @@ -2415,6 +2404,7 @@ accept-values-resynchronize accepting-values display-exit-boxes + frame-manager-dialog-view invoke-accept-values-command-button ;; Command processor @@ -2487,7 +2477,7 @@ user-command-table with-command-table-keystrokes - ;; Application frames + ;; Application frames and frame managers *application-frame* *default-frame-manager* *pointer-documentation-output* @@ -2521,6 +2511,8 @@ frame-maintain-presentation-histories frame-manager frame-manager-frames + frame-manager-notify-user + frame-manager-select-file frame-name frame-named-panes frame-pane @@ -2567,6 +2559,15 @@ with-application-frame with-frame-manager + ;; Progress notes + *current-progress-note* + dolist-noting-progress + dotimes-noting-progress + note-progress + note-progress-in-phases + noting-progress + progress-note-name + ;; Panes +fill+ allocate-space @@ -2585,11 +2586,12 @@ label-pane labelled lowering - make-clim-pane + make-clim-stream-pane make-pane make-pane-1 make-space-requirement note-space-requirements-changed + note-viewport-position-changed outlined-pane outlining pane @@ -2632,11 +2634,16 @@ activate-callback activate-gadget armed-callback + check-box + check-box-current-selection + check-box-pane + check-box-selections deactivate-gadget disarmed-callback drag-callback gadget gadget-activate-callback + gadget-active-p gadget-armed-callback gadget-client gadget-disarmed-callback @@ -2655,27 +2662,17 @@ gadget-show-value-p gadget-value gadget-value-changed-callback - gadget-show-value-p - - ;; this should go somewhere - - slider-decimal-places - set-gadget-items - set-gadget-name-key - set-gadget-value-key - set-gadget-test + label-pane + labelled-gadget-mixin list-pane list-pane-mode - option-pane - - label-pane - labelled-gadget menu-bar menu-button menu-button-pane note-gadget-activated note-gadget-deactivated - oriented-gadget + option-pane + oriented-gadget-mixin push-button push-button-pane push-button-show-as-default-p @@ -2684,9 +2681,16 @@ radio-box-pane radio-box-selections scroll-bar + scroll-bar-current-size + scroll-bar-current-value scroll-bar-drag-callback scroll-bar-pane + set-gadget-items + set-gadget-name-key + set-gadget-test + set-gadget-value-key slider + slider-decimal-places slider-pane text-editor text-editor-pane @@ -3320,9 +3324,6 @@ frame-shell frame-wrapper gadget-alignment - gadget-range - gadget-range* - gadget-show-value-p get-drawing-function-description get-port-canonical-gesture-spec grid-pane @@ -3331,7 +3332,6 @@ label-button-pane layout-mixin line-editor-pane - list-pane make-frame-manager make-medium medium-+y-upward-p @@ -3350,6 +3350,7 @@ mute-repainting-mixin non-drawing-option-keywords one-of-pane + option-pane parse-gesture-spec permanent-medium-sheet-output-mixin pointer-press-event @@ -3374,8 +3375,6 @@ port-pointer port-process port-undefined-text-style - port-write-char-1 - port-write-string-1 process-event-locally radio-button-pane raise-mirror @@ -3398,9 +3397,8 @@ standard-sheet-input-mixin standardize-text-style standardize-text-style-1 - stream-glyph-for-character + stream-scan-character-for-writing stream-scan-string-for-writing - stream-write-string-1 string-height string-width text-style-scale diff --git a/utils/reader.lisp b/utils/reader.lisp index 64fead9d..c505f157 100644 --- a/utils/reader.lisp +++ b/utils/reader.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: reader.lisp,v 1.5 92/02/24 13:05:53 cer Exp $ +;; $fiHeader: reader.lisp,v 1.6 92/03/10 10:11:58 cer Exp $ (in-package :clim-utils) @@ -44,7 +44,7 @@ (catch 'stop ;; here's where we install #\} as the terminating character ;; for #{ - (with-macro-character (#\} '|READ-}|) + (with-macro-character (#\} #'|READ-}|) (loop (let ((feature (read stream t nil t))) (when found-otherwise diff --git a/utils/regions.lisp b/utils/regions.lisp index 13998c10..5ca23e3b 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: regions.lisp,v 1.7 92/04/21 16:12:47 cer Exp Locker: cer $ +;; $fiHeader: regions.lisp,v 1.8 92/05/07 13:11:44 cer Exp $ (in-package :clim-utils) @@ -584,8 +584,8 @@ (defmethod bounding-rectangle-set-edges ((rectangle standard-bounding-rectangle) left top right bottom) (declare (type real left top right bottom)) - #+ignore (assert (<= left right)) - #+ignore (assert (<= top bottom)) + #+++ignore (assert (<= left right)) + #+++ignore (assert (<= top bottom)) (with-slots ((bl left) (bt top) (br right) (bb bottom)) rectangle (setq bl (coordinate left) bt (coordinate top) diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 0adf11d1..179e9078 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ffi.lisp,v 1.10 92/04/15 11:45:43 cer Exp Locker: cer $ +;; $fiHeader: ffi.lisp,v 1.11 92/04/21 20:28:01 cer Exp $ (in-package :x11) @@ -89,6 +89,7 @@ (foo-slot slot)) slots)) (error ":overlays used in a way we cannot handle")))))))) + (defun trans-slot-type (type) diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp index fdc7b073..5fc87e99 100644 --- a/xlib/load-xlib.lisp +++ b/xlib/load-xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xlib.lisp,v 1.2 92/03/30 17:52:17 cer Exp $ +;; $fiHeader: load-xlib.lisp,v 1.3 92/05/13 17:10:47 cer Exp Locker: cer $ (in-package :x11) @@ -48,10 +48,11 @@ :system-libraries libraries :print t)))) -(defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") +(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a") (unless (ff:get-entry-point (ff:convert-to-lang "lisp_XDrawString")) - (load "xlibsupport.o" :system-libraries (list *libx11-pathname*) :print t)) + (load "xlibsupport.o" :system-libraries (list sys::*libx11-pathname*) :print t)) + (x11::load-undefined-symbols-from-library "stub-x.o" (x11::symbols-from-file "misc/undefinedsymbols") @@ -59,5 +60,5 @@ "__prod_b10000" "__carry_out_b10000" "__prod_65536_b10000") - (list x11::*libx11-pathname*)) + (list sys::*libx11-pathname*)) diff --git a/xlib/pkg.lisp b/xlib/pkg.lisp index e5550106..72c7412f 100644 --- a/xlib/pkg.lisp +++ b/xlib/pkg.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.5 92/02/24 13:06:36 cer Exp Locker: cer $ +;; $fiHeader: pkg.lisp,v 1.6 92/03/09 17:41:34 cer Exp Locker: cer $ (defpackage :x11 diff --git a/xlib/x11-keysyms.lisp b/xlib/x11-keysyms.lisp index 26a88e1a..c69c35fc 100644 --- a/xlib/x11-keysyms.lisp +++ b/xlib/x11-keysyms.lisp @@ -18,11 +18,11 @@ ;; Commercial Software developed at private expense as specified in FAR ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. +;; ;; (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design ;; patents pending in the U.S. and foreign countries. OPEN LOOK is a ;; registered trademark of USL. Used by written permission of the owners. -;; ;; (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered ;; trademark of Bigelow & Holmes. Permission to use the Lucida ;; trademark is hereby granted only in association with the images @@ -44,8 +44,10 @@ ;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION ;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. +;;; $fiHeader: x11-keysyms.lisp,v 1.7 92/04/21 20:34:41 cer Exp $ + ;;;@(#)x11-keysym.lisp 1.3 11/29/90 -;;; $fiHeader$ + (in-package :x11) -- GitLab