diff --git a/Makefile b/Makefile index ff93d378146d8e4f1b5d0fd9d59c19a60b4d0da2..20fadb8715e641d8efd5dd4783609f24d0fd21cf 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,8 @@ -# $fiHeader: Makefile,v 1.16 92/03/10 10:13:11 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.17 92/03/10 16:00:50 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # -CL = /net/sparky/usr/tech/jdi/4.1/src/dcl +CL = /vapor/usr/tech/cer/cl/src/dcl DUMP-CL = $(CL) CLOPTS = -qq @@ -23,7 +23,7 @@ DEVICE = /dev/null RM = /bin/rm CAT = /bin/cat ECHO = /bin/echo -MV = mv +MV = mv-nfs TAGS = /usr/fi/lib/emacs/etc/etags TMP = /usr/tmp @@ -131,7 +131,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ XLIB-CLIM-OBJS = xlib/pkg.fasl -XT-CLIM-OBJS = tk/pkg.fasl \ +XT-TK-OBJS = tk/pkg.fasl \ tk/foreign-obj.fasl \ tk/macros.fasl \ tk/xlib.fasl \ @@ -149,7 +149,7 @@ XT-CLIM-OBJS = tk/pkg.fasl \ tk/xt-classes.fasl \ tk/xt-init.fasl -XM-CLIM-OBJS = tk/xm-classes.fasl \ +XM-TK-OBJS = tk/xm-classes.fasl \ tk/xm-init.fasl \ tk/xm-widgets.fasl \ tk/xm-font-list.fasl \ @@ -157,6 +157,11 @@ XM-CLIM-OBJS = tk/xm-classes.fasl \ tk/convenience.fasl \ tk/make-widget.fasl +OL-CLIM-OBJS = tk/ol-classes.fasl \ + tk/ol-init.fasl \ + tk/ol-callbacks.fasl \ + tk/make-widget.fasl + MOTIF-CLIM-OBJS = xm-silica/pkg.fasl \ xm-silica/xt-silica.fasl \ xm-silica/xm-silica.fasl \ @@ -171,10 +176,6 @@ MOTIF-CLIM-OBJS = xm-silica/pkg.fasl \ xm-silica/xt-pixmaps.fasl \ xm-silica/xm-cursor.fasl -OL-CLIM-OBJS = tk/ol-classes.fasl \ - tk/ol-init.fasl \ - tk/ol-callbacks.fasl \ - tk/make-widget.fasl OPENLOOK-CLIM-OBJS = xm-silica/pkg.fasl \ xm-silica/xt-silica.fasl \ @@ -188,30 +189,54 @@ OPENLOOK-CLIM-OBJS = xm-silica/pkg.fasl \ xm-silica/ol-gadgets.fasl \ xm-silica/xt-pixmaps.fasl -MOTIF-OBJS = $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS) \ - $(XLIB-CLIM-OBJS) $(XT-CLIM-OBJS) $(XM-CLIM-OBJS) \ - $(MOTIF-CLIM-OBJS) +GENERIC-OBJS= $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS) +XT-OBJS= $(XLIB-CLIM-OBJS) $(XT-TK-OBJS) +MOTIF-OBJS = $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS) +OPENLOOK-OBJS = #(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) -OPENLOOK-OBJS = $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) \ - $(CLIM-STANDALONE-OBJS) $(XLIB-CLIM-OBJS) $(XT-CLIM-OBJS) \ - $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) +default: all-xm -default: compile clim +all-xm: compile-xm cat-xm clim-xm +all-ol: compile-ol cat-ol clim-ol -all: compile cat clim +# Compilation -compile: FORCE +compile-xm: FORCE $(ECHO) " \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch -clim.fasl: $(MOTIF-OBJS) - $(CAT) $(MOTIF-OBJS) > $(TMP)/clim.fasl_`whoami` - $(MV) $(TMP)/clim.fasl_`whoami` clim.fasl - ls -lt clim.fasl >> Clim-sizes.n - ls -lt clim.fasl +compile-ol: FORCE + $(ECHO) " \ + (setq *ignore-package-name-case* t) \ + (set-case-mode :case-insensitive-lower) \ + (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ + (load \"misc/compile-ol.lisp\")" | $(CL) $(CLOPTS) -batch + +# Concatenation + +cat-xm: climg.fasl climxm.fasl clim-debug.fasl +cat-ol: climg.fasl climol.fasl clim-debug.fasl + +climg.fasl : $(GENERIC-OBJS) $(XT-OBJS) + $(CAT) $(GENERIC-OBJS) $(XT-OBJS) > $(TMP)/clim.fasl_`whoami` + $(MV) $(TMP)/clim.fasl_`whoami` climg.fasl + ls -lt climg.fasl >> Clim-sizes.n + ls -lt climg.fasl + +climxm.fasl : $(MOTIF-OBJS) + $(CAT) $(MOTIF-OBJS) > $(TMP)/clim.fasl_`whoami` + $(MV) $(TMP)/clim.fasl_`whoami` climxm.fasl + ls -lt climxm.fasl >> Clim-sizes.n + ls -lt climxm.fasl + +climol.fasl : $(OPENLOOK-OBJS) + $(CAT) $(OPENLOOK-OBJS) > $(TMP)/clim.fasl_`whoami` + $(MV) $(TMP)/clim.fasl_`whoami` climol.fasl + ls -lt climol.fasl >> Clim-sizes.n + ls -lt climol.fasl echo-fasls: ls -lt $(MOTIF-OBJS) > /tmp/foo @@ -222,9 +247,9 @@ clim-debug.fasl: $(DEBUG-OBJS) ls -lt clim-debug.fasl >> Clim-sizes.n ls -lt clim-debug.fasl -cat: clim.fasl clim-debug.fasl +# Building -clim: FORCE +clim-xm: FORCE -$(RM) $(CLIM) $(ECHO) " \ (setq *ignore-package-name-case* t) \ @@ -235,6 +260,19 @@ clim: FORCE ls -lt $(CLIM) >> Clim-sizes.n ls -lt $(CLIM) + +clim-ol: FORCE + -$(RM) $(CLIM) + $(ECHO) " \ + (setq *ignore-package-name-case* t) \ + (set-case-mode :case-insensitive-lower) \ + (load \"misc/dev-load-ol.lisp\") \ + (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch + $(MV) $(TMP)/clim.temp_`whoami` $(CLIM) + ls -lt $(CLIM) >> Clim-sizes.n + ls -lt $(CLIM) + + clim-small: FORCE $(ECHO) " \ (setq *ignore-package-name-case* t) \ @@ -245,11 +283,8 @@ clim-small: FORCE ls -lt $(CLIM-SMALL) >> Clim-sizes.n ls -lt $(CLIM-SMALL) -xm-composer: - cd tk ; $(MAKE) xm-composer -xm-dcl: - cd tk ; $(MAKE) xm-dcl +# Misc clean: find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim.fasl @@ -266,7 +301,7 @@ swm-tape: dist: tar -cf - \ - */*.lisp *.lisp Makefile */Makefile \ + */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \ misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.motif \ | compress > Dist/src.tar.Z @@ -279,3 +314,62 @@ echo_src_files: FORCE: +################## Lower level Makefile stuff + +CL_SRC=/vapor/usr/tech/cer/cl/src +OPENWINHOME=/usr/openwin-3.0 + +#MOTIFHOME=/usr/motif +#MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm.a +#XLIBS=$(MOTIFHOME)/usr/lib/libXt.a $(MOTIFHOME)/usr/lib/libX11.a + +#MOTIFLIB=/x11/motif-1.1/lib/Xm/libXm.a +#XLIBS=/x11/R4/src/mit/lib/Xt/libXt_d.a /x11/R4/src/mit/lib/X/libX_d.a + +XLIBHOME=/misc +MOTIFLIB=$(XLIBHOME)/libXm_d.a +XLIBS=$(XLIBHOME)/libXt_d.a $(XLIBHOME)/libX_d.a + +#OLXLIBS=$(XLIBS) +OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2/ +OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a +#LIBXOL=$(OPENWINHOME)/lib/libXol.a +LIBXOL=$(OLCOPYLIB)/libXol.a + +# This has to be kept consistent with xlib.lisp + +UNDEFS=misc/undefinedsymbols + +# This should be the same as load-xm + +XM_UNDEFS=misc/undefinedsymbols.motif + +# This should be the same as load-ol + +OL_UNDEFS=misc/undefinedsymbols.olit + +default : xm-composer + +ol-dcl : stub-olit.o + cd $(CL_SRC) ; /bin/rm -f ucl ;\ + make ucl_xtras='$(PWD)/stub-olit.o $(LIBXOL) $(OLXLIBS)' dcl + +xm-dcl : stub-motif.o + cd $(CL_SRC) ; /bin/rm -f ucl ;\ + make ucl_xtras='$(PWD)/stub-motif.o $(MOTIFLIB) $(XLIBS)' dcl + +stub-motif.c : $(UNDEFS) $(XM_UNDEFS) misc/make-stub-file + misc/make-stub-file "void ___lisp_load_motif_stub ()" $(UNDEFS) $(XM_UNDEFS) > stub-motif.c + +stub-olit.c : $(UNDEFS) $(OL_UNDEFS) misc/make-stub-file + misc/make-stub-file "void ___lisp_load_olit_stub ()" $(UNDEFS) $(OL_UNDEFS) > stub-olit.c + +FRC : + +xm-composer : xm-dcl + cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2 + +ol-composer : ol-dcl + cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2 + + diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index da99a5c10c191cb535800ca6db104886cb4c959d..9ce38997f49879fe6ad53f1e602f686815f4e396 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.9 92/03/04 16:21:04 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.11 92/03/10 10:12:13 cer Exp Locker: cer $ (in-package :clim-internals) @@ -197,6 +197,7 @@ (setf exit-button-stream (realize-pane 'clim-stream-pane :initial-cursor-visibility nil))))) + (:top-level (accept-values-top-level)) (:menu-bar nil) (:command-table accept-values) (:command-definer nil)) @@ -275,6 +276,7 @@ (bottom-margin 10)) (if own-window (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) + :parent *application-frame* :calling-frame *application-frame* :continuation continuation :exit-boxes exit-boxes @@ -1035,17 +1037,26 @@ (formatting-cell (stream) (with-output-as-gadget (stream) (realize-pane 'push-button + :activate-callback + #'(lambda (gadget) + (declare (ignore gadget)) + (com-abort-avv)) :client frame :id :abort :label abort))) (formatting-cell (stream) (with-output-as-gadget (stream) (realize-pane 'push-button + :activate-callback + #'(lambda (gadget) + (declare (ignore gadget)) + (com-exit-avv)) :client frame :id :exit :label exit)))))))) ;; Callback for exit boxes +#+ignore (defmethod activate-callback ((button push-button) (client accept-values) id) (ecase id (:abort (com-abort-avv)) @@ -1060,6 +1071,7 @@ (setf value new-value changed-p t))) +#+ignore (defmethod value-changed-callback :around ((gadget value-gadget) (client accept-values-stream) id new-value) (declare (ignore new-value)) @@ -1067,15 +1079,29 @@ ;; Only call the callback if the query is still valid (call-next-method))) -;; Callback for value gadgets +#+ignore (defmethod value-changed-callback ((gadget value-gadget) (client accept-values-stream) id new-value) (do-avv-command new-value client id)) +#+ignore (defmethod value-changed-callback ((gadget radio-box) (client accept-values-stream) id new-value) (do-avv-command (gadget-id new-value) client id)) + +(defun accept-values-value-changed-callback (gadget new-value stream query-id) + (declare (ignore gadget)) + (when (accept-values-query-valid-p (accept-values-query-presentation query-id)) + ;; Only call the callback if the query is still valid + (do-avv-command new-value stream query-id))) + +(defun make-accept-values-value-changed-callback (stream query-id) + ;; We attach a callback function directly now + `(,#'accept-values-value-changed-callback ,stream ,query-id)) + +;;;;;;;;;;;;;;; + (defun do-avv-command (new-value client id) (throw-highlighted-presentation (make-instance 'standard-presentation @@ -1092,27 +1118,46 @@ ;; This is how we associate an output-record with the button (defmethod invoke-accept-values-command-button - (stream continuation (view gadget-dialog-view) prompt - &key (documentation (if (stringp prompt) - prompt - (with-output-to-string (stream) - (funcall prompt stream)))) - (query-identifier (list ':button documentation)) - (cache-value t) (cache-test #'eql) - resynchronize) + (stream continuation (view gadget-dialog-view) prompt + &key (documentation (if (stringp prompt) + prompt + (with-output-to-string (stream) + (funcall prompt stream)))) + (query-identifier (list ':button documentation)) + (cache-value t) (cache-test #'eql) + resynchronize) (declare (dynamic-extent prompt)) (updating-output (stream :unique-id query-identifier :id-test #'equal :cache-value cache-value :cache-test cache-test) (with-output-as-gadget (stream) - (realize-pane 'push-button - :label prompt - :id (stream-current-output-record (slot-value stream 'stream)) - :client (make-instance 'accept-values-command-button - :continuation continuation - :documentation documentation - :resynchronize resynchronize))))) - + (let ((id (stream-current-output-record (slot-value stream + 'stream))) + (client (make-instance 'accept-values-command-button + :continuation continuation + :documentation documentation + :resynchronize resynchronize))) + (realize-pane 'push-button + :activate-callback + #'(lambda (button) + (when (accept-values-query-valid-p id) + (throw-highlighted-presentation + (make-instance 'standard-presentation + :object `(com-avv-command-button ,client ,id) + :type 'command) + *input-context* + ;;--- It would be nice if we had the real event... + (make-instance 'pointer-button-press-event + :sheet (sheet-parent button) + :x 0 + :y 0 + :modifiers 0 + :button 256)))) + :label prompt + :id id + :client client))))) + +#+ignore (defmethod activate-callback ((button push-button) (client accept-values-command-button) id) (when (accept-values-query-valid-p id) diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index fce22fadf8c584dcc81f98edc8d7514529e9f911..389105271bdb443e0250c457734dd6199824ddab 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.4 92/03/04 16:21:13 cer Exp $ +;; $fiHeader: command-processor.lisp,v 1.5 92/03/10 10:12:20 cer Exp Locker: cer $ (in-package :clim-internals) @@ -46,9 +46,11 @@ (with-accept-help ((:top-level-help #'command-help)) (multiple-value-bind (command final-delimiter) (invoke-command-name-parser-and-collect-1 - command-name arg-parser delimiter-parser stream) - (if (member final-delimiter *command-previewers* - :test #'keyboard-event-matches-gesture-name-p) + command-name arg-parser delimiter-parser stream) + ;;-- In the cad demo this ends up as NIL. Is that ok?? + (if (and final-delimiter + (member final-delimiter *command-previewers* + :test #'keyboard-event-matches-gesture-name-p)) (with-input-editor-typeout (stream) (accept-values-command-parser command-name command-table diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 1e10d74c141c6a0d09b4ad656b7d9e70ed8c4521..586c16235a199da6786ef529f61aff01a5fbdd33 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.8 92/02/24 13:07:16 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.9 92/03/04 16:21:21 cer Exp Locker: cer $ (in-package :clim-internals) @@ -193,6 +193,7 @@ (defclass interactor-pane (clim-stream-pane) ()) (defclass application-pane (clim-stream-pane) ()) +(defclass pointer-documentation-pane (clim-stream-pane) ()) (defclass command-menu-pane (clim-stream-pane) ()) (defmethod compose-space :before ((pane command-menu-pane) &key width height) @@ -268,9 +269,9 @@ (when text-record (replay text-record stream)))) (defmethod window-erase-viewport ((stream window-stream)) - (with-output-recording-options (stream :record nil) + (with-sheet-medium (medium stream) (multiple-value-call #'draw-rectangle* - (sheet-medium stream) + medium (bounding-rectangle* (or (pane-viewport stream) stream)) :ink +background-ink+))) @@ -330,6 +331,15 @@ ;; location. It does NOT do any cleaning up after itself. It does not side-effect ;; the output history of the window. It calls COPY-AREA whose contract is to ;; do the above, the whole above, and nothing but the above. + +;;;--- +(defmethod window-shift-visible-region ((window t) + old-left old-top old-right old-bottom + new-left new-top new-right + new-bottom) + (declare (ignore old-left old-top old-right old-bottom new-left new-top new-right new-bottom)) + nil) + (defmethod window-shift-visible-region ((window clim-stream-sheet) old-left old-top old-right old-bottom new-left new-top new-right new-bottom) diff --git a/clim/frames.lisp b/clim/frames.lisp index 399c2424097cc92034514cbe37af83cdd23df00d..c036717aeab818965738e4afec4f718735b85f8b 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.9 92/03/04 16:21:35 cer Exp $ +;; ;; $fiHeader: frames.lisp,v 1.10 92/03/10 10:12:33 cer Exp Locker: cer $ (in-package :clim-internals) @@ -13,6 +13,7 @@ ;;--- We should add an input event-queue to frames, so that other ;;--- 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) @@ -24,7 +25,7 @@ ;; 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 :initarg :frame-manager) + (frame-manager :reader frame-manager) (calling-frame :reader frame-calling-frame :initarg :calling-frame) ;;--- How does ALL-PANES differ from PANES? (panes :initarg :panes :accessor frame-panes) @@ -40,14 +41,26 @@ :reader frame-current-layout) (default-size :initform nil :initarg :default-size) (shell :accessor frame-shell) - (port :reader port :initarg :port) - (graft :reader graft :initarg :graft) + (pointer-documentationp + :initarg :pointer-documentation + :reader frame-pointer-documentationp) + (pointer-documentation-pane :initform nil) (properties :initform nil :initarg :properties :accessor frame-properties)) - (:default-initargs :top-level 'default-frame-top-level - :frame-manager (find-frame-manager) - :port (find-port) - :graft (find-graft))) + (:default-initargs + :pointer-documentation nil + :top-level 'default-frame-top-level)) + +(defmethod port ((frame standard-application-frame)) + (port (frame-manager frame))) + +(defmethod graft ((frame standard-application-frame)) + (graft (frame-manager frame))) + + +(defmethod frame-pointer-documentation-output ((frame standard-application-frame)) + (with-slots (pointer-documentation-pane) frame + pointer-documentation-pane)) #+CLIM-1-compatibility (define-compatibility-function (frame-top-level-window frame-top-level-sheet) @@ -55,9 +68,20 @@ (frame-top-level-sheet frame)) (defmethod initialize-instance :after ((frame standard-application-frame) - &rest args &key frame-manager) + &rest args &key + frame-manager + (parent frame-manager)) (declare (ignore args)) - (adopt-frame frame-manager frame)) + (let ((frame-manager + (etypecase parent + (null (find-frame-manager)) + (list (apply #'find-frame-manager parent)) + (frame-manager parent) + (application-frame (frame-manager parent)) + (port (find-frame-manager :port parent)) + (sheet (frame-manager (pane-frame parent)))))) + (setf (slot-value frame 'frame-manager) frame-manager) + (adopt-frame frame-manager frame))) ;; Default method does nothing (defmethod generate-panes ((framem standard-frame-manager) @@ -80,6 +104,7 @@ #+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 command-definer command-table disabled-commands) (macrolet ((extract (name keyword default &optional (pair t)) `(let ((entry (assoc ',keyword options))) @@ -94,7 +119,9 @@ `((assert (listp (rest entry)) (entry) "The remainder of ~S must be a list" entry) (setq ,name (rest entry) - options (delete entry options))))))))) + options (delete entry + options))))))))) + (extract pointer-documentation :pointer-documentation nil) (extract pane :pane nil) (extract panes :panes nil nil) (extract layout :layout nil nil) @@ -148,7 +175,8 @@ (defclass ,name ,superclasses ,slots ,@options (:default-initargs - :menu-bar ',menu-bar + :pointer-documentation ',pointer-documentation + :menu-bar ',menu-bar ,@(and command-table `(:command-table ',(car command-table))) ,@(and top-level `(:top-level ',top-level)) ,@(and panes `(:pane-constructors ,pane-constructors)) @@ -314,10 +342,16 @@ (setq width (space-requirement-width sr) height (space-requirement-height sr)))) ;;--- Don't bother with this if the size didn't change? - (allocate-space panes width height) - ;; This is quite likely not going to work - (when (frame-top-level-sheet frame) - (resize-sheet* (frame-top-level-sheet frame) width height))))) + ;;-- This is wrong We want to resize the top level sheet + ;;; (allocate-space panes width height) + (resize-sheet* + (or (frame-top-level-sheet frame) + panes) + width height + ;;-- we need to do this because if the wm has changed the sheet + ;; then this will not change its size but we need it to start + ;; the layout stuff + :force t)))) (defmethod (setf frame-current-layout) (nv (frame standard-application-frame)) (unless (eq (frame-current-layout frame) nv) @@ -332,7 +366,6 @@ ;; Now we want to give it some new ones (generate-panes (frame-manager frame) frame) (sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame)) - (clear-space-requirement-caches-in-tree (frame-panes frame)) (multiple-value-call #'layout-frame frame (bounding-rectangle-size (frame-top-level-sheet frame))) (throw 'layout-changed nil))) @@ -480,28 +513,34 @@ (loop (catch 'layout-changed (let* ((*standard-output* - (or (frame-standard-output frame) *standard-output*)) + (or (frame-standard-output frame) *standard-output*)) (*standard-input* - (or (frame-standard-input frame) *standard-output*)) + (or (frame-standard-input frame) *standard-output*)) (*query-io* - (or (frame-query-io frame) *standard-input*)) + (or (frame-query-io frame) *standard-input*)) (*error-output* - (or (frame-error-output frame) *standard-output*)) + (or (frame-error-output frame) *standard-output*)) (interactor - (not (null (find-frame-pane-of-type frame 'interactor-pane)))) + (not (null (find-frame-pane-of-type frame 'interactor-pane)))) (*command-parser* - (or command-parser - (if interactor - #'command-line-command-parser - #'menu-command-parser))) + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-command-parser))) (*command-unparser* - (or command-unparser - #'command-line-command-unparser)) + (or command-unparser + #'command-line-command-unparser)) (*partial-command-parser* - (or partial-command-parser - (if interactor - #'command-line-read-remaining-arguments-for-partial-command - #'menu-read-remaining-arguments-for-partial-command)))) + (or partial-command-parser + (if interactor + #'command-line-read-remaining-arguments-for-partial-command + #'menu-read-remaining-arguments-for-partial-command))) + (command-stream + (typecase *standard-input* + (output-protocol-mixin + *standard-input*) + (t + (frame-top-level-sheet frame))))) #+Allegro (unless (typep *standard-input* 'excl::bidirectional-terminal-stream) (assert (port *standard-input*))) @@ -521,7 +560,7 @@ (if (stringp prompt) (write-string prompt *standard-input*) (funcall prompt *standard-input* frame))) - (let ((command (read-frame-command frame :stream *standard-input*))) + (let ((command (read-frame-command frame :stream command-stream))) (when interactor (terpri *standard-input*)) ;; Need this check in case the user aborted out of a command menu @@ -585,36 +624,40 @@ (defun redisplay-frame-pane (frame pane &key force-p) (when (symbolp pane) (setq pane (get-frame-pane frame pane))) - (when (pane-display-function pane) - (let* ((ir (slot-value pane 'incremental-redisplay-p)) - (redisplay-p (if (listp ir) (first ir) ir)) - (check-overlapping (or (atom ir) ;default is T - (getf (rest ir) :check-overlapping t)))) - (with-simple-restart (nil "Skip redisplaying pane ~S" pane) - (loop - (with-simple-restart (nil "Retry displaying pane ~S" pane) - (return - (let ((redisplay-record - (and redisplay-p - (let ((history (stream-output-history pane))) - (when history - #+compulsive-redisplay - (when (> (output-record-count history) 1) - (cerror "Clear the output history and proceed" - "There is more than one element in this redisplay pane") - (window-clear pane)) - (unless (zerop (output-record-count history)) - (output-record-element history 0))))))) - (cond ((and redisplay-p - (or force-p (null redisplay-record))) - (when force-p - (window-clear pane)) - (invoke-pane-redisplay-function frame pane)) - (redisplay-p - (redisplay redisplay-record pane - :check-overlapping check-overlapping)) - (t - (invoke-pane-display-function frame pane))))))))))) + (cond ((pane-display-function pane) + (let* ((ir (slot-value pane 'incremental-redisplay-p)) + (redisplay-p (if (listp ir) (first ir) ir)) + (check-overlapping (or (atom ir) ;default is T + (getf (rest ir) :check-overlapping t)))) + (with-simple-restart (nil "Skip redisplaying pane ~S" pane) + (loop + (with-simple-restart (nil "Retry displaying pane ~S" pane) + (return + (let ((redisplay-record + (and redisplay-p + (let ((history (stream-output-history pane))) + (when history + #+compulsive-redisplay + (when (> (output-record-count history) 1) + (cerror "Clear the output history and proceed" + "There is more than one element in this redisplay pane") + (window-clear pane)) + (unless (zerop (output-record-count history)) + (output-record-element history 0))))))) + (cond ((and redisplay-p + (or force-p (null redisplay-record))) + (when force-p + (window-clear pane)) + (invoke-pane-redisplay-function frame pane)) + (redisplay-p + (redisplay redisplay-record pane + :check-overlapping check-overlapping)) + (t + (invoke-pane-display-function frame + pane)))))))))) + (force-p + ;;-- Is there anything else we need to do? + (stream-replay pane)))) (defun invoke-pane-redisplay-function (frame pane &rest args) (declare (dynamic-extent args)) @@ -748,19 +791,15 @@ (defmethod frame-error-output ((frame standard-application-frame)) (frame-standard-output frame)) -;;--- Get this right -(defmethod frame-pointer-documentation-output ((frame standard-application-frame)) - nil) - ;;--- This causes direct-manipulation and menu-driven applications not to ;;--- maintain histories. Is there a better heuristic? (defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) (not (null (find-frame-pane-of-type frame 'interactor-pane)))) ;;--- What should this really do? -#+Allegro -(defun notify-user (&rest ignore) - (format excl::*initial-terminal-io* "Notify ~a~%" ignore)) + +(defmethod notify-user (frame format-string &rest format-arguments) + (apply #'port-notify-user (port frame) frame format-string format-arguments)) ;;; Pointer documentation diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index f67e24d6dff271dcd9953ba109f5f56ee10117ab..a9ca435333fb363ad8573ac5ce2dd23f0634e3b7 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.6 92/02/24 13:07:33 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.7 92/03/04 16:21:37 cer Exp Locker: cer $ (in-package :clim-internals) @@ -130,6 +130,9 @@ (let* (gadget (record (with-new-output-record (stream 'gadget-output-record record) + ;;--- Do we really need to do this. under what + ;;--- situations does this happen and why cant we loose + ;;--- the gadget (unless (setq gadget (output-record-gadget record)) (associate-record-and-gadget record @@ -204,9 +207,13 @@ ;; value-key, test, sequence (with-output-as-gadget (stream) (let* ((gadget - (realize-pane 'radio-box - :client stream - :id query-identifier))) + (realize-pane 'radio-box + :label (and (stringp prompt) prompt) + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier) + :client stream + :id query-identifier))) (dolist (element sequence) (realize-pane 'toggle-button :value (and default-supplied-p @@ -225,12 +232,20 @@ present-p query-identifier &key (prompt t)) (declare (ignore default-supplied-p present-p)) - (with-output-as-gadget (stream) - (realize-pane 'toggle-button - :client stream - :id query-identifier - :value default - :label (and (stringp prompt) prompt)))) + (let ((x (with-output-as-gadget (stream) + (realize-pane 'toggle-button + :client stream + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier) + :id query-identifier + :value default + :label (and (stringp prompt) prompt))))) + ;;--- 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! + (setf (gadget-value x) default))) + (define-presentation-method accept-present-default ((type integer) @@ -242,6 +257,9 @@ (declare (ignore present-p)) (with-output-as-gadget (stream) (realize-pane 'slider + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier) :client stream :width 100 :value (if default-supplied-p default 0) diff --git a/clim/menus.lisp b/clim/menus.lisp index d9c388d5548b7623bafe1b26f17d2c8bbd30e70d..81492b4813f094eaf38360e8935e1c3d0bc6627f 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.14 92/03/06 09:08:44 cer Exp $ +;; $fiHeader: menus.lisp,v 1.15 92/03/10 10:12:44 cer Exp Locker: cer $ (in-package :clim-internals) @@ -24,8 +24,9 @@ (and (boundp '*application-frame*) *application-frame*)) -(defun get-menu (&key server-path) +(defun get-menu (&key port) (let ((frame (make-application-frame 'menu-frame + :parent port :save-under t))) (values (slot-value frame 'menu) frame))) @@ -61,9 +62,8 @@ #+Silica (defresource menu (associated-window root) - :constructor (let* ((port (if (null root) (find-port) (port root))) - (server-path (port-server-path port))) - (get-menu :server-path server-path)) + :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 diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index 79b8eb552934980d5424f8b2c4abdb37ae15cdbf..b8099a855f36662d36b896e99020d40d958e2192 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.3 92/03/04 16:22:13 cer Exp $ +;; $fiHeader: recording-protocol.lisp,v 1.5 92/03/10 10:12:49 cer Exp Locker: cer $ (in-package :clim-internals) @@ -1139,6 +1139,7 @@ ((stream-drawing-p stream) draw)) (funcall continuation))) + ;;; The following two are only called when STREAM-RECORDING-P is true and the ;;; characters are printable (see CHARACTER-DRAWING.LISP). (defmethod stream-add-string-output ((stream output-recording-mixin) string diff --git a/demo/address-book.lisp b/demo/address-book.lisp index 0d83fc7cdd250b06ccfc85dcce69522039875f23..74e8a19f20397983e8d56ec94b5edc4b18a3eb9f 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.1 92/01/31 14:31:57 cer Exp $ +;; $fiHeader: address-book.lisp,v 1.2 92/02/24 13:09:16 cer Exp Locker: cer $ (in-package :clim-demo) @@ -94,30 +94,35 @@ (write-string number stream)))) ;;; Define the application-frame for our application + (define-application-frame address-book - () - ;; This application has two state variables, the currently displayed - ;; address and the window from which user queries should be read. - ((current-address :initform nil) - (interaction-pane ) - (name-pane)) + () + ;; This application has two state variables, the currently displayed + ;; address and the window from which user queries should be read. + ((current-address :initform nil) + (interaction-pane ) + (name-pane)) + (:panes - ((interactor :interactor) - (menu :command-menu) - (address :application - :incremental-redisplay t - :display-function 'display-current-address) - (names :application - :incremental-redisplay t - :display-function 'display-names))) + (interactor + (scrolling () + (realize-pane 'interactor-pane))) + (address + (scrolling () + (realize-pane 'application-pane + :incremental-redisplay t + :display-function + 'display-current-address))) + (names + (scrolling () + (realize-pane 'application-pane + :incremental-redisplay t + :display-function 'display-names)))) (:layout - ((default - (:column 1 - (:row 1/2 - (address 1/2) - (names :rest)) - (menu :compute) - (interactor :rest)))))) + (default + (vertically () + (horizontally () address names) + interactor)))) ;;; This is the display-function for the upper-left pane, which specified ;;; :display-function '(incremental-redisplay-display-function display-current-address). diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index 6a28ba65a8ef03ca2cae1a5f928831cec60834fa..26f11942c7028adbccc8596ad58e1f539ec8eceb 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.2 92/02/24 13:09:20 cer Exp $ +;; $fiHeader: cad-demo.lisp,v 1.3 92/03/04 16:22:58 cer Exp Locker: cer $ (in-package :clim-demo) @@ -499,9 +499,13 @@ (cond ((eq ink +background-ink+) ;;--- gee, am I getting carried away? (multiple-value-bind (nx ny) - (drawing-surface-to-viewport-coordinates stream x y) - (decf ny *component-size*) - (window-clear-area stream (- nx 10) (- ny 10) nx (+ ny 20)))) + #+ignore drawing-surface-to-viewport-coordinates + (values x y) + (decf ny *component-size*) + (with-sheet-medium (medium stream) + (draw-rectangle* medium + (- nx 10) (- ny 10) nx (+ ny 20) + :ink +background-ink+)))) (t (draw-text* stream name (- x 10) (- y 10))))))) @@ -527,32 +531,33 @@ ;;; First define a "application" that manages the application's state variables ;;; and defines a high-level division of screen real estate. + + + (define-application-frame cad-demo (standard-application-frame output-record) - ((object-list :initform nil)) + ((object-list :initform nil)) (:panes - ((title :title - :display-string "Mini-CAD") - (menu :command-menu) - (design-area :application) - (documentation :pointer-documentation))) + (design-area + (realize-pane 'application-pane))) + (:pointer-documentation t) (:layout - ((main - (:column :rest - (title :compute) - (menu :compute) - (design-area :rest) - (documentation :compute))) - (other - (:column :rest - (title :compute) - (:row :rest - (menu :compute) - (design-area :rest)) - (documentation :compute))))) + (:default + (scrolling () + design-area))) (:top-level (default-frame-top-level :partial-command-parser cad-demo-partial-command-parser))) +;;--- I am amazed every day by something +;; and this was it today !!!! + +(defmethod initialize-instance :around ((cd cad-demo) &key) + (call-next-method) + (let ((dp (get-frame-pane cd 'design-area))) + ;;--- kludge this one pane + (setf (stream-output-history dp) cd) + (setf (stream-recording-p dp) nil))) + (defun cad-demo-partial-command-parser (partial-command command-table stream start-location) (let ((name (command-name partial-command))) (if (eq name 'com-create-component) @@ -675,6 +680,7 @@ ;(make-component-prototypes) ;;; Return the class name of the selected component + (defun select-component (parent) (labels ((draw-icon-menu (menu presentation-type) (formatting-table (menu :x-spacing 5) @@ -696,7 +702,7 @@ (with-menu (menu parent) (let ((component (menu-choose-from-drawer menu 'menu-item #'draw-icon-menu))) - (class-name (class-of component))))) + (class-name (class-of component)))))) @@ -884,15 +890,17 @@ (define-cad-demo-command (com-exit-CAD-demo :menu "Exit" :keystroke #\X) () ;; assume called via run-cad-demo - (throw 'exit-cad-demo nil)) - -(define-cad-demo-command (com-swap-layouts :menu "Swap Layouts") - () - (let ((current-layout (frame-current-layout *application-frame*))) - (setf (frame-current-layout *application-frame*) - (case current-layout - (main 'other) - (other 'main))))) + (frame-exit *application-frame*)) + +;;;------------ +;;; Right now there is only one +;(define-cad-demo-command (com-swap-layouts :menu "Swap Layouts") +; () +; (let ((current-layout (frame-current-layout *application-frame*))) +; (setf (frame-current-layout *application-frame*) +; (case current-layout +; (main 'other) +; (other 'main))))) #|| diff --git a/demo/navfun.lisp b/demo/navfun.lisp index d79167cfdc18a828f06a6531463d36b8e5a3a3a7..f630c4010aa113fe1a8969c68219030e5b5e76cc 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.1 92/01/31 14:32:06 cer Exp $ +;; $fiHeader: navfun.lisp,v 1.2 92/02/24 13:09:28 cer Exp Locker: cer $ (in-package :clim-demo) @@ -220,11 +220,11 @@ (draw-coastline *coastline*) (flet ((present-position (object) (present object (class-name (class-of object)) - :view +iconic-view+ :single-box t))) + :view +gadget-view+ :single-box t))) (mapc #'present-position *position-list*)) (flet ((present-route (object) (present object (class-name (class-of object)) - :view +iconic-view+ :single-box nil))) + :view +gadget-view+ :single-box nil))) (mapc #'present-route *route-list*) (mapc #'present-route *victor-airway-list*))) @@ -307,14 +307,14 @@ (format stream "NDB ~A ~A" name longname))) #-Allegro -(defclass intersection (named-position) ()) +(defclass named-intersection (named-position) ()) #+Allegro (eval-when (compile load eval) - (defclass intersection (named-position) ())) + (defclass named-intersection (named-position) ())) -(defmethod draw-position ((intersection intersection) stream &optional label) - (with-slots (longitude latitude) intersection +(defmethod draw-position ((named-intersection named-intersection) stream &optional label) + (with-slots (longitude latitude) named-intersection (multiple-value-bind (x y) (scale-coordinates longitude latitude) (rounding-coordinates (x y) (let ((color-args (and (color-stream-p stream) @@ -343,7 +343,7 @@ (define-presentation-type ground-position ()) -(define-presentation-method present (object (type ground-position) stream (view iconic-view) &key) +(define-presentation-method present (object (type ground-position) stream (view gadget-view) &key) (draw-position object stream)) @@ -354,7 +354,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (position-name object)))) -(define-presentation-method present (object (type named-position) stream (view iconic-view) +(define-presentation-method present (object (type named-position) stream (view gadget-view) &key) (draw-position object stream (and (typep object 'named-position) @@ -372,7 +372,7 @@ (define-presentation-type NDB ()) -(define-presentation-type intersection ()) +(define-presentation-type named-intersection ()) (define-presentation-type visual-checkpoint ()) @@ -494,7 +494,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (route-name object)))) -(define-presentation-method present (object (type route) stream (view iconic-view) &key) +(define-presentation-method present (object (type route) stream (view gadget-view) &key) (let ((drawing-args (if (color-stream-p stream) (list :ink +red+) '(:line-dashes t)))) @@ -522,7 +522,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (route-name object)))) -(define-presentation-method present (object (type victor-airway) stream (view iconic-view) +(define-presentation-method present (object (type victor-airway) stream (view gadget-view) &key) (let ((drawing-args (if (color-stream-p stream) (list :ink +blue+) @@ -1018,20 +1018,17 @@ ;;; Flight-Planner user interface (define-application-frame Flight-Planner - () - ((fp-window)) - (:panes ((title :title) - (display :application) - (commands :command-menu) - (interactor :interactor) - (documentation :pointer-documentation))) - (:layout ((default - (:column 1 - (title :compute) - (display :rest) - (commands :compute) - (interactor 1/5) - (documentation :compute)))))) + () + ((fp-window)) + (:panes + (display (realize-pane 'application-pane)) + (interactor (realize-pane 'interactor-pane))) + (:layout + (default + (vertically + () + (scrolling () display) + (scrolling () interactor))))) (define-Flight-Planner-command (com-Zoom-In :name t :menu t) () (multiple-value-bind (longitude latitude) @@ -1104,11 +1101,11 @@ (defun route-start-object-p (thing) ;--- kludge! (or (typep thing 'airport) - (typep thing 'intersection) + (typep thing 'named-intersection) (typep thing 'vor))) (define-presentation-type-abbreviation route-start-object () - '(or airport intersection vor)) + '(or airport named-intersection vor)) ;;; Add <kind> (define-Flight-Planner-command (com-Add-Object :name t :menu "Add") @@ -1122,17 +1119,17 @@ (ground-position (let ((new-position (query-new-position))) (when new-position - (present new-position 'ground-position :view +iconic-view+) + (present new-position 'ground-position :view +gadget-view+) (push new-position *position-list*)))) (route (let* ((new-route (query-new-route :route-start route-start))) (when new-route - (present new-route 'route :view +iconic-view+) + (present new-route 'route :view +gadget-view+) (push new-route *route-list*)))) (victor-airway (let ((new-victor-airway (query-new-victor-airway))) (when new-victor-airway - (present new-victor-airway 'victor-airway :view +iconic-view+) + (present new-victor-airway 'victor-airway :view +gadget-view+) (push new-victor-airway *victor-airway-list*)))) (aircraft (let ((new-aircraft (query-new-aircraft))) @@ -1158,7 +1155,7 @@ (terpri *query-io*) (setq long-name (accept 'string :prompt "Long name")) (terpri *query-io*) - (setq kind (accept '(member airport vor intersection visual-checkpoint) + (setq kind (accept '(member airport vor named-intersection visual-checkpoint) :prompt "Kind of position")) (terpri *query-io*) (setq lat-and-long (accept 'latitude-and-longitude :prompt "Latitude, Longitude")) @@ -1176,11 +1173,11 @@ (defun waypoint-object-p (thing) ;--- kludge! (or (null thing) (typep thing 'airport) - (typep thing 'intersection) + (typep thing 'named-intersection) (typep thing 'vor))) (define-presentation-type-abbreviation waypoint-object () - '(or null airport intersection vor)) + '(or null airport named-intersection vor)) (defun query-new-route (&key (name nil) (route-start nil)) (do* ((overfly ()) @@ -1611,11 +1608,11 @@ ;; Airports (add-position "HFD" 'airport (degminsec 41 44) (degminsec 72 39) 19 15 "Hartford-Brainard") - ;; Intersections - (add-position "DREEM" 'intersection (degminsec 42 21.6) (degminsec 71 44.3) 0 15 "DREEM") - (add-position "GRAYM" 'intersection (degminsec 42 06.1) (degminsec 72 01.9) 0 15 "GRAYM") - (add-position "WITNY" 'intersection (degminsec 42 03) (degminsec 72 14.2) 0 15 "WITNY") - (add-position "EAGRE" 'intersection (degminsec 41 45) (degminsec 72 20.6) 0 15 "EAGRE") + ;; Named-Intersections + (add-position "DREEM" 'named-intersection (degminsec 42 21.6) (degminsec 71 44.3) 0 15 "DREEM") + (add-position "GRAYM" 'named-intersection (degminsec 42 06.1) (degminsec 72 01.9) 0 15 "GRAYM") + (add-position "WITNY" 'named-intersection (degminsec 42 03) (degminsec 72 14.2) 0 15 "WITNY") + (add-position "EAGRE" 'named-intersection (degminsec 41 45) (degminsec 72 20.6) 0 15 "EAGRE") ;; VOR's diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index 419a0b0930bfdcefdc70985b15d3e28434635d95..d107c2823f39f33f872a40f243a37a14c3fa0837 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -1,22 +1,28 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: puzzle.lisp,v 1.1 92/01/31 14:32:10 cer Exp $ +;; $fiHeader: puzzle.lisp,v 1.2 92/02/24 13:09:31 cer Exp Locker: cer $ (in-package :clim-demo) "Copyright (c) 1989, 1990, 1991 Symbolics, Inc. All rights reserved." (define-application-frame puzzle - () - ((puzzle :initform (make-array '(4 4)) - :accessor puzzle-puzzle)) - (:panes ((title :title) - (menu :command-menu) - (display :application - :default-text-style '(:fix :bold :very-large) - :scroll-bars nil - :incremental-redisplay T - :display-function 'draw-puzzle)))) + () + ((puzzle :initform (make-array '(4 4)) + :accessor puzzle-puzzle)) + (:panes + (display + (outlining () + (realize-pane 'application-pane + :text-cursor nil + :width :compute + :max-width +fill+ + :height :compute + :max-height +fill+ + :incremental-redisplay T + :display-function 'draw-puzzle)))) + (:layout + (:default display))) (defmethod frame-query-io ((puzzle puzzle)) (get-frame-pane puzzle 'display)) @@ -63,8 +69,11 @@ (dotimes (column 4) (setf (aref puzzle-array row column) (mod (1+ (encode-puzzle-cell row column)) 16)))))) -(defmethod draw-puzzle ((puzzle puzzle) stream) - (with-end-of-page-action (stream :allow) +(defmethod draw-puzzle ((puzzle puzzle) stream &key max-width max-height) + (declare (ignore max-width max-height)) + (with-text-style (stream '(:fix :bold :very-large)) + (with-end-of-page-action (stream :allow) + (with-end-of-line-action (stream :allow) (let ((puzzle-array (puzzle-puzzle puzzle))) ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this (stream-set-cursor-position* stream 0 0) @@ -81,7 +90,7 @@ (unless (zerop value) (with-output-as-presentation (stream (encode-puzzle-cell row column) 'puzzle-cell) - (format stream "~D" value)))))))))))))) + (format stream "~D" value)))))))))))))))) (defun find-open-cell (puzzle) (dotimes (row 4) diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp index 580e62724d07aa80488aeb231783f6a2280e2097..50359f7347df49fa9768531b40b55f6adc9c7b04 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.1 92/01/31 14:32:11 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.5 92/03/04 16:23:04 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -22,28 +22,26 @@ #+Allegro (frob-pathname "demo") #+CMU "/home/hornig/clim/rel-2/cmu/" #+CCL-2 "ccl;clim-2.0:fasls:" - :needed-systems (clim-standalone)) +;;;; :needed-systems (clim-standalone) + ) ("packages") ("aaai-demo-driver" :load-before-compile ("packages")) ("listener" :load-before-compile ("aaai-demo-driver" "packages")) ("graphics-demos" :load-before-compile ("aaai-demo-driver" "packages") :features (not Minima)) - #+++when-converted + ("puzzle" :load-before-compile ("aaai-demo-driver" "packages")) ("cad-demo" :load-before-compile ("aaai-demo-driver" "packages") :features (not Minima)) - #+++when-converted ("navdata" :load-before-compile ("packages") :features (not Minima)) - #+++when-converted ("navfun" :load-before-compile ("aaai-demo-driver" "navdata" "packages") :features (not Minima)) - #+++when-converted - ("puzzle" :load-before-compile ("aaai-demo-driver" "packages")) - #+++when-converted - ("address-book" :load-before-compile ("aaai-demo-driver" "packages")) - #+++when-converted - ("thinkadot" :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)))) #+Genera diff --git a/demo/thinkadot.lisp b/demo/thinkadot.lisp index bfd51a1b5f9b976f21c2749432f10ea2b1f84f39..ac012ee0042140598941b09e18a2a8dca54c1451 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.2 92/02/24 13:09:34 cer Exp $ +;; $fiHeader: thinkadot.lisp,v 1.3 92/03/04 16:23:05 cer Exp Locker: cer $ (in-package :clim-demo) @@ -39,22 +39,24 @@ (define-application-frame thinkadot () - ((node1) - (node2) - (node3) - (node4) - (node5) - (node6) - (node7) - (node8) - (all-nodes) - (lexit) - (rexit)) - (:panes ((display :application - :display-function 'draw-the-display - :incremental-redisplay t - :scroll-bars nil) - (menu :command-menu)))) + ((node1) + (node2) + (node3) + (node4) + (node5) + (node6) + (node7) + (node8) + (all-nodes) + (lexit) + (rexit)) + (:panes + (display + (realize-pane 'application-pane + :display-function 'draw-the-display + :incremental-redisplay t))) + (:layout + (:default (scrolling () display)))) (defmethod initialize-instance :after ((frame thinkadot) &key) (multiple-value-bind (w h) @@ -88,7 +90,9 @@ (defvar *light-color* (make-gray-color 0.667)) (defvar *dark-color* +black+) -(defmethod draw-the-display ((frame thinkadot) stream) + +(defmethod draw-the-display ((frame thinkadot) stream &key max-width max-height) + (declare (ignore max-width max-height)) (with-slots (all-nodes lexit rexit) frame (let ((id 0)) (dolist (node all-nodes) @@ -138,7 +142,8 @@ (drop-a-marble node)) (define-presentation-to-command-translator drop-a-marble - (entry-node com-drop-marble thinkadot) + (entry-node com-drop-marble thinkadot + :documentation "Drop Marble") (object) `(,object)) @@ -157,9 +162,6 @@ (setf (td-node-direction node) nil)))) (define-thinkadot-command (com-exit :menu T) () - (let ((window (frame-top-level-sheet *application-frame*))) - (window-clear window) - (setf (window-visibility window) nil)) (frame-exit *application-frame*)) diff --git a/misc/compile-xm.lisp b/misc/compile-xm.lisp index 1eba2ebd5f5f4077d03d54b87ef98b1d699c1e80..db1d12e4a28346f013a0fedd294584e4e3a22f54 100644 --- a/misc/compile-xm.lisp +++ b/misc/compile-xm.lisp @@ -20,30 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-xm.lisp,v 1.5 92/03/09 17:42:03 cer Exp Locker: cer $ +;; $fiHeader: compile-xm.lisp,v 1.6 92/03/10 10:13:13 cer Exp Locker: cer $ (in-package :user) -(setq *ignore-package-name-case* t) -(set-case-mode :case-insensitive-lower) -(setf *load-source-file-info* t) -(setf *record-source-file-info* t) -(setf *load-xref-info* nil) -(setf *record-xref-info* nil) -(setf (sys:gsgc-switch :print) nil) -(setf (sys:gsgc-switch :stats) nil) - -(setq *compile-print* nil) -(unless (find-package 'excl-defsystem) - (compile-file-if-needed "sys/defsystem") - (let ((*enable-package-locked-errors* nil)) - (load "sys/defsystem"))) -(unless (errorset (defsys::find-system 'motif-clim)) - (load "sys/sysdcl")) -(defsys::compile-system 'motif-clim :propagate t) -(tenuring - (defsys::load-system 'motif-clim)) -(compile-file-if-needed "test/test-suite") -(load "demo/sysdcl") -(defsys::compile-system 'clim-demo :propagate t) - +(load "misc/compile-1") +(compile-it 'motif-clim) diff --git a/misc/dev-load-xm.lisp b/misc/dev-load-xm.lisp index 314bbb6cd3766cac927f214d4a7205956627b914..7773737f2b1e5839ff1db305571b6844e600f107 100644 --- a/misc/dev-load-xm.lisp +++ b/misc/dev-load-xm.lisp @@ -20,33 +20,8 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-xm.lisp,v 1.3 92/02/26 10:24:03 cer Exp $ +;; $fiHeader: dev-load-xm.lisp,v 1.5 92/03/04 16:23:12 cer Exp Locker: cer $ -(excl::free (excl::malloc 131072)) -(setq *ignore-package-name-case* t) -(set-case-mode :case-insensitive-lower) - -(tenuring - (let ((*load-source-file-info* t) - (*load-xref-info* nil)) - (let ((*enable-package-locked-errors* nil)) - (load "sys/defsystem")) - (load "sys/sysdcl"))) - - -(tenuring - (let ((*load-source-file-info* t) - (*load-xref-info* nil) - (excl:*global-gc-behavior* nil)) - (defsys::load-system 'motif-clim))) - -(compile-file-if-needed "test/test-suite") - -(tenuring - (load "test/test-suite") - (load "misc/clos-preload.fasl" :if-does-not-exist nil)) - -(load "demo/sysdcl") -(tenuring - (defsys::load-system 'clim-demo)) +(load "misc/dev-load-1") +(load-it 'motif-clim) diff --git a/misc/dump.lisp b/misc/dump.lisp index c34b8fca5a17e63937ead34323fefc8958e2f669..488329b98774f231bc8ef3620dc361c71cfcd10f 100644 --- a/misc/dump.lisp +++ b/misc/dump.lisp @@ -20,12 +20,13 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dump.lisp,v 1.1 92/02/16 20:31:29 cer Exp $ +;; $fiHeader: dump.lisp,v 1.3 92/03/04 16:23:13 cer Exp Locker: cer $ ;; Assuming CLIM is loaded, dump it into /usr/tmp/clim.temp_$USER. (room t) (sys:resize-areas :global-gc t :old 1000000 :new 500000) (room t) + (dumplisp :name (concatenate 'simple-string "/tmp/clim.temp_" (sys:getenv "USER")) :checkpoint nil) diff --git a/notes/clim.todo b/notes/clim.todo index fea3f74aa13853aff866330e9c435d95998de72e..775b75d64f0cb18899fec1439dde1eb764ef7a6e 100644 --- a/notes/clim.todo +++ b/notes/clim.todo @@ -1,4 +1,4 @@ -%% $fiHeader: clim.todo,v 1.11 92/03/12 13:41:57 cer Exp Locker: cer $ +K%% $fiHeader: clim.todo,v 1.12 92/03/13 09:55:56 cer Exp Locker: cer $ %% ****************************************** SWM things @@ -103,9 +103,6 @@ those really mean to coerce to the COORDINATE type. - The per-port code will needs to "devicize" all coordinates. For example, for CLX that means integerizing, but not for PostScript. - * [swm] Reinstate graphics function optimizers. - - Is any of the CLIM 1.0 graphics-defining stuff useful? - - Is any of the ILA CLIM graphics-defining stuff useful? % Size issues * [swm] Modularize with load on demand/required modules @@ -163,70 +160,67 @@ %% ********************************************* CER things % Silica back-ends - * [cer,jdi] Xt - - Motif - - OpenLook + % Holes to fill in - * [cer] INPUT-PROTOCOL and the HANDLE-EVENT problem - - Why does INPUT-PROTOCOL-MIXIN define an input buffer? What's wrong with the - sheet event queue? - - What we really need to do is maintain a separate input buffer for the stream, - then STREAM-READ-GESTURE should loop doing HANDLE-EVENT until something gets - inserted into the stream's input buffer. When there is something in input - buffer, STREAM-READ-GESTURE should then process it. - * [cer] Define cursor protocol - * [cer] Rename DEFSYS package to CLIM-DEFSYS. + * [cer,1d] INPUT-PROTOCOL and the HANDLE-EVENT problem + - Why does INPUT-PROTOCOL-MIXIN define an input buffer? What's wrong with the + sheet event queue? + - What we really need to do is maintain a separate input buffer for the stream, + then STREAM-READ-GESTURE should loop doing HANDLE-EVENT until something gets + inserted into the stream's input buffer. When there is something in input + buffer, STREAM-READ-GESTURE should then process it. + * [cer,0.5d] Define cursor protocol + * [cer,0.5d] Rename DEFSYS package to CLIM-DEFSYS. * Sheet protocol. - - [cer] How do we deal with the case where a sheet has one children and its + - [cer,1d] How do we deal with the case where a sheet has one children and its mirror allows one children only but the sheet actually has two children, e.g., (FRAME (HORIZONTALLY () () ())). - * [cer] Multiple layouts need to allow different size reqs for the sheets. - * [cer] The code for switching layouts needs to be cleaned up. - * [cer] Protocol to compute to the WM the desired geometry of the frame. - * [cer] When the viewport is resized in might need to be moved, for example, if + * [cer,1d] Multiple layouts need to allow different size reqs for the sheets. + * [cer,1d] The code for switching layouts needs to be cleaned up. + * [cer,0.5d] Protocol to compute to the WM the desired geometry of the frame. + * [cer,0.5d] When the viewport is resized in might need to be moved, for example, if it becomes big enough to display the entire window: in the ALLOCATE-SPACE for viewport. - * [cer] Pointer documentation panes and other pane types, - * [cer] Gadget enable/disable protocol. - * [cer] On-demand scrollbars. - * [cer] Complete layout protocol - * [cer] Complete set of layout gadgets. - * [cer] writers for gadgets - * [cer] notify-user - -% Cleanups - * [cer] Sort out the whole server path mechanism and make sure we can + * [cer,0.5d] Pointer documentation panes and other pane types, + * [cer,0.5d] Gadget enable/disable protocol. + * [cer,0.5] On-demand scrollbars. + * [cer,1d] Complete layout protocol + * [cer,1d] Complete set of layout gadgets. + * [cer,1d] notify-user + * [cer,1d] Sort out the whole server path mechanism and make sure we can windows where we want. - -% Bugs to fix - * [cer] What's the problem with radio-boxes and move-cursor-after. The + * [cer,0.5d] What's the problem with radio-boxes and move-cursor-after. The alternative definitions almost work except for exit-buttons. I think the bounding rectangle of gadget output records is computed incorrectly and that it works because the UPDATE-GADGET-POSITION is broken to match. - * [cer] why? #<standard-method STREAM-READ-CHAR-NO-HANG (motif-top-level-sheet) @ #x1b18eee> - * [cer] When default-text-margin slot yet bound, drawing on a unexposed window + * [cer,0.5d] When default-text-margin slot yet bound, drawing on a unexposed window can cause problems. - * [cer] command parser uses the variable stream, + others. - * [cer] perhaps max widths ending up smaller than widths! - * [cer] :fill in box panes?? - * [cer] why do we need a pane when we read commands? - * [cer] replay-output-record is not called on output-record-mixin! + * [cer,0.5d] command parser uses the variable stream, + others rather + than gensyms + * [cer, 0.5d] perhaps max widths ending up smaller than widths! + * [cer,0.5d] replay-output-record is not called on output-record-mixin! See the method in recording-output-protocol.lisp - * [cer] I suspect that replay needs to intersect the region with the + * [cer,0.1d] I suspect that replay needs to intersect the region with the viewport - * [cer] why in the without-as-gadget code does the stream-redisplay + * [cer,0.5d] why in the without-as-gadget code does the stream-redisplay cause us to resuse an old output record and gadget. in accept-present-default results in gadgets with the (old) wrong value being used. + * Menu enhancements + - separators in menus + - In active menu items + - Labels in menus + - Hierarchical menus + * Locking + %% ******************************************* JDI things % Holes to fill in - * [jdi] Design and implement a colormap scheme + * [jdi,5d,d] Design and implement a colormap scheme - Poll the CLIM@BBN.COM mailing list to see what the requirements are. - %% **************************************** UNASSIGNED things % Silica back-ends @@ -265,7 +259,6 @@ * [all] Should we do "stream relative" coordinates (as opposed to the current "parent relative" scheme) for output records? It solves some problems, but introduces others. - * silica::shift-code is undefined in the gesture code. % Final spec conformance checking % Beefing up the test suites. @@ -276,6 +269,13 @@ * [all] Surpass CLIM 1.0 performance goals. * Add port-level (graft-level? medium-level?) caches for inks. +% Performance things + * Why does text-style-mapping need to call standardize-text-style - + in particular this interns like hell. + * transformers for draw-circle* and perhaps others. + * automagic replay-output-record to do with with-medium earlier on and use + that all the way through + % User Guide. % Demos and example code. diff --git a/silica/db-button.lisp b/silica/db-button.lisp index 1f42fd76c3e21b84bc62d7189a6b50141c0b0f3a..82ccd6675c2125774cefce1b566df0ab8373e9f5 100644 --- a/silica/db-button.lisp +++ b/silica/db-button.lisp @@ -3,7 +3,7 @@ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;; $fiHeader$ +;; $fiHeader: db-button.lisp,v 1.3 92/03/10 15:45:49 cer Exp Locker: cer $ (in-package :silica) @@ -120,7 +120,8 @@ ;; This is done in the (SETF GADGET-VALUE) method because that's where it ;; would be done in, say, Motif. (I.e. we'd pass the SET-GADGET-VALUE off ;; to Motif which would toggle the indicator.) -(defmethod (setf gadget-value) :after (nv (pane toggle-button-pane)) + +(defmethod (setf gadget-value) :after (nv (pane toggle-button-pane) &key) (when (port pane) ;; If it's not grafted, don't draw it. (with-sheet-medium (medium pane) @@ -130,8 +131,8 @@ (cx (+ left radius)) (cy (+ top (round (- bottom top) 2)))) (draw-circle* medium cx cy (round radius 2) - :ink (if (gadget-value pane) +foreground-ink+ +background-ink+)))))) - (value-changed-callback pane (gadget-client pane) (gadget-id pane) nv)) + :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 diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index b3ecc33f86c770e60cc3310e5222d4b78091e150..74135ec9704476088b17624741b1f03457d03efd 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.8 92/02/24 13:04:26 cer Exp $ +;; $fiHeader: db-layout.lisp,v 1.9 92/03/04 16:19:28 cer Exp Locker: cer $ (in-package :silica) @@ -82,6 +82,9 @@ nil) (defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port) + (note-layout-mixin-region-changed pane :port port)) + +(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))) @@ -203,7 +206,8 @@ (defmethod compose-space ((pane space-requirement-mixin) &key width height) - (slot-value pane 'space-requirement)) + (or (slot-value pane 'space-requirement) + (slot-value pane 'initial-space-requirement))) (defmethod change-space-requirement ((pane space-requirement-mixin) &rest keys) (declare (dynamic-extent keys)) @@ -244,6 +248,22 @@ slot that defaults to NIL")) :max-height max-height :min-height min-height))))) +(warn "duplicate?") + +(defmethod default-space-requirements ((pane basic-client-space-requirement-mixin) + &key (width 0) + (min-width width) + (max-width width) + (height 0) + (min-height height) + (max-height height)) + (values width + min-width + max-width + height + min-height + max-height)) + ;;;; (defclass client-space-requirement-mixin (basic-client-space-requirement-mixin) @@ -495,3 +515,19 @@ provided elsewhere")) sheet-permanently-enabled-mixin) ()) + +;;-- Does this need to be more complicated. +;; What is the correct behavior. Should it take a space requirement?? +;; and just call allocate-space + +(defclass bboard-pane (space-requirement-mixin layout-pane) + ()) + +(defmethod allocate-space ((pane bboard-pane) width height) + (declare (ignore width height)) + (dolist (child (sheet-children pane)) + (let ((space-req (compose-space child))) + (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 d5dfeb0d32302c0bab6ae6efea5b5c871be2e654..8a037c5f9b06cc8ed354cf5a677c4dd13b29455b 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.7 92/03/09 17:41:12 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.8 92/03/10 15:39:56 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -60,7 +60,10 @@ (defun update-scrollbars (vp) (with-bounding-rectangle* (minx miny maxx maxy) - (stream-output-history (sheet-child vp)) + (let ((c (sheet-child vp))) + (if (typep c 'clim-internals::output-recording-mixin) + (stream-output-history c) + c)) (with-bounding-rectangle* (vminx vminy vmaxx vmaxy) (viewport-viewport-region vp) (with-slots (horizontal-scrollbar vertical-scrollbar) @@ -70,6 +73,10 @@ (update-scrollbar horizontal-scrollbar minx maxx vminx vmaxx))))) +;;;--- In the case where the viewport is bigger than the window this +;;;code gets things kind a wrong. Checkout the thinkadot puzzl. Its +;;;cos (- (--) (- vminx)) is -ve + (defun update-scrollbar (scrollbar minx maxx vminx vmaxx) (declare (optimize (safety 0) (speed 3))) (let* ((size (truncate (* 100.0 @@ -120,7 +127,9 @@ size) (declare (ignore sheet)) (with-slots (viewport contents) client - (let* ((extent (stream-output-history contents)) + (let* ((extent (if (typep contents 'clim-internals::output-recording-mixin) + (stream-output-history contents) + contents)) (vp viewport) (viewport (viewport-viewport-region vp))) (case id @@ -146,7 +155,7 @@ (/ value (- 100 size))))) :y (bounding-rectangle-min-y viewport))))))) -(defun update-region (stream nminx nminy nmaxy nmaxx &key no-repaint) +(defun update-region (stream nminx nminy nmaxx nmaxy &key no-repaint) ;;-- I suspect that we should pass in mins and maxs since this does ;;-- assume that the window origin is 0,0 and I think that this ;;-- causes the compass menu test to fail since there are graphics at @@ -159,10 +168,10 @@ (> nmaxx r) (> nmaxy b)) (setf (sheet-region stream) - (make-bounding-rectangle (min nminx (bounding-rectangle-min-x stream)) - (min nminy (bounding-rectangle-min-y stream)) - (max nmaxx (bounding-rectangle-max-x stream)) - (max nmaxy (bounding-rectangle-max-y stream)))))) + (make-bounding-rectangle (min nminx l) + (min nminy tt) + (max nmaxx r) + (max nmaxy b))))) #+ignore (let ((width (- nmaxx nminx)) (height (- nmaxy nminy))) @@ -185,39 +194,54 @@ ;;--- Is this the correct place (update-scrollbars vp) (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))) - (dolist (region rectangles) - (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)))) - ;; 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 - (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 vp) - (draw-rectangle* medium - 0 0 - (bounding-rectangle-width region) - (bounding-rectangle-height 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 + #+ignore + (break "before shifting ~S" + (list (list left top right bottom) + (list nleft ntop nright nbottom))) + (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))) + #+ignore + (break "done shifting") + (with-sheet-medium (medium stream) + (dolist (region rectangles) + (multiple-value-call #'draw-rectangle* + medium + (bounding-rectangle* region) + :ink +background-ink+ :filled t) + #+ignore + (break "cleared region ~S" region) + (when (typep stream 'clim-internals::output-recording-mixin) + (replay (stream-output-history stream) stream + region)) + #+ignore + (break "done replay"))))) + ;; 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 vp) + (draw-rectangle* medium + 0 0 + (bounding-rectangle-width region) + (bounding-rectangle-height region) + :ink +background-ink+ :filled t)) + (replay (stream-output-history stream) stream region))))))))) @@ -524,11 +548,13 @@ (value (compute-symmetric-value min max coord min-value max-value))) (setf (gadget-value scroll-bar) value))) -(defmethod (setf gadget-value) (nv (pane scroll-bar-pane)) +;;;-- This looks like a value gadget to me + +(defmethod (setf gadget-value) (nv (pane scroll-bar-pane) &key) (with-slots (value) pane (setf value nv))) -(defmethod (setf gadget-value) :around (nv (pane scroll-bar-pane)) +(defmethod (setf gadget-value) :around (nv (pane scroll-bar-pane) &key) (declare (ignore nv)) (if (port pane) (let ((shaft (slot-value pane 'shaft-pane))) diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp index f76e833d3f594c23d4163b929c0d1b53a4023851..664d5d3fe39ab4d687a56da106f09ad989af86b8 100644 --- a/silica/db-slider.lisp +++ b/silica/db-slider.lisp @@ -3,7 +3,7 @@ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;; $fiHeader$ +;; $fiHeader: db-slider.lisp,v 1.3 92/03/10 15:45:47 cer Exp Locker: cer $ (in-package :silica) @@ -152,11 +152,8 @@ (value (compute-symmetric-value min max coord min-value max-value))) (setf (gadget-value pane) value))) -(defmethod (setf gadget-value) (nv (pane slider-pane)) - (with-slots (value) pane - (setf value nv))) -(defmethod (setf gadget-value) :around (nv (pane slider-pane)) +(defmethod (setf gadget-value) :around (nv (pane slider-pane) &key) (declare (ignore nv)) (if (port pane) (with-sheet-medium (medium pane) diff --git a/silica/framem.lisp b/silica/framem.lisp index aeca9bb9e83dd2f7ed51732392abf35973d6ef1e..fb5b7e3dc18dda0681c997389d5cfad08d963069 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.1 92/02/24 13:26:51 cer Exp $ +;; $fiHeader: framem.lisp,v 1.2 92/03/04 16:19:39 cer Exp Locker: cer $ (in-package :silica) @@ -31,12 +31,13 @@ (defvar *frame-managers* nil) -(defun find-frame-manager (&rest options) +(defun find-frame-manager (&rest options + &key (port (apply #'find-port options)) + &allow-other-keys) (declare (dynamic-extent options)) - (let ((port (apply #'find-port options))) - (second (or (assoc port *frame-managers*) + (second (or (assoc port *frame-managers*) (car (push (list port (make-frame-manager port)) - *frame-managers*)))))) + *frame-managers*))))) (defmethod make-frame-manager (port) (cerror "Make a default frame manager" @@ -62,7 +63,8 @@ (bounding-rectangle-size top-pane) (make-bounding-rectangle 0 0 width height)) - :parent (find-graft))))) + :parent (find-graft + :port (port frame)))))) (setf (frame-top-level-sheet frame) sheet (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index c1d62cd3d8ae2fa5d8c60a24eb6db0f7dfc87b21..cbf2d84cea3d9011dc62c80a4e01969aa93957a0 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.10 92/03/06 14:17:30 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.11 92/03/10 10:11:39 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -44,8 +44,7 @@ (defun invoke-callback-function (function &rest args) (declare (dynamic-extent args)) (if (consp function) - (with-stack-list* (args args (cdr function)) - (apply (car function) args)) + (apply (car function) (append args (cdr function))) (apply function args))) @@ -70,14 +69,22 @@ (with-slots (value) gadget (setf value new-value))) -(defgeneric (setf gadget-value) (nv gadget)) +(defgeneric (setf gadget-value) (nv gadget &key)) -(defmethod (setf gadget-value) (nv (gadget value-gadget)) +(defmethod (setf gadget-value) (nv (gadget value-gadget) &key) (declare (ignore nv))) -(defmethod (setf gadget-value) :after (nv (gadget value-gadget)) +;;-- What is the correct default? + +(defmethod (setf gadget-value) :after (nv (gadget value-gadget) &key invoke-callback) (with-slots (value) gadget - (setf value nv))) + (setf value nv)) + (when invoke-callback + (value-changed-callback + gadget + (gadget-client gadget) + (gadget-id gadget) + nv))) (defclass action-gadget (gadget) @@ -100,10 +107,9 @@ (defclass labelled-gadget () ((label :initarg :label :accessor gadget-label) - (alignment :initarg :halign ;--- compatibility hack - :initarg :alignment + (alignment :initarg :x-align :accessor gadget-alignment)) - (:default-initargs :label nil)) + (:default-initargs :label nil :x-align :center)) ;;--- Do the right thing #---ignore @@ -166,7 +172,7 @@ (defclass label-pane - (labelled-gadget) + (gadget labelled-gadget) ()) @@ -179,9 +185,11 @@ (value-gadget oriented-gadget) ((selections :initform nil :reader radio-box-selections) - (current-selection :initform nil - :initarg :current-selection - :accessor radio-box-current-selection))) + ;;--- think about this + (value :initform nil + :initarg :current-selection + :initarg :current + :accessor radio-box-current-selection))) (defmethod initialize-instance :after ((rb radio-box) &key choices) (let ((fr (pane-frame rb))) @@ -202,7 +210,15 @@ ;; As well as the callback mechanism a we want to specify a binding to commands (defclass text-field (value-gadget action-gadget) - ()) + ()) + +(defclass text-editor (text-field) + ((ncolumns :initarg :ncolumns + :accessor gadget-columns) + (nlines :initarg :nlines + :accessor gadget-lines)) + (:default-initargs :ncolumns 1 :nlines 1)) + ;;; Viewport @@ -223,12 +239,24 @@ (make-bounding-rectangle 0 0 width height)))) (defmethod allocate-space ((viewport viewport) width height) - ;; We do nothing to the child of a viewport - nil) + ;;-- Make sure the child is at least as big as the viewport + (let* ((child (sheet-child viewport))) + (multiple-value-bind + (cwidth cheight) + (bounding-rectangle-size child) + (when (or (< cwidth width) + (< cheight height)) + (resize-sheet* child + (max width cwidth) + (max height cheight)))))) + + (defmethod allocate-space :after ((viewport viewport) width height) (bounding-rectangle-set-size - (viewport-viewport-region viewport) width height) + (viewport-viewport-region viewport) width height) + ;; At this point it might make sense to move the viewport if it is + ;; big enough to contain the contents (update-scrollbars viewport) (viewport-region-changed (sheet-child viewport) viewport)) diff --git a/silica/graphics.lisp b/silica/graphics.lisp index ba2c43c490a9066364ea157203d2fc09f89f5473..e170062f78b4a0ca5439d4feb7cc4b90287f30e8 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.5 92/02/24 13:04:38 cer Exp $ +;; $fiHeader: graphics.lisp,v 1.6 92/03/04 16:19:43 cer Exp Locker: cer $ (in-package :silica) @@ -77,6 +77,63 @@ (eval-when (compile load eval) +(defun write-graphics-function-transformer (name + medium-graphics-function-name + unspread-argument-names + spread-arguments + spread-name + spread-argument-names + drawing-options + other-keyword-arguments + arguments) + (declare (ignore spread-arguments)) + (list + `(define-compiler-macro ,spread-name + (&whole form + medium-or-stream + ,@spread-argument-names &rest drawing-options-and-keyword-arguments) + (or (transform-graphics-function-call + medium-or-stream + ',medium-graphics-function-name + ',drawing-options + ',other-keyword-arguments + (list ,@spread-argument-names) + drawing-options-and-keyword-arguments) + form)) + `(define-compiler-macro ,name + (&whole form medium-or-stream ,@unspread-argument-names + &rest drawing-options-and-keyword-arguments) + (or (transform-graphics-function-call + medium-or-stream + ',medium-graphics-function-name + ',drawing-options + ',other-keyword-arguments + (list ,@unspread-argument-names) + drawing-options-and-keyword-arguments + ',arguments) + form)))) + +(defun generate-argument-spreading-code (x) + (if (consp x) + (destructuring-bind (argname type . names) x + (ecase type + (point-sequence + (destructuring-bind (new-name) names + (values argname + (list `(unspread-point-sequence ,argname)) + (list new-name)))) + (point + (destructuring-bind (x y) names + (values + argname + (list `(point-x ,argname) + `(point-y ,argname)) + (list x y)))))) + (values + x + (list x) + (list x)))) + (defun decode-graphics-function-arguments (arguments) (let* ((keyn (position '&key arguments)) (no-keyword (subseq arguments 0 keyn)) @@ -85,24 +142,12 @@ spread-arguments spread-argument-names) (dolist (x no-keyword) - (if (consp x) - (destructuring-bind (argname type . names) x - (push argname unspread-argument-names) - (ecase type - (point-sequence - (destructuring-bind (new-name) names - (push `(unspread-point-sequence ,argname) spread-arguments) - (push new-name spread-argument-names))) - (point - (destructuring-bind (x y) names - (push `(point-x ,argname) spread-arguments) - (push x spread-argument-names) - (push `(point-y ,argname) spread-arguments) - (push y spread-argument-names))))) - (progn - (push x unspread-argument-names) - (push x spread-arguments) - (push x spread-argument-names)))) + (multiple-value-bind + (argname spread-args spread-values) + (generate-argument-spreading-code x) + (push argname unspread-argument-names) + (dolist (x spread-args) (push x spread-arguments)) + (dolist (x spread-values) (push x spread-argument-names)))) (values (nreverse unspread-argument-names) (nreverse spread-arguments) (nreverse spread-argument-names) @@ -113,7 +158,83 @@ (intern (symbol-name (if (consp x) (car x) x)) *keyword-package*)) keyword)))) -) ;eval-when + +(defun transform-graphics-function-call (medium-or-stream + medium-graphics-function-name + drawing-options + other-keyword-arguments + required-arguments + rest-argument + &optional + arguments) + (let ((drawing-options + (mapcar #'(lambda (x) + (intern x :keyword)) + drawing-options))) + (flet ((kw-arg-keyword (x) + (intern (if (consp x) (car x) x) :keyword)) + (kw-arg-default-value (x) + (and (consp x) (second x)))) + (when (do ((args rest-argument (cddr args))) + (nil) + (cond ((null args) (return t)) + ((null (cdr args)) (return nil)) + ((not (or (member (car args) drawing-options) + (dolist (arg other-keyword-arguments) + (when (eq (kw-arg-keyword arg) (car args)) + (return t))))) + (return nil)))) + (let (bindings) + (when arguments + (setq required-arguments + (mapcan #'(lambda (arg req-arg) + (let ((g (gensym))) + (push (list g req-arg) bindings) + (if (consp arg) + (nth-value + 1 + (generate-argument-spreading-code + (cons g + (cdr arg)))) + (list g)))) + arguments + required-arguments)) + (setq bindings (nreverse bindings))) + (let* ((stuff + (do ((args rest-argument (cddr args)) + (result nil)) + ((null args) + (nreverse result)) + (let ((kw (car args)) + (value (cadr args))) + (push (list kw (gensym) value) result)))) + (medium-or-stream-name (gensym)) + (call + `(,medium-graphics-function-name + ,medium-or-stream-name + ,@required-arguments + ,@(mapcar #'(lambda (kw-arg) + (or + (second (assoc (kw-arg-keyword kw-arg) stuff)) + (kw-arg-default-value kw-arg))) + other-keyword-arguments))) + (supplied-drawing-options + (mapcan #'(lambda (do) + (let ((x (assoc do stuff))) + (and x (list do (second x))))) + drawing-options))) + + `(let ((,medium-or-stream-name ,medium-or-stream)) + (let ,bindings + (let ,(mapcar #'(lambda (x) + (list (second x) (third x))) + stuff) + ,(if supplied-drawing-options + `(with-drawing-options + (,medium-or-stream-name ,@supplied-drawing-options) + ,call) + call)))))))))) +) ;eval-when (defmacro transform-points ((transform) &rest points) @@ -220,6 +341,16 @@ (setf (get ',name 'args) '((,@spread-argument-names ,@keyword-argument-names) ,@args)) + ,@(write-graphics-function-transformer + name + medium-graphics-function-name + unspread-argument-names + spread-arguments + spread-name + spread-argument-names + drawing-options + other-keyword-arguments + arguments) (defmethod ,medium-graphics-function-name ((sheet sheet) ,@spread-argument-names ,@keyword-argument-names) @@ -250,6 +381,13 @@ ,@spread-argument-names ,@keyword-argument-names))))))) + + + + + + + (define-graphics-function draw-point ((point point x y)) :drawing-options :point diff --git a/silica/layout.lisp b/silica/layout.lisp index b63d608340a1b27cae4ecb86d89041851feed0b9..9c8f73c9f5fe12170959c052fbec0ac8ad6f8f5f 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.7 92/02/24 13:04:44 cer Exp $ +;; $fiHeader: layout.lisp,v 1.8 92/03/04 16:19:45 cer Exp Locker: cer $ (in-package :silica) @@ -104,16 +104,18 @@ ,@options)) -(defmethod resize-sheet* ((sheet sheet) width height) +(defmethod resize-sheet* ((sheet sheet) width height &key force) (when (or width height) - (with-bounding-rectangle* (minx miny maxx maxy) sheet - (when (or (and width (/= (- maxx minx) width)) - (and height (/= (- maxy miny) height))) - (setf (sheet-region sheet) - (make-bounding-rectangle - minx miny - (if width (+ width minx) maxx) - (if height (+ height miny) maxy))))))) + (with-bounding-rectangle* + (minx miny maxx maxy) sheet + (when (or force + (and width (/= (- maxx minx) width)) + (and height (/= (- maxy miny) height))) + (setf (sheet-region sheet) + (make-bounding-rectangle + minx miny + (if width (+ width minx) maxx) + (if height (+ height miny) maxy))))))) (defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) (resize-sheet* sheet width height) @@ -291,18 +293,43 @@ ;;--- CLIM 0.9 has some other methods on top-level sheets -- do we want them? -(defclass top-level-sheet - (pane - wrapping-space-mixin - mirrored-sheet-mixin - sheet-multiple-child-mixin) - ()) - -(defmethod allocate-space ((sheet top-level-sheet) width height) - (resize-sheet* (first (sheet-children sheet)) width height)) -(defmethod compose-space ((sheet top-level-sheet) &key width height) - (compose-space (first (sheet-children sheet)) :width width :height height)) +(defclass top-level-sheet + ( + ;; Have these so that we can use + clim-internals::window-stream + ;; + pane + wrapping-space-mixin + mirrored-sheet-mixin + sheet-multiple-child-mixin) + () + (:default-initargs :text-cursor nil :text-margin 10)) + + +;; invoke-with-recording-options +;; default-text-margin +;; stream-read-gesture + + +(defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port) + (if port + (multiple-value-call #'layout-frame + (pane-frame pane) + (bounding-rectangle-size pane)) + (call-next-method))) + +;(defmethod allocate-space ((sheet top-level-sheet) width height) +; ;;--- To make openlook windows fill the vertical dimension we need +; ;;--- to do this why???. Actually doing this seems to make a lot of sense +; ;;--- Perhaps what should happen is that if the sheet-region is +; ;;--- changed by the port we should layout the entire frame instead +; (clear-space-requirement-caches-in-tree (first (sheet-children sheet))) +; ;; +; (resize-sheet* (first (sheet-children sheet)) width height)) +; +;(defmethod compose-space ((sheet top-level-sheet) &key width height) +; (compose-space (first (sheet-children sheet)) :width width :height height)) (defclass leaf-pane diff --git a/silica/macros.lisp b/silica/macros.lisp index d9f3505cd98a55d823e153e2523075e3d88b6ef4..60cf9d1948d61fe1a0a66d391ab040f650906235 100644 --- a/silica/macros.lisp +++ b/silica/macros.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.lisp,v 1.5 92/03/04 16:19:46 cer Exp $ +;; $fiHeader: macros.lisp,v 1.6 92/03/10 10:11:41 cer Exp Locker: cer $ (in-package :silica) @@ -53,14 +53,15 @@ ,@body)) -(defmacro with-look-and-feel-realization ((frame-manager frame) &body forms) - `(macrolet ((realize-pane (pane-class &rest pane-options) - `(realize-pane-1 ,',frame-manager ,',frame ,pane-class - ,@pane-options))) +(defmacro with-look-and-feel-realization ((&optional frame-manager frame) &body forms) + (when (and (null frame) (null frame-manager)) + (setq frame-manager `(frame-manager *application-frame*)) + (setq frame `*application-frame*)) + `(flet ((realize-pane (pane-class &rest pane-options) + (apply #'realize-pane-1 ,frame-manager ,frame pane-class pane-options))) ,@forms)) -(defmacro realize-pane (&whole form pane-class &rest pane-options) +(defun realize-pane (pane-class &rest pane-options) (declare (ignore pane-class pane-options)) (error "~S not inside a call to ~S" - 'realize-pane 'with-look-and-feel-realization) - form) + 'realize-pane 'with-look-and-feel-realization)) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index bb71f0a1d3ba015a6776f4c8f6c04999ff3f7e55..67834d0be9e025dbe9dc2c81a032ddc7500de52c 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.11 92/03/06 14:17:31 cer Exp Locker: cer $ +;; $fiHeader: mirror.lisp,v 1.12 92/03/10 10:11:42 cer Exp Locker: cer $ (in-package :silica) @@ -250,6 +250,8 @@ ;; Compute transformation from sheet-region to mirror cordinates. (update-mirror-transformation-1 port sheet (sheet-parent sheet))) +(defvar *check-mirror-transformation* nil) + (defmethod update-mirror-transformation-1 ((port port) sheet parent) (declare (ignore parent)) ;; would imagine that a lot of the time this would be identity @@ -262,10 +264,11 @@ (- right left))) (sc-y (/ (- mirror-bottom mirror-top) (- bottom top)))) - (when (or (/= sc-x 1.0) - (/= sc-y 1.0) - (not (zerop tr-x)) - (not (zerop tr-y))) + (when (and *check-mirror-transformation* + (or (/= sc-x 1.0) + (/= sc-y 1.0) + (not (zerop tr-x)) + (not (zerop tr-y)))) (let (#+Allegro (*error-output* excl::*initial-terminal-io*)) (warn "Mirror scaling ~S,~S,~S,~S" (list tr-x tr-y sc-x sc-y) sheet diff --git a/silica/port.lisp b/silica/port.lisp index 671674a5dbbd882c773b7c449de76f52d2248fcf..76285a13e9c8bc6b55b826deec9136cc1f05182c 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.7 92/03/09 17:41:14 cer Exp Locker: cer $ +;; $fiHeader: port.lisp,v 1.8 92/03/10 10:11:43 cer Exp Locker: cer $ (in-package :silica) @@ -68,13 +68,16 @@ (mapc function *ports*)) (defgeneric restart-port (port) - (:method - ((port port)) - (when (port-process port) - (destroy-process (port-process port))) - (setf (port-process port) - (make-process #'(lambda () (port-event-loop port)) - :name "CLIM Event Dispatcher")))) + ) + +(defmethod restart-port ((port port)) + (when (port-process port) + (destroy-process (port-process port))) + (setf (port-process port) + (make-process #'(lambda () (port-event-loop port)) + :name (format nil + "CLIM Event Dispatcher for ~A" + (port-server-path port))))) (defgeneric port-event-loop (port) (:method ((port port)) @@ -110,12 +113,11 @@ (:method ((x graft)) t) (:method ((x t)) nil)) -(defun find-graft (&key (port (find-port)) - (server-path *default-server-path*) - (orientation :default) - (units :device)) - (unless port - (setq port (find-port :server-path server-path))) +(defun find-graft (&key + (server-path *default-server-path*) + (orientation :default) + (units :device) + (port (find-port :server-path server-path))) (map-over-grafts #'(lambda (graft) (when (graft-matches-spec graft orientation units) (return-from find-graft graft))) @@ -132,6 +134,8 @@ (pushnew graft (port-grafts port)) (realize-graft port graft)) + + (defmethod update-mirror-region ((port port) (sheet graft)) ;;--- I don't think we ever change the region of a graft... ) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 85dcff926caf4431f510de9a461bdf362f375e51..a9f8e62a6cf484413017328b8ecbe26db9da932b 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.6 92/02/24 13:04:55 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.7 92/03/04 16:19:55 cer Exp Locker: cer $ (in-package :silica) @@ -52,8 +52,6 @@ (error "Not one child:~S" sheet)) (car x))) -(defmethod sheet-shell (sheet) sheet) - (defun map-over-sheets (function sheet) (declare (dynamic-extent function)) (funcall function sheet) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 1649d2058605b6e6dbedf28a9a040d81ce0bbe30..db3f7877bd0706569be33dfeed08ee009f3a24fa 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.6 92/03/04 16:22:34 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.8 92/03/10 10:13:03 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -408,7 +408,7 @@ #+(and Silica Allegro) -(defsys:defsystem xlib-clim +(defsys:defsystem xlib (:default-pathname (frob-pathname "xlib") :default-binary-pathname (frob-pathname "xlib") :needed-systems (clim-standalone) @@ -424,11 +424,11 @@ #+(and Silica Allegro) -(defsys:defsystem xt-clim +(defsys:defsystem xt-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") - :needed-systems (xlib-clim) - :load-before-compile (xlib-clim)) + :needed-systems (xlib) + :load-before-compile (xlib)) ;; General stuff ("pkg") ("foreign-obj") @@ -453,11 +453,11 @@ ("xt-init")) #+(and Silica Allegro) -(defsys:defsystem xm-clim +(defsys:defsystem xm-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") - :needed-systems (xt-clim) - :load-before-compile (xt-clim)) + :needed-systems (xt-tk) + :load-before-compile (xt-tk)) ;; Motif specific stuff ("xm-classes") ("xm-init") @@ -471,11 +471,11 @@ ("make-widget")) #+(and Silica Allegro) -(defsys:defsystem ol-clim +(defsys:defsystem ol-tk (:default-pathname (frob-pathname "tk") :default-binary-pathname (frob-pathname "tk") - :needed-systems (xt-clim) - :load-before-compile (xt-clim)) + :needed-systems (xt-tk) + :load-before-compile (xt-tk)) ;; OpenLook specific stuff ("ol-classes") ("ol-init") @@ -487,8 +487,8 @@ (defsys:defsystem motif-clim (:default-pathname (frob-pathname "xm-silica") :default-binary-pathname (frob-pathname "xm-silica") - :needed-systems (xm-clim) - :load-before-compile (xm-clim)) + :needed-systems (clim-standalone xm-tk) + :load-before-compile (clim-standalone xm-tk)) ("pkg") ("xt-silica") ("xm-silica") @@ -507,8 +507,8 @@ (defsys:defsystem openlook-clim (:default-pathname (frob-pathname "xm-silica") :default-binary-pathname (frob-pathname "xm-silica") - :needed-systems (ol-clim) - :load-before-compile (ol-clim)) + :needed-systems (clim-standalone ol-tk) + :load-before-compile (clim-standalone ol-tk)) ("pkg") ("xt-silica") ("ol-silica") diff --git a/test/test-suite.lisp b/test/test-suite.lisp index b2e34ebf9e6f241644a88b4a1c71d438092ba579..3867139ebf3fcd36565bb18810e1b2a0cf2277dc 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.12 92/03/04 16:22:38 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.13 92/03/06 09:08:49 cer Exp Locker: cer $ (in-package :clim-user) @@ -2514,7 +2514,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (simple-menu-choose :iterations 10) (stream) "Pop up a simple menu of colors" (without-clim-input - (if #+Allegro (typep (sheet-port stream) 'xm-silica::xt-port) + (if #+Allegro (typep (port stream) 'xm-silica::xt-port) #-Allegro nil (sleep 1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) @@ -2532,7 +2532,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (cached-menu-choose :iterations 10) (stream) "Pop up a cached menu of colors" (without-clim-input - (if #+Allegro (typep (sheet-port stream) 'xm-silica::xt-port) + (if #+Allegro (typep (port stream) 'xm-silica::xt-port) #-Allegro nil (sleep 1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) diff --git a/test/test.lisp b/test/test.lisp index 8a603ba115eb24cc9c142742ce7eea973fb3e6a5..811ad02e8a0aabce28fa3a76a9213d20ee591a0b 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.14 92/03/04 16:22:41 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.15 92/03/09 17:41:57 cer Exp Locker: cer $ (in-package :clim-user) @@ -46,6 +46,12 @@ (define-application-frame test-frame0 () () + (:command-table test-frame) + (:pane + (scrolling () + (realize-pane 'interactor-pane)))) + +(define-application-frame test-frame01 () () (:command-table test-frame) (:pane (scrolling () @@ -217,20 +223,20 @@ (setf (car weird) (with-output-as-presentation (stream weird 'some-kinda-gadget) (surrounding-output-with-border (stream) - (with-output-as-gadget (stream) + (clim-internals::with-output-as-gadget (stream) (realize-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) + (clim-internals::with-output-as-gadget (stream) (realize-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) + (clim-internals::with-output-as-gadget (stream) (scrolling () (realize-pane 'interactor-pane))))))))) @@ -259,7 +265,7 @@ () (let* ((stream *query-io*)) (flet ((make-it (i) - (with-output-as-gadget (stream) + (clim-internals::with-output-as-gadget (stream) (realize-pane 'push-button :label (format nil "Amazing ~D" i))))) @@ -274,7 +280,7 @@ (define-test-frame-command (com-make-radio-box :name t :menu t) () (let* ((stream *query-io*)) - (with-output-as-gadget (stream) + (clim-internals::with-output-as-gadget (stream) (let* (#+ignore (frame-pane (realize-pane 'frame-pane)) (gadget (realize-pane 'radio-box @@ -338,3 +344,48 @@ (defun slider-dragged-callback (slider value) (format t "~&Slider ~A dragged to ~S" (gadget-label slider) value)) + + +(defclass insect () ()) + +(define-test-frame-command (com-make-insect :name t :menu t) + () + (let ((i (make-instance 'insect))) + (with-output-as-presentation (t i (presentation-type-of i)) + (print i)) + (terpri))) + +(define-test-frame-command (com-describe-insect :name t :menu t) + ((bug 'insect + :gesture (nil :menu t) + :prompt "Select an insect")) + (describe bug)) + + + +(define-application-frame tf99 () () + (:command-table test-frame) + (:pane + (vertically () + (outlining () + (horizontally () + (realize-pane 'push-button + :label "B1" + :activate-callback 'push-button-callback) + (realize-pane 'push-button + :label "B2" + :activate-callback 'push-button-callback))) + (outlining () + (horizontally () + (realize-pane 'toggle-button + :label "T1" + :value-changed-callback 'toggle-button-callback) + (realize-pane 'toggle-button + :label "T2" + :value-changed-callback 'toggle-button-callback))) + (outlining () + (spacing () + (realize-pane 'slider + :label "Slider" + :value-changed-callback 'slider-changed-callback + :drag-callback 'slider-dragged-callback)))))) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 5795e4e3ff06d410dc0a2da8deca8cb23528b815..909108cb0128fc3a0747fe9726ee36cf1b14c760 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.5 92/02/24 13:06:08 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.6 92/03/04 16:20:30 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,6 +30,7 @@ (second (assoc class '((scroll-bar openlook-scrollbar) (slider openlook-slider) (push-button openlook-push-button) + (label-pane openlook-label-pane) (text-field openlook-text-field) (toggle-button openlook-toggle-button) (menu-bar openlook-menu-bar) @@ -151,10 +152,6 @@ :resize-callback 'sheet-mirror-resized-callback sheet)) -(warn "This is really bogus") - -(defmethod stream-read-char-no-hang ((x openlook-top-level-sheet)) - nil) (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) @@ -263,3 +260,105 @@ (defun command-button-callback-ol (button frame item) (command-button-callback button nil frame item)) + + +;;; Label pane + +(defclass openlook-label-pane (xt-leaf-pane silica::label-pane) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-label-pane)) + (with-accessors ((label gadget-label) + (alignment gadget-alignment)) sheet + (values 'tk::static-text + (append + (list :alignment + (ecase alignment + ((:left nil) :left) + (:center :center) + (:right :right))) + (and label (list :string label)))))) + +;;; Push button + +(defclass openlook-push-button (xt-leaf-pane + push-button + openlook-action-pane) + ()) + + + +(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 + (and label (list :label label))))) + +;; + + +(defclass openlook-action-pane () ()) + +(defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-action-pane) (widget t)) + (tk::add-callback widget + :select + 'queue-active-event-ol + sheet)) + +(defmethod queue-active-event-ol ((widget openlook-action-pane) sheet) + (distribute-event + (port sheet) + (make-instance 'activate-gadget-event + :gadget sheet))) + + +;;; Text field + +(defclass openlook-text-field (xt-leaf-pane + openlook-value-pane + openlook-action-pane + text-field) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) + (parent t) + (sheet openlook-text-field)) + (with-accessors ((value gadget-value)) sheet + (values 'tk::text + (append + (and value `(:string ,value)))))) + + +;;; Value stuff +;;; I suspect that this is worthless + +(defclass openlook-value-pane () ()) + +(defmethod add-sheet-callbacks :after ((port openlook-port) (sheet + openlook-value-pane) (widget t)) + #+igore + (tk::add-callback widget + :value-changed-callback + 'queue-value-changed-event + sheet)) + +(defmethod gadget-value ((gadget openlook-value-pane)) + (if (sheet-direct-mirror gadget) + (tk::get-values (sheet-mirror gadget) :value) + (call-next-method))) + +(defmethod (setf gadget-value) (nv (gadget openlook-value-pane) &key) + (when (sheet-mirror gadget) + (tk::set-values (sheet-mirror gadget) :value nv))) + +(defmethod queue-value-changed-event (widget sheet) + (declare (ignore widget)) + (distribute-event + (port sheet) + (make-instance 'value-changed-gadget-event + :gadget sheet + :value (gadget-value sheet)))) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 052313be3443a249d9ec38e4e2c722a6c81fa056..16f0b86b179f134d20847c024180d020cbde1ab7 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.5 92/02/24 13:06:12 cer Exp $ +;; $fiHeader: ol-silica.lisp,v 1.6 92/03/04 16:20:32 cer Exp Locker: cer $ (in-package :xm-silica) @@ -32,7 +32,7 @@ 'openlook-port) (warn "Changing the default server path to ~S" - (setq *default-server-path* '(:openlook :display "localhost:0"))) + (setq *default-server-path* '(:openlook))) (defmethod port-note-cursor-change ((port openlook-port) cursor stream type old new) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index d79bc778937f122b757eecf1b61eb9286ca427eb..ddcca434c18d7738b3c4e067fc60fdd410ff4704 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.14 92/03/06 09:08:32 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.16 92/03/10 10:12:02 cer Exp Locker: cer $ (in-package :xm-silica) @@ -29,6 +29,7 @@ (push-button motif-push-button) (label-pane motif-label-pane) (text-field motif-text-field) + (silica::text-editor motif-text-editor) (toggle-button motif-toggle-button) (menu-bar motif-menu-bar) (viewport xm-viewport) @@ -66,7 +67,7 @@ (tk::get-values (sheet-mirror gadget) :value) (call-next-method))) -(defmethod (setf gadget-value) (nv (gadget motif-value-pane)) +(defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key) (when (sheet-mirror gadget) (tk::set-values (sheet-mirror gadget) :value nv))) @@ -103,9 +104,16 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-label-pane)) - (with-accessors ((label gadget-label)) sheet + (with-accessors ((label gadget-label) + (alignment gadget-alignment)) sheet (values 'tk::xm-label - (and label (list :label-string label))))) + (append + (list :alignment + (ecase alignment + ((:left nil) :beginning) + (:center :center) + (:right :end))) + (and label (list :label-string label)))))) ;;; Push button @@ -278,10 +286,6 @@ (defclass motif-top-level-sheet (top-level-sheet) ()) -(warn "This is really bogus") - -(defmethod stream-read-char-no-hang ((x motif-top-level-sheet)) - nil) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-top-level-sheet) @@ -347,6 +351,41 @@ (append (and value `(:value ,value)))))) +;;; + +(defclass motif-text-editor (xt-leaf-pane + motif-value-pane + motif-action-pane + silica::text-editor) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (sheet motif-text-editor)) + (with-accessors ((value gadget-value) + (ncolumns silica::gadget-columns) + (nlines silica::gadget-lines)) sheet + (values 'tk::xm-text + (append + (and ncolumns (list :columns ncolumns)) + (and nlines (list :rows nlines)) + (and value `(:value ,value)))))) + +(defmethod set-mirror-geometry (parent (sheet motif-text-editor) initargs) + (multiple-value-bind (left top right bottom) + (sheet-actual-native-edges* sheet) + (setf (getf initargs :x) (floor left) + (getf initargs :y) (floor top)) + initargs)) + + +(defmethod compose-space ((te motif-text-editor) &key width height) + (declare (ignore width height)) + (let ((sr (call-next-method))) + (setq sr (silica::copy-space-requirement sr)) + (setf (space-requirement-max-width sr) +fill+ + (space-requirement-max-height sr) +fill+) + sr)) ;;; Toggle button @@ -374,7 +413,7 @@ (tk::get-values (sheet-mirror gadget) :set) (call-next-method))) -(defmethod (setf gadget-value) (nv (gadget motif-toggle-button)) +(defmethod (setf gadget-value) (nv (gadget motif-toggle-button) &key) (when (sheet-direct-mirror gadget) (tk::set-values (sheet-mirror gadget) :set nv))) diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp index 3a33c8bc57a401ef019ce8a2403b1262553c7e50..c00a9b6a9c7310b6c593901356cd97a9d12f2da5 100644 --- a/tk-silica/xm-menus.lisp +++ b/tk-silica/xm-menus.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-menus.lisp,v 1.5 92/03/04 16:20:38 cer Exp Locker: cer $ +;; $fiHeader: xm-menus.lisp,v 1.6 92/03/10 15:39:59 cer Exp Locker: cer $ (in-package :xm-silica) @@ -93,17 +93,19 @@ (port-display port))) (declare (ignore ignore win1 win2 x y)) (tk::set-values menu :x root-x :y root-y) - (tk::manage-child menu) - ;; Now we have to wait - (port-force-output port) - (mp::process-wait "Returned value" #'(lambda () - ;;-- This is to deal - ;;-- with the race - ;;-- condition where - ;;-- the menu go down - ;;-- to quick - (or (not (tk::is-managed-p menu)) - value-returned))) + (loop + (when value-returned (return nil)) + (tk::manage-child menu) + ;; Now we have to wait + (port-force-output port) + (mp::process-wait "Returned value" #'(lambda () + ;;-- This is to deal + ;;-- with the race + ;;-- condition where + ;;-- the menu go down + ;;-- to quick + (or (not (tk::is-managed-p menu)) + value-returned)))) ;; destroy the menu (tk::unmanage-child menu) (values-list return-value))))) @@ -113,9 +115,12 @@ (setf (stream-text-margin menu) 1000) (let ((rec (with-output-recording-options (menu :draw nil :record t) (with-output-to-output-record (menu) - (if presentation-type - (present menu-item presentation-type :stream menu) - (funcall printer menu-item 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) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 3ce09e491597e5a23431161f586a00cc5b758f5b..af106403b6a236ef33e2e143d0ccdf2fe4bc88fe 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.4 92/02/24 13:06:24 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.5 92/03/04 16:20:40 cer Exp Locker: cer $ (in-package :xm-silica) @@ -36,14 +36,31 @@ (let ((menu-bar (slot-value frame 'menu-bar))) (if menu-bar (with-look-and-feel-realization (framem frame) - (vertically () - (realize-pane 'menu-bar + (let ((mb (realize-pane 'menu-bar :command-table (if (eq menu-bar t) (frame-command-table frame) - (find-command-table menu-bar))) - (call-next-method))) + (find-command-table + menu-bar)))) + (next (call-next-method)) + (pointer + (if (clim-internals::frame-pointer-documentationp frame) + (setf (slot-value frame 'clim-internals::pointer-documentation-pane) + (realize-pane + 'clim-internals::pointer-documentation-pane + :max-width +fill+ + ;;-- This should be a better value! + :height 15))))) + (if pointer + (vertically () mb next pointer) + (vertically () mb next)))) (call-next-method)))) + +(defmethod clim-internals::port-notify-user ((port xt-port) frame format-string &rest format-arguments) + (format excl::*initial-terminal-io* + "Notify ~a~%" + (list frame format-string format-arguments))) + ;;; (defclass presentation-event (event) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index fe5587cf0b5a8cd5f8c40af2251efff6ef91384f..987d4eeee3672c9e154b1a2dfaa0b25631d6eb78 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.11 92/03/04 16:20:43 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.12 92/03/09 17:41:28 cer Exp Locker: cer $ (in-package :xm-silica) @@ -337,7 +337,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (unless (eq mcr +everywhere+) (setq mcr (transform-region (sheet-device-transformation sheet) mcr)) (setq dr (region-intersection dr (bounding-rectangle mcr)))) - (cond ((eq dr +everywhere+) + (cond ((or #+ignore t (eq dr +everywhere+)) (setf (tk::gcontext-clip-mask gc) :none)) ((eq dr +nowhere+) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 9f724eb5ff3ba7e3517f51744a2e5977002697a7..00789c8bd71c0fec279d5f64c162c72a9e6b5460 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.13 92/03/10 10:12:04 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.14 92/03/10 15:40:01 cer Exp Locker: cer $ (in-package :xm-silica) @@ -394,6 +394,7 @@ ;;--- We do not want to specify the x,y if this is a top-level ;;sheet. (unless (typep parent 'tk::shell) + ;;--floor (setf (getf initargs :x) (floor left) (getf initargs :y) (floor top))) (setf (getf initargs :width) (floor (- right left)) @@ -417,7 +418,8 @@ (defmethod find-shell-of-calling-frame ((frame application-frame)) (let (cf) (and (setq cf (frame-calling-frame frame)) - (sheet-shell (frame-top-level-sheet cf))))) + (setq cf (frame-top-level-sheet cf)) + (sheet-shell cf)))) (defmethod find-shell-parent (port sheet) (or (and ;;--- hack alert diff --git a/tk/graphics.lisp b/tk/graphics.lisp index c101263fc93a1b3d6e446e600bba2842c7acf787..a59ed0e2b14d9769b2e88c53571520eada96acfb 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: graphics.lisp,v 1.4 92/02/24 13:03:04 cer Exp Locker: cer $ +;; $fiHeader: graphics.lisp,v 1.5 92/03/09 17:40:45 cer Exp Locker: cer $ (in-package :tk) @@ -76,6 +76,11 @@ ;; Degrade to drawing a rectilinear ellipse (values (truncate (sqrt s-1)) (truncate (sqrt s-2))))))) + (setq start-angle (round (* start-angle (/ (* 360 64) (* 2 pi))))) + (setq end-angle (round (* end-angle (/ (* 360 64) (* 2 pi))))) + (if (> end-angle start-angle) + (setq end-angle (- end-angle start-angle)) + (setq end-angle (- start-angle end-angle))) (if filled (x11:xfillarc (object-display drawable) @@ -85,8 +90,7 @@ (- center-y y-radius) (* 2 x-radius) (* 2 y-radius) - 0 - (* 360 64)) + start-angle end-angle) (x11:xdrawarc (object-display drawable) drawable @@ -95,8 +99,8 @@ (- center-y y-radius) (* 2 x-radius) (* 2 y-radius) - 0 - (* 360 64))))) + start-angle + end-angle)))) (defstub draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) @@ -186,13 +190,23 @@ (defun draw-string (drawable gc x y string &optional (start 0) end) (unless start (setq start 0)) (unless end (setq end (length string))) + #-ignore (x11::xdrawstring (object-display drawable) drawable gc x y (+ start (string-to-char* string)) - (- end start))) + (- end start)) + #+ignore + (x11:lisp-xdrawstring + (object-display drawable) + drawable + gc + x y + string + start + end)) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index fea0c40751d5dace8d9f6eaa7680bdbccb2c7c4a..5083cb466a225d864cbd9634b5b9cf46a239ff7d 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,43 +20,27 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.6 92/02/24 13:03:10 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.7 92/02/28 09:17:23 cer Exp Locker: cer $ (in-package :tk) -(defmacro symbols-from-file (file) - (with-open-file (s file :direction :input) - (do ((r nil) - (l (read-line s nil nil) (read-line s nil nil))) - ((null l) - `(quote ,r)) - (push l r)))) -(defun load-undefined-symbols-from-library (what kludges libraries) - (setq what (remove-if #'ff::get-entry-point what)) - (when what - (mapc #'foreign-functions:remove-entry-point kludges) - (load "" - :unreferenced-lib-names what - :foreign-files libraries - :print t))) - ;;;; (defvar *libxm-pathname* "/usr/motif/usr/lib/libXm.a") (defvar *libxt-pathname* "/usr/motif/usr/lib/libXt.a") -(defvar *libx11-pathname* "/usr/motif/usr/lib/libX11.a") + (defun load-from-xm () - (load-undefined-symbols-from-library - (list* "_XCopyGC" (symbols-from-file "misc/undefinedsymbols.motif")) + (x11::load-undefined-symbols-from-library + (list* "_XCopyGC" (x11::symbols-from-file "misc/undefinedsymbols.motif")) '("__unpack_quadruple" "__prod_b10000" "__carry_out_b10000" "__prod_65536_b10000") (list *libxm-pathname* *libxt-pathname* - *libx11-pathname*))) + x11::*libx11-pathname*))) (load-from-xm) diff --git a/tk/ol-classes.lisp b/tk/ol-classes.lisp index 80095d67bfc30feb26f3a0091771a3f5738e7572..f3bbf3c5ef540d493f694691786fa0390deaf4f5 100644 --- a/tk/ol-classes.lisp +++ b/tk/ol-classes.lisp @@ -20,85 +20,85 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-classes.lisp,v 1.1 92/02/16 20:30:56 cer Exp $ +;; $fiHeader: ol-classes.lisp,v 1.2 92/02/24 13:03:35 cer Exp Locker: cer $ (in-package :tk) - (defparameter *openlook-classes* '( - ;; Base classes - "_applicationShellWidgetClass" - "_compositeWidgetClass" - "_constraintWidgetClass" - "_coreWidgetClass" - "_objectClass" - "_overrideShellWidgetClass" - "_shellWidgetClass" - "_topLevelShellWidgetClass" - "_transientShellWidgetClass" - "_vendorShellWidgetClass" - "_wmShellWidgetClass" +(defparameter *openlook-classes* '( + ;; Base classes + "_applicationShellWidgetClass" + "_compositeWidgetClass" + "_constraintWidgetClass" + "_coreWidgetClass" + "_objectClass" + "_overrideShellWidgetClass" + "_shellWidgetClass" + "_topLevelShellWidgetClass" + "_transientShellWidgetClass" + "_vendorShellWidgetClass" + "_wmShellWidgetClass" - ;; OpenLook specific classes - ;; Some of these are both gadgets - ;; and widget and I think the - ;; names are the same! + ;; OpenLook specific classes + ;; Some of these are both gadgets + ;; and widget and I think the + ;; names are the same! - "_abbrevMenuButtonWidgetClass" - "_abbrevStackWidgetClass" - "_arrowWidgetClass" - "_baseWindowShellWidgetClass" - "_bulletinBoardWidgetClass" - "_buttonWidgetClass" - "_buttonGadgetClass" - "_buttonStackWidgetClass" + "_abbrevMenuButtonWidgetClass" + "_abbrevStackWidgetClass" + "_arrowWidgetClass" + "_baseWindowShellWidgetClass" + "_bulletinBoardWidgetClass" + "_buttonWidgetClass" + "_buttonGadgetClass" + "_buttonStackWidgetClass" - ;;"_buttonStackGadgetClass" + ;;"_buttonStackGadgetClass" - "_captionWidgetClass" - "_checkBoxWidgetClass" - "_controlAreaWidgetClass" - "_eventObjClass" - "_exclusivesWidgetClass" - "_flatCheckBoxWidgetClass" - "_flatExclusivesWidgetClass" - "_flatNonexclusivesWidgetClass" - "_flatWidgetClass" - "_footerPanelWidgetClass" - "_formWidgetClass" - "_helpWidgetClass" - "_listPaneWidgetClass" - "_magWidgetClass" - "_managerWidgetClass" - "_menuShellWidgetClass" - "_menuButtonWidgetClass" + "_captionWidgetClass" + "_checkBoxWidgetClass" + "_controlAreaWidgetClass" + "_eventObjClass" + "_exclusivesWidgetClass" + "_flatCheckBoxWidgetClass" + "_flatExclusivesWidgetClass" + "_flatNonexclusivesWidgetClass" + "_flatWidgetClass" + "_footerPanelWidgetClass" + "_formWidgetClass" + "_helpWidgetClass" + "_listPaneWidgetClass" + "_magWidgetClass" + "_managerWidgetClass" + "_menuShellWidgetClass" + "_menuButtonWidgetClass" - ;;"_menuButtonGadgetClass" + ;;"_menuButtonGadgetClass" - "_nonexclusivesWidgetClass" - "_noticeShellWidgetClass" - "_oblongButtonWidgetClass" - ;; "_oblongButtonGadgetClass" - "_popupWindowShellWidgetClass" - "_primitiveWidgetClass" - "_pushpinWidgetClass" - "_rectButtonWidgetClass" - "_scrollbarWidgetClass" - "_scrolledWindowWidgetClass" - "_scrollingListWidgetClass" - "_sliderWidgetClass" - "_staticTextWidgetClass" - "_stubWidgetClass" - "_textWidgetClass" + "_nonexclusivesWidgetClass" + "_noticeShellWidgetClass" + "_oblongButtonWidgetClass" + ;; "_oblongButtonGadgetClass" + "_popupWindowShellWidgetClass" + "_primitiveWidgetClass" + "_pushpinWidgetClass" + "_rectButtonWidgetClass" + "_scrollbarWidgetClass" + "_scrolledWindowWidgetClass" + "_scrollingListWidgetClass" + "_sliderWidgetClass" + "_staticTextWidgetClass" + "_stubWidgetClass" + "_textWidgetClass" ;;; This two seem to be broken! - ;; "_textEditWidgetClass" - ;;"_textPaneWidgetClass" + ;; "_textEditWidgetClass" + ;;"_textPaneWidgetClass" - "_compositeWidgetClass" - "_overrideShellWidgetClass" - "_shellWidgetClass" - "_topLevelShellWidgetClass" - "_widgetClass" - "_widgetClassRec" - "_drawAreaWidgetClass" - )) + "_compositeWidgetClass" + "_overrideShellWidgetClass" + "_shellWidgetClass" + "_topLevelShellWidgetClass" + "_widgetClass" + "_widgetClassRec" + "_drawAreaWidgetClass" + )) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index dfd5a454bf4f38a95be81c75817df79caaab47da..e9ba1b398781174c552939775de9f533a098a8d5 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.6 92/02/24 13:03:42 cer Exp Locker: cer $ +;; $fiHeader: ol-init.lisp,v 1.7 92/03/09 17:40:52 cer Exp Locker: cer $ (in-package :tk) @@ -72,6 +72,7 @@ (unless *ol-done* (ol-initialize) + (xt-initialize) (define-toolkit-classes *openlook-classes*) (setq *ol-done* t)) diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp index e265431384704f760a3b83dcc0ba31847aa1285c..6e835b7f21a647e65958b14a99b33876a58a9bac 100644 --- a/tk/xm-init.lisp +++ b/tk/xm-init.lisp @@ -20,16 +20,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-init.lisp,v 1.4 92/02/16 20:55:08 cer Exp $ +;; $fiHeader: xm-init.lisp,v 1.5 92/02/24 13:04:03 cer Exp Locker: cer $ (in-package :tk) (defvar *xm-done* nil) -(warn "This bites") - (unless *xm-done* + (xt-initialize) (define-toolkit-classes *motif-classes*) (setq *xm-done* t)) diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp index bd41af2f3f15bfd3cd3566eba96d65461ea3a28f..3bdc3c4407fba13094e21e0afbb8e5eadc62506c 100644 --- a/tk/xt-init.lisp +++ b/tk/xt-init.lisp @@ -20,14 +20,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-init.lisp,v 1.1 92/02/16 20:31:00 cer Exp $ +;; $fiHeader: xt-init.lisp,v 1.2 92/02/24 13:04:16 cer Exp Locker: cer $ (in-package :tk) (defvar *xt-done* nil) -(unless *xt-done* - (toolkit-initialize) - (define-toolkit-classes *intrinsic-classes*) - (setq *xt-done* t)) +(defun xt-initialize () + (unless *xt-done* + (toolkit-initialize) + (define-toolkit-classes *intrinsic-classes*) + (setq *xt-done* t))) diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 236816a42a1271fca7ca5c57a16a40c35563a815..1ff2e04cd506072e85e5500765c5aeef7b66abbf 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: excl-verification.lisp,v 1.4 92/02/24 13:05:36 cer Exp $ +;; $fiHeader: excl-verification.lisp,v 1.5 92/03/10 10:11:51 cer Exp Locker: cer $ (in-package :sys) @@ -31,5 +31,5 @@ You do not have patches ~{~S ~}" dont-have))) (si::rcsnote - "CLIM 2.0" + "CLIM 2.0.alpha.0" "$fiHeader: ") diff --git a/utils/packages.lisp b/utils/packages.lisp index 1872248945b2a85d220d7910e76ae04a18840783..bb4dd3802715c91e9fe755a95082cebfebcc4e9d 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.4 92/02/24 13:05:46 cer Exp $ +;; $fiHeader: packages.lisp,v 1.7 92/03/10 10:11:54 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1745,6 +1745,7 @@ pointer-event-y pointer-exit-event pointer-motion-event + port-notify-user poll-pointer port port-keyboard-input-focus @@ -2514,6 +2515,8 @@ pane-frame pane-needs-redisplay panes-need-redisplay + pane-viewport + pane-viewport-region read-frame-command reconfigure-frame redisplay-frame-command-menu @@ -2556,6 +2559,7 @@ scrolling spacing tabling + text-editor text-field text-stream-pane top-level-sheet @@ -2572,12 +2576,14 @@ disarmed-callback drag-callback gadget + gadget-alignment gadget-client gadget-id gadget-indicator-type gadget-label gadget-orientation gadget-value + label-pane menu-bar note-gadget-activated note-gadget-deactivated @@ -3240,7 +3246,6 @@ intern-text-style invoke-callback-function label-button-pane - label-pane labelled-gadget line-editor-pane list-pane @@ -3265,8 +3270,6 @@ one-of-pane outlined-pane pane-scroller - pane-viewport - pane-viewport-region parse-gesture-spec permanent-medium-sheet-output-mixin pointer-press-event diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 530668fc29f268a9f01ed8d58c1769502e112dc3..5cb7793bbaa89b20fd26e1984e0a589d0af3abd5 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.6 92/02/24 13:06:33 cer Exp Locker: cer $ +;; $fiHeader: ffi.lisp,v 1.7 92/03/09 17:41:32 cer Exp Locker: cer $ (in-package :x11) @@ -86,9 +86,9 @@ (error ":overlays used in a way we cannot handle"))))) (defmacro ,(fintern "~A~A" 'make- name) () #+ignore - (excl::malloc ,(ff::cstruct-property-length (ff::cstruct-prop name))) + `(excl::malloc ,,(ff::cstruct-property-length (ff::cstruct-prop name))) #-ignore - (ff::make-cstruct ',name)))) + `(ff::make-cstruct ',',name)))) (defun trans-slot-type (type) diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 0853e8045ab7fefd409d5109917860bfacfcb749..0a571a42673490d7509eed3ed76923d9e7550d37 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;;; $fiHeader$ +;;; $fiHeader: xlib-funs.lisp,v 1.1 92/03/06 17:07:01 cer Exp Locker: cer $ (in-package :x11) @@ -1769,7 +1769,7 @@ (gc gc) (x fixnum-int) (y fixnum-int) - (string :simple-string) + (string (:pointer char)) (start fixnum-int) (end fixnum-int))