diff --git a/Makefile b/Makefile index 81d88fc5212e063c54bd6f66cfd4902bf178c2aa..036827da66d176b22c97c730ffd3227d2963d0a2 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ -# $fiHeader$ +# $fiHeader: Makefile,v 1.4 92/01/02 15:33:41 cer Exp Locker: cer $ -SOMEDIRS=utils silica clim ws xm-silica -DIRS=$(SOMEDIRS) xlib tk +SOMEDIRS=utils silica clim ws +DIRS=$(SOMEDIRS) xlib tk xm-silica DEVICE=/dev/null CL=/usr/composer2/composer2 diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 76ac8593bbbb846f60df9d1afa9ccdae79be793b..e19c9e3649d9b5c2cc83770538d516a05edafbaa 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: accept-values.lisp,v 1.1 91/11/25 10:00:56 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.2 92/01/02 15:11:54 cer Exp Locker: cer $ (in-package :clim) @@ -276,7 +276,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved (return-values nil) (initial-query nil) avv avv-record) - (letf-globally (((stream-default-view stream) +dialog-view+)) + (letf-globally (((stream-default-view stream) + (port-dialog-view (port stream)))) (flet ((run-continuation (stream avv-record) (setf (slot-value stream 'avv-record) avv-record) (with-output-recording-options (stream :draw-p nil :record-p t) @@ -321,8 +322,6 @@ Copyright (c) 1991, Franz Inc. All rights reserved (with-end-of-page-action (:allow stream) (with-new-output-record (stream 'avv-output-record avv-record) (run-continuation stream avv-record))))))) - #+ignore - (replay avv stream) (unwind-protect (cond (own-window (size-menu-appropriately own-window @@ -336,12 +335,15 @@ Copyright (c) 1991, Franz Inc. All rights reserved (position-window-near-carefully own-window x y)) (window-expose own-window) (with-input-focus (own-window) + (replay avv stream) (run-avv))) (t ;; Ensure that bottom of the AVV is visible. I think that ;; this is OK even if the AVV is bigger than the viewport. (move-cursor-beyond-output-record (slot-value stream 'stream) avv) - (stream-ensure-cursor-visible stream) + (stream-ensure-cursor-visible + stream) + (replay avv stream) (run-avv))) (unless own-window (move-cursor-beyond-output-record (slot-value stream 'stream) avv)))) @@ -351,6 +353,7 @@ Copyright (c) 1991, Franz Inc. All rights reserved ;;; Applications can create their own AVV class and specialize this method in ;;; order to get different exit boxes. + (defmethod display-exit-boxes ((frame accept-values) stream) ;; Do the fresh-line *outside* of the updating-output so that it ;; doesn't get repositioned relatively in the X direction if the diff --git a/clim/cursor.lisp b/clim/cursor.lisp index 261a6239b1e21d6a1abad411896541054c00791d..7a2010e86ff3dece51f2f57c186bca5f9c1a08c8 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: cursor.lisp,v 1.2 92/01/02 15:33:02 cer Exp Locker: cer $ (in-package :clim-internals) @@ -157,10 +157,12 @@ (values (slot-value cursor 'width) (stream-line-height (slot-value cursor 'stream)))) +(warn "Checking for port") + (defmethod note-cursor-change ((cursor text-cursor) type old new) ;;; type is currently one of CURSOR-ACTIVE, -FOCUS, or -STATE (let ((stream (slot-value cursor 'stream))) - (when stream + (when (and stream (port stream)) (port-note-cursor-change (port stream) cursor stream type old new)))) ;;; The port needs to know about state transitions. We originally had one diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 9d738de2a8bdfa2a65f4f0acca61768f0c2cf708..e2e1977d3283b43b4f9569f94f6ccbdb510c56cb 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -21,7 +21,7 @@ ;;; ;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved. ;;; -;; $fiHeader$ +;; $fiHeader: db-stream.lisp,v 1.4 92/01/02 15:33:09 cer Exp Locker: cer $ (in-package :clim-internals) @@ -70,9 +70,10 @@ silica::pane sheet-permanently-enabled-mixin sheet-mute-input-mixin - + sheet-multiple-child-mixin + ;sheet - ;sheet-multiple-child-mixin + ;sheet-transformation-mixin ;standard-repainting-medium ;standard-sheet-input-mixin diff --git a/clim/frames.lisp b/clim/frames.lisp index c492aea63cbc9215ec6cd4ee1e7c627b2e58e953..780229ea65be497986f70ca1bae29262033d8153 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: frames.cl,v 1.4 92/01/02 15:33:14 cer Exp Locker: cer $ (in-package :clim) @@ -48,6 +48,9 @@ :initform (find-command-table 'user-command-table) :accessor frame-command-table) (top-level :initarg :top-level :accessor frame-top-level) + (current-layout :initarg :default-layout :reader frame-current-layout) + (all-panes :initform nil) + (pane-constructors :initarg :pane-constructors) ) (:default-initargs :top-level 'default-frame-top-level @@ -80,7 +83,9 @@ (defmethod adopt-frame ((framem frame-manager) (frame application-frame)) (generate-panes frame framem)) - + +;; what is this??? + (defmethod generate-panes ((frame application-frame) (framem frame-manager)) (setf (frame-panes frame) nil)) @@ -90,11 +95,21 @@ (defmacro define-application-frame (name superclasses slots &rest options) (unless superclasses (setq superclasses '(application-frame))) (let ((pane (second (assoc :pane options))) + (panes (cdr (assoc :panes options))) + (layout (cdr (assoc :layout options))) (command-definer (second (or (assoc :command-definer options) '(t t)))) (command-table (second (or (assoc :command-table options) '(t t)))) (top-level (assoc :top-level options))) + + (when (and pane panes) + (error "Cannot use :pane and :panes together")) + + (when (or (and panes (null layout)) + (and layout (null panes))) + (error ":layout and :panes must be used together")) + (cond ((null command-table)) ((symbolp command-table) (setq command-table (list command-table)))) @@ -107,15 +122,18 @@ ,superclasses ,slots (:default-initargs - ,@(and top-level `(:top-level ',(second top-level))) - ,@(and command-table - `(:command-table (clim-internals::find-command-table ',(car command-table)))))) + ,@(and layout `(:default-layout ',(car (car layout)))) + ,@(and top-level `(:top-level ',(second top-level))) + ,@(and panes `(:pane-constructors + ,(compute-pane-constructor-code panes))) + ,@(and command-table + `(:command-table (clim-internals::find-command-table ',(car command-table)))))) ,@(when command-table `((define-command-table ,(first command-table) - ,@(cdr command-table)))) + ,@(cdr command-table)))) ,@(when command-definer (compute-command-definer-code name command-table)) - ,@(compute-generate-panes-code name pane)))) + ,@(compute-generate-panes-code name pane panes layout)))) (defmacro define-frame-command (command-table-name name-and-options arguments &body body) (multiple-value-bind (command-name command-options) @@ -132,7 +150,12 @@ -(defun compute-generate-panes-code (name code) +(defun compute-generate-panes-code (name code panes layouts) + (if panes + (compute-complex-generate-panes-code name panes layouts) + (compute-simple-generate-panes-code name code))) + +(defun compute-simple-generate-panes-code (name code) (and code (let ((f (gensym)) (fm (gensym))) @@ -145,6 +168,51 @@ (,fm ,f) ,code))))))))) +(defun compute-complex-generate-panes-code (name panes layouts) + (let ((f (gensym)) + (fm (gensym))) + `((defmethod generate-panes ((,f ,name) (,fm frame-manager)) + (symbol-macrolet + ,(mapcar #'(lambda (pane-spec) + (destructuring-bind + (name code) pane-spec + `(,name (find-or-make-pane-named ,f + ',name)))) + panes) + + (let ((*application-frame* ,f)) + (setf (frame-panes ,f) + (frame-wrapper + ,f ,fm + (with-look-and-feel-realization + (,fm ,f) + (ecase (frame-current-layout ,f) + ,@(mapcar #'(lambda (layout-spec) + (destructuring-bind + (name panes) layout-spec + `(,name ,panes))) + layouts))))))))))) + +(defun find-or-make-pane-named (frame name) + (second (or (assoc name (slot-value frame 'all-panes)) + (car (push + (list name + (funcall (second (assoc name (slot-value frame 'pane-constructors))) + frame + (frame-manager frame))) + (slot-value frame 'all-panes)))))) + +(defun compute-pane-constructor-code (panes) + `(list ,@(mapcar #'(lambda (pane-spec) + (destructuring-bind + (name code) pane-spec + `(list ',name + #'(lambda (frame framem) + (with-look-and-feel-realization + (framem frame) + ,code))))) + panes))) + (defmethod frame-wrapper ((frame t) (framem t) pane) pane) @@ -176,7 +244,7 @@ (defmethod disable-frame ((frame application-frame)) (ecase (frame-state frame) - (:disabled) + ((:disowned :disabled)) ((:enabled :shrunk) (setf (frame-state frame) :disabled) (note-frame-disabled (frame-manager frame) frame)))) @@ -227,37 +295,45 @@ (unless (eq (frame-state frame) :enabled) (enable-frame frame)) - (let* ((*standard-output* (or (frame-standard-output frame) *standard-output*)) - (*query-io* (or (frame-query-io frame) *query-io*)) - (interactor (find-frame-pane-of-type frame 'interactor-pane)) - (*standard-input* (or interactor *standard-output*)) - (*command-parser* - (or command-parser - (if interactor - #'command-line-command-parser - #'menu-only-command-parser))) - (*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-only-read-remaining-arguments-for-partial-command)))) - (loop - (clim-utils::with-simple-abort-restart ("Abort Command") - (redisplay-frame-panes frame) - (when interactor - (fresh-line *standard-input*) - (if (stringp prompt) - (write-string prompt *standard-input*) - (funcall prompt *standard-input* frame))) - (let ((command (read-frame-command frame :stream *standard-input*))) - (when interactor - (terpri *standard-input*)) - ;; Need this check in case the user aborted out of a command menu - (when command - (execute-frame-command frame command))))))) + (loop + (catch 'layout-changed + (let* ((*standard-output* (or (frame-standard-output frame) *standard-output*)) + (*query-io* (or (frame-query-io frame) *query-io*)) + (interactor (find-frame-pane-of-type frame 'interactor-pane)) + (*standard-input* (or interactor *standard-output*)) + (*command-parser* + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-only-command-parser))) + (*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-only-read-remaining-arguments-for-partial-command)))) + (unless (typep *standard-input* 'excl::bidirectional-terminal-stream) + (assert (port *standard-input*))) + (unless (typep *standard-output* 'excl::bidirectional-terminal-stream) + (assert (port *standard-output*))) + (unless (typep *query-io* 'excl::bidirectional-terminal-stream) + (assert (port *query-io*))) + (loop + (clim-utils::with-simple-abort-restart ("Abort Command") + (redisplay-frame-panes frame) + (when interactor + (fresh-line *standard-input*) + (if (stringp prompt) + (write-string prompt *standard-input*) + (funcall prompt *standard-input* frame))) + (let ((command (read-frame-command frame :stream *standard-input*))) + (when interactor + (terpri *standard-input*)) + ;; Need this check in case the user aborted out of a command menu + (when command + (execute-frame-command frame command))))))))) (defmethod redisplay-frame-panes (frame &key force-p) (map-over-sheets #'(lambda (sheet) @@ -371,3 +447,29 @@ (defmethod frame-exit ((frame application-frame)) (invoke-restart 'frame-exit)) + +(defmethod (setf frame-current-layout) (nv (frame application-frame)) + (unless (eq (frame-current-layout frame) nv) + (setf (slot-value frame 'current-layout) nv) + ;; Top level sheet should loose all its child annd then we should + + (dolist (name-and-pane (slot-value frame 'all-panes)) + (let ((sheet (second name-and-pane))) + (when (silica::sheet-parent sheet) + (silica::disown-child (silica::sheet-parent sheet) sheet)))) + + (dolist (child (sheet-children (frame-top-level-sheet frame))) + (silica::disown-child (frame-top-level-sheet frame) child)) + + ;; Now we want to give it some new ones + (generate-panes frame (frame-manager frame)) + (adopt-child (frame-top-level-sheet frame) (frame-panes frame)) + (silica::clear-space-req-caches-in-tree (frame-panes frame)) + (multiple-value-call #'layout-frame + frame + (bounding-rectangle-size + (frame-top-level-sheet frame))) + (print 'throwing excl:*initial-terminal-io*) + (throw 'layout-changed nil))) + + diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index fcf334c7b6172d6ea110cc148a0b79a17dcb3133..a73f22bba0fcb016aaab25452a17e20ac842b019 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: input-defs.lisp,v 1.2 92/01/02 15:33:17 cer Exp Locker: cer $ (in-package :clim-internals) @@ -143,13 +143,15 @@ (setf (pointer-x-position pointer) native-x-position (pointer-y-position pointer) native-y-position))))) +(warn "Checking for port") + (defmethod (setf pointer-window) :before (new-value (pointer pointer)) (with-slots (window) pointer (unless (eql new-value window) (when window ;; --- horrible cross-protocol modularity violation here ;; but it's hours before AAAI - (when (output-recording-stream-p window) + (when (and (port window) (output-recording-stream-p window)) (set-highlighted-presentation window nil)))))) (defmethod query-pointer ((pointer pointer)) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 4c3c62427a9d2f9ec019835c172b93ba1ef90f1d..b7c2a9111479c7509babf3f45c1dcacd10267145 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: interactive-protocol.lisp,v 1.1 91/09/09 12:47:22 cer Exp Locker: cer $ +;; $fiHeader: interactive-protocol.lisp,v 1.1 91/11/25 10:01:09 cer Exp Locker: cer $ (in-package :clim-internals) @@ -891,7 +891,11 @@ Copyright (c) 1991, Franz Inc. All rights reserved #-excl (defmethod stream-supports-input-editing ((stream t)) nil) #+excl -(defmethod stream-supports-input-editing ((stream excl::string-input-stream)) nil) +(defmethod stream-supports-input-editing ((stream + excl::string-input-stream)) + nil) +#+excl +(defmethod stream-supports-input-editing ((stream excl::bidirectional-terminal-stream)) nil) #+Genera (defmethod si:stream-compatible-input-editing diff --git a/clim/output-recording-protocol.lisp b/clim/output-recording-protocol.lisp index 159d04f667e786ac275d04df9a73b4394b3ad543..fb807848c6a11ec59ac5675d11b837861aa1c48d 100644 --- a/clim/output-recording-protocol.lisp +++ b/clim/output-recording-protocol.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: output-recording-protocol.cl,v 1.3 92/01/02 15:33:28 cer Exp Locker: cer $ (in-package :clim-internals) @@ -31,10 +31,11 @@ (contents-ok :initform nil :accessor output-record-contents-ok) - (start-cursor-x :initform 0) - (start-cursor-y :initform 0) - (end-cursor-x :initform 0) - (end-cursor-y :initform 0))) + (start-cursor-x :initform 0) + (start-cursor-y :initform 0) + (end-cursor-x :initform 0) + (end-cursor-y :initform 0) + (stream :initform nil :accessor output-record-stream))) (defmethod output-record-set-start-cursor-position* ((r output-record-mixin) @@ -228,7 +229,21 @@ (defmethod add-output-record :after (child (record output-record)) (setf (output-record-parent child) record) - (recompute-extent-for-new-child record child)) + (recompute-extent-for-new-child record child) + (when (output-record-stream record) + (note-output-record-attached child (output-record-stream record)))) + + +(defmethod note-output-record-attached ((element output-record-mixin) stream) + (setf (output-record-stream element) stream)) + +(defmethod note-output-record-attached :after ((element output-record) stream) + (map-over-output-record-children + #'(lambda (rec) + (note-output-record-attached rec stream)) + element + +everywhere+)) + (defmethod remove-output-record (child (record output-record)) (error "cannot remove an output record: ~S,~S" child record)) @@ -240,8 +255,32 @@ record child (bounding-rectangle* child))) - +(defmethod remove-output-record :around (child (record output-record)) + (let ((stream (output-record-stream child))) + (multiple-value-prog1 + (call-next-method) + (when stream + (note-output-record-detached child))))) + + +(defmethod note-output-record-detached ((element output-record-mixin)) + (setf (output-record-stream element) nil)) + +(defmethod note-output-record-detached :after ((element output-record)) + (map-over-output-record-children + #'note-output-record-detached + element + +everywhere+)) + + +(defmethod clear-output-record :around ((record output-record)) + (when (output-record-stream record) + (map-over-output-record-children + #'note-output-record-detached + record + +everywhere+)) + (call-next-method)) (defmethod clear-output-record :after ((record output-record)) (bounding-rectangle-set-edges record 0 0 0 0)) diff --git a/clim/presentations.lisp b/clim/presentations.lisp index 7c0c3befbe0cae9357281b4a1bd6bc29a617f0de..c0e2199e2289f9ce40371863b8452a463fac34bf 100644 --- a/clim/presentations.lisp +++ b/clim/presentations.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: presentations.lisp,v 1.1 91/11/25 10:01:12 cer Exp Locker: cer $ +;; $fiHeader: presentations.lisp,v 1.2 91/12/13 10:36:54 cer Exp Locker: cer $ (in-package :clim-internals) @@ -427,10 +427,14 @@ Copyright (c) 1991, Franz Inc. All rights reserved (highlight-output-record history-window highlighted-presentation :unhighlight) (setf highlighted-presentation nil)))))) +(warn "Checking for port") + (defun find-appropriate-window (stream) ;;--- how do we hack multiple pointers? (let* ((pointer (stream-primary-pointer stream)) (window (pointer-window pointer))) ;; It ain't no good if it doesn't have a history. - (when (output-recording-stream-p window) + (when (and window + (silica::port window) + (output-recording-stream-p window)) window))) diff --git a/clim/sysdcl.lisp b/clim/sysdcl.lisp index e24a64a088648fb371ee8b07123e736309dde727..84faef1d96033016208b9c1e38cd1b4dd54bca49 100644 --- a/clim/sysdcl.lisp +++ b/clim/sysdcl.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: sysdcl.cl,v 1.4 92/01/02 15:33:34 cer Exp Locker: cer $ (defsys::defsystem :clim (:default-pathname (frob-pathname "clim")) @@ -106,6 +106,10 @@ ("surround-output") ("graph-formatting") ("text-formatting") + + ;; This is the future + ("gadget-output") + ("stream-trampolines" :load-before-compile ("defprotocol" "stream-defprotocols") )) diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index 62e233f5206848b72f73a6dcf362d2a422406982..d4b0b20e09c97cf860df2793d566d464d48cb906 100644 --- a/clim/view-defs.lisp +++ b/clim/view-defs.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: view-defs.lisp,v 1.7 91/08/05 14:35:50 cer Exp $ +;; $fiHeader: view-defs.lisp,v 1.1 91/11/25 10:01:19 cer Exp Locker: cer $ (in-package :clim) @@ -43,3 +43,23 @@ (defvar +dialog-view+ (make-instance 'dialog-view)) (defvar +menu-view+ (make-instance 'menu-view)) (defvar +iconic-view+ (make-instance 'iconic-view)) + +(defmethod stream-default-view ((stream t)) +textual-view+) +(defmethod stream-record-p ((stream t)) nil) +(defmethod stream-draw-p ((stream t)) nil) +;(defmethod with-output-recording-options-internal ((stream t) +; record-p +; draw-p +; continuation) +; (funcall continuation)) +;(defmethod stream-cursor-position* ((stream t)) (values 0 0)) + + +(defmethod port-dialog-view ((port t)) + +dialog-view+) + + +(defclass gadget-dialog-view (dialog-view) + ()) + +(defvar +gadget-dialog-view+ (make-instance 'gadget-dialog-view)) diff --git a/draw-sheets.lisp b/draw-sheets.lisp index 3eed2b34b353e8c5c6af42657283c5b98460466f..5b858b746d557f5f34f56254bb7af1628ef01dd3 100644 --- a/draw-sheets.lisp +++ b/draw-sheets.lisp @@ -34,7 +34,7 @@ sheet) :display 'gr-sheet-display :gnode-class 'sheet-gnode - :title "Sheet hierarchy" + :title "Output History" :children-fn #'(lambda (x) (clim-internals::output-record-children x)) diff --git a/misc/go.lisp b/misc/go.lisp index bbe93ba40922b83137da1c70dac91f3c36f83eae..422a57651557531a2ff1e8f2ac4862724ec8028b 100644 --- a/misc/go.lisp +++ b/misc/go.lisp @@ -39,9 +39,11 @@ (defsys::load-system :clim) + (load "xlib/sysdcl") (defsys::compile-system :xlib) -(defsys::load-system :xlib) +(tenuring (defsys::load-system :xlib)) + (load "tk/defsys.cl") (defsys::compile-system :xm-tk) @@ -56,7 +58,8 @@ #+:composer (progn - (load "draw-sheets.cl") + (excl::compile-file-if-needed "draw-sheets.cl") + (load "draw-sheets") ) (load "test/test") diff --git a/silica/db-box.lisp b/silica/db-box.lisp index fe44f49f1b035229d6345902cc186a963de2d4d8..a5dd11c1310d4dd6a965c433b5436e6dd9241c32 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -21,7 +21,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader$ +;; $fiHeader: db-box.lisp,v 1.4 92/01/02 15:33:04 cer Exp Locker: cer $ (in-package :silica) @@ -157,28 +157,6 @@ space-req-min-height) (:width :max-width :min-width :height :max-height :min-height))) - -(defmethod allocate-space ((contract hbox-pane) width height) - (with-slots (contents space space-req) contract - (unless space-req (compose-space contract)) - (let ((sizes - (allocate-space-to-items - width - space-req - contents - #'space-req-min-width - #'space-req-width - #'space-req-max-width - #'compose-space)) - (x 0)) - (mapc #'(lambda (sheet size) - (move-and-resize-sheet* - sheet x 0 (frob-size size width x) height) - (incf x size)) - contents - sizes)))) - - (defmethod allocate-space ((contract hbox-pane) width height) (flet ((move-and-resize-entry (entry min-x width height) (move-and-resize-sheet* entry min-x 0 width height))) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 3f612d55fe24b2f02f38bf4afb027ed73a44930c..21164422c10f674031fd4b30e2c49cb451f0ada4 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: db-scroll.cl,v 1.1 92/01/02 15:31:50 cer Exp Locker: cer $ (in-package :silica) @@ -75,10 +75,6 @@ (defmethod compose-space ((pane scroller-pane)) (compose-space (sheet-child pane))) -(defclass scrollbar () - ((current-value :initform nil) - (current-size :initform nil))) - (defun update-scrollbars (vp) (with-bounding-rectangle* (minx miny maxx maxy) (clim-internals::output-recording-stream-output-record diff --git a/silica/event.lisp b/silica/event.lisp index aa3785d4f3ad3acb86384725ba02fa4604df91e0..eadc98b05db7a660def0787ca4273c120ea57e89 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: event.cl,v 1.2 92/01/02 15:09:11 cer Exp Locker: cer $ (in-package :silica) @@ -429,6 +429,8 @@ +(warn "Checking for port") + (defun distribute-pointer-event (port mirrored-sheet event-type x y modifiers button) ;; Generate all the correct enter/exit events (generate-crossing-events port mirrored-sheet x y modifiers button) @@ -436,7 +438,7 @@ (let ((sheet (let ((v (port-trace-thing port))) (and (not (zerop (fill-pointer v))) (aref v (1- (fill-pointer v))))))) - (when sheet + (when (and sheet (port sheet)) (multiple-value-bind (tx ty) (untransform-point* diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index a1383537f174a1a0e2ffdfd3908c3c0b24b449d6..12c19eaf03a301a5d3c4d017c7997bceb6d1f54a 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: gadgets.cl,v 1.3 92/01/02 15:33:15 cer Exp Locker: cer $ (in-package :silica) @@ -29,7 +29,7 @@ (defclass value-gadget (gadget) ()) -(defmethod value-changed-callback ((v value-gadget) (client t) (id t) (value t)) +(defmethod value-changed-callback ((v gadget) (client t) (id t) (value t)) ()) (defgeneric gadget-value (gadget)) @@ -38,14 +38,25 @@ (defclass action-gadget (gadget) ()) -(defmethod activate-callback ((v action-gadget) (client t) (id t)) +(defmethod activate-callback ((v gadget) (client t) (id t)) ()) +;;;;;;;;;;;;;;;;;;;; The intent is that the real implementations +;;;;;;;;;;;;;;;;;;;; inherit from these ;; slider ;; push-button + +(defclass silica::push-button () ()) + ;; toggle-button ;; scroll-bar + + +(defclass scrollbar () + ((current-value :initform nil) + (current-size :initform nil))) + ;; Caption ;; option menu ;; label @@ -144,3 +155,9 @@ (defmethod handle-event ((gadget action-gadget) (event activate-gadget-event)) (activate-callback gadget (gadget-client gadget) (gadget-id gadget))) +;; Does this make sense + +(defclass foreground-background-and-text-style-mixin () + ((foreground :initform nil :initarg :foreground) + (background :initform nil :initarg :background) + (text-style :initform nil :initarg :text-style))) diff --git a/silica/layout.lisp b/silica/layout.lisp index b6cf296e77c3bada5fd521b6bde5713a51126298..2775e3ac68244df8a2901b6ceb0aecb400ee31be 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: layout.cl,v 1.3 92/01/02 15:33:21 cer Exp Locker: cer $ (in-package :silica) @@ -108,6 +108,7 @@ (if height (+ height miny) maxy))))))) (defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) + (resize-sheet* sheet width height) (let ((trans (sheet-transformation sheet))) (multiple-value-bind (x y) (transform-point* trans 0 0) @@ -117,8 +118,21 @@ (compose-translation-transformation trans (if minx (- minx x) 0) - (if miny (- miny y) 0)))) - (resize-sheet* sheet width height)))) + (if miny (- miny y) 0))))))) + + +(defmethod move-sheet* ((sheet sheet) minx miny) + (let ((trans (sheet-transformation sheet))) + (multiple-value-bind + (x y) (transform-point* trans 0 0) + (when (or (/= x minx) + (/= y miny)) + (setf (sheet-transformation sheet) + (compose-translation-transformation + trans + (- minx x) + (- miny y))))))) + ;; Various diff --git a/silica/medium.lisp b/silica/medium.lisp index efd27fc1c1654edfb2c8ec92dfc9abb5cdb5df09..b6d785e91690d5704c25cd90104882b692ff60a6 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: medium.cl,v 1.3 92/01/02 15:09:13 cer Exp Locker: cer $ (in-package :silica) @@ -26,6 +26,10 @@ (declare (ignore sheet port)) nil) +(defmethod degraft-medium (medium port sheet) + (declare (ignore sheet port)) + nil) + (defun with-sheet-medium-1 (sheet continuation) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 6bd8cbed6d38a68c05c41d4d2dabc09cbdfed287..ac470422e2c278431363124ac57d8241a608fd18 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: mirror.cl,v 1.3 92/01/02 15:09:15 cer Exp Locker: cer $ (in-package :silica) @@ -156,9 +156,17 @@ (update-mirror-transformation port sheet) mirror)) +(defmethod destroy-mirror :around ((port port) (sheet mirrored-sheet-mixin)) + (call-next-method) + (setf (sheet-direct-mirror sheet) nil)) + (defmethod note-sheet-grafted :after ((sheet mirrored-sheet-mixin)) (realize-mirror (port sheet) sheet)) +(defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin)) + (when (sheet-direct-mirror sheet) + (destroy-mirror (port sheet) sheet))) + (defmethod note-sheet-enabled ((sheet mirrored-sheet-mixin)) (call-next-method) (when (sheet-direct-mirror sheet) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 52ae357bc7913f3b2de810b4e2cd40676d1d2128..385bed15f1c4cb7df8a8052413053d8fb59be4a5 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: sheet.cl,v 1.3 92/01/02 15:09:23 cer Exp Locker: cer $ (in-package :silica) @@ -121,8 +121,9 @@ (declare (ignore graft)) (note-sheet-degrafted sheet) (setf (slot-value sheet 'port) port) - (dolist (child (sheet-children sheet)) - (setf (port child) port))) + (when (typep sheet 'sheet-parent-mixin) + (dolist (child (sheet-children sheet)) + (setf (port child) port)))) (defmethod (setf port) ((port port) sheet &key graft) (setf (slot-value sheet 'port) port @@ -132,6 +133,27 @@ (dolist (child (sheet-children sheet)) (setf (port child :graft graft) port)))) +(defmethod disown-child ((parent sheet-multiple-child-mixin) child) + (unless (eq (sheet-parent child) parent) + (error "~S is not child of ~S" child parent)) + (setf (sheet-parent child) nil) + (setf (sheet-children parent) + (delete child (sheet-children parent))) + (note-sheet-disowned child) + (when (port parent) + (setf (port child) nil))) + + +(defmethod disown-child ((parent sheet-single-child-mixin) child) + (unless (eq (sheet-parent child) parent) + (error "~S is not child of ~S" child parent)) + (setf (sheet-parent child) nil + (sheet-child parent) nil) + (note-sheet-disowned child) + (when (port parent) + (setf (port child) nil))) + + ;;;; (defgeneric map-sheet-point*-to-parent (sheet x y) @@ -335,13 +357,19 @@ (defmethod note-sheet-degrafted ((sheet permanent-medium-sheet-output-mixin)) (when (sheet-medium sheet) - (error "do something"))) + (degraft-medium (sheet-medium sheet) (port sheet) sheet) + (setf (sheet-medium sheet) nil))) (defclass temporary-medium-sheet-output-mixin (sheet-with-medium) ()) -(defclass sheet-permanently-enabled-mixin () ()) +;; This is badly named since it merely specifies the default + +(defclass sheet-permanently-enabled-mixin () + () + (:default-initargs :enabled t)) -(defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) &key) - (setf (sheet-enabled-p sheet) t)) +(defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) + &key enabled) + (setf (sheet-enabled-p sheet) enabled)) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 5c96a9ec16bb508367bb95cc1e318acffe9e6fd6..7a3a78d9caa73e153c785bd89933a7f34653f583 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*- -;; $fiHeader: test-suite.cl,v 1.2 91/12/13 10:36:59 cer Exp Locker: cer $ +;; $fiHeader: test-suite.cl,v 1.3 92/01/02 15:12:25 cer Exp Locker: cer $ (in-package :clim) @@ -1704,6 +1704,13 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-test (graphics-dialog menus-and-dialogs) (stream) "An ACCEPTING-VALUES dialog that has graphics inside of it." + (graphics-dialog-common stream)) + +(define-test (graphics-dialog-own-window menus-and-dialogs) (stream) + "An ACCEPTING-VALUES dialog that has graphics inside of it." + (graphics-dialog-common stream t)) + +(defun graphics-dialog-common (stream &optional own-window) (let ((square-dimension 100) (draw-circle t) (draw-square t) @@ -1711,55 +1718,55 @@ Luke Luck licks the lakes Luke's duck likes.")) (draw-\\-diagonal t) (line-thickness 1) (line-thickness-units :normal)) - (accepting-values (stream) - (setq square-dimension - (accept 'number :stream stream - :prompt "Size of square" :default square-dimension)) - (terpri stream) - (setq draw-circle - (accept 'boolean :stream stream - :prompt "Draw the circle" :default draw-circle)) - (terpri stream) - (setq draw-square - (accept 'boolean :stream stream - :prompt "Draw the square" :default draw-square)) - (terpri stream) - (setq draw-/-diagonal - (accept 'boolean :stream stream - :prompt "Draw / diagonal" :default draw-/-diagonal)) - (terpri stream) - (setq draw-\\-diagonal - (accept 'boolean :stream stream - :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) - (terpri stream) - (setq line-thickness - (accept 'number :stream stream - :prompt "Line thickness" :default line-thickness)) - (terpri stream) - (setq line-thickness-units - (accept '(member :normal :point) :stream stream - :prompt "Line style units" :default line-thickness-units)) - (terpri stream) - (with-room-for-graphics (stream) - (let ((radius (/ square-dimension 2))) - (with-drawing-options (stream #-Silica :line-unit #-Silica line-thickness-units - :line-thickness line-thickness) - (when draw-square - (draw-polygon* stream (list 0 0 - 0 square-dimension - square-dimension square-dimension - square-dimension 0) - :line-joint-shape :miter - :filled nil)) - (when draw-circle - (draw-circle* stream radius radius radius - :filled nil)) - (when draw-/-diagonal - (draw-line* stream 0 square-dimension square-dimension 0 - :line-cap-shape :round)) - (when draw-\\-diagonal - (draw-line* stream 0 0 square-dimension square-dimension - :line-cap-shape :round)))))))) + (accepting-values (stream :own-window own-window) + (setq square-dimension + (accept 'number :stream stream + :prompt "Size of square" :default square-dimension)) + (terpri stream) + (setq draw-circle + (accept 'boolean :stream stream + :prompt "Draw the circle" :default draw-circle)) + (terpri stream) + (setq draw-square + (accept 'boolean :stream stream + :prompt "Draw the square" :default draw-square)) + (terpri stream) + (setq draw-/-diagonal + (accept 'boolean :stream stream + :prompt "Draw / diagonal" :default draw-/-diagonal)) + (terpri stream) + (setq draw-\\-diagonal + (accept 'boolean :stream stream + :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) + (terpri stream) + (setq line-thickness + (accept 'number :stream stream + :prompt "Line thickness" :default line-thickness)) + (terpri stream) + (setq line-thickness-units + (accept '(member :normal :point) :stream stream + :prompt "Line style units" :default line-thickness-units)) + (terpri stream) + (with-room-for-graphics (stream) + (let ((radius (/ square-dimension 2))) + (with-drawing-options (stream #-Silica :line-unit #-Silica line-thickness-units + :line-thickness line-thickness) + (when draw-square + (draw-polygon* stream (list 0 0 + 0 square-dimension + square-dimension square-dimension + square-dimension 0) + :line-joint-shape :miter + :filled nil)) + (when draw-circle + (draw-circle* stream radius radius radius + :filled nil)) + (when draw-/-diagonal + (draw-line* stream 0 square-dimension square-dimension 0 + :line-cap-shape :round)) + (when draw-\\-diagonal + (draw-line* stream 0 0 square-dimension square-dimension + :line-cap-shape :round)))))))) ;;;; Benchmarks diff --git a/test/test.lisp b/test/test.lisp index 52da8762577aec18388c79e81dd7d4dc075e16c3..9af49fd4931cd2b77e702325ccd2dcfa3106c443 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -21,15 +21,33 @@ (in-package :clim) (define-application-frame test-frame () - (a b c) - (:pane - (vertically () - (silica::scrolling - () - (setq aaa - (silica::realize-pane - 'interactor-pane))) - (realize-pane 'slider)))) + (a b c) + (:pane + (vertically () + (silica::scrolling + () + (setq aaa + (silica::realize-pane + 'interactor-pane + :foreground +green+ + :background +red+))) + (realize-pane + 'silica::push-button + :label "press me" + :background (make-pattern #2A((0 0 0 1 1 0 0 0) + (0 0 1 1 1 1 0 0) + (0 1 1 1 1 1 1 0) + (1 1 1 1 1 1 1 1) + (1 1 1 1 1 1 1 1) + (0 1 1 1 1 1 1 0) + (0 0 1 1 1 1 0 0) + (0 0 0 1 1 0 0 0)) + (list +red+ +green+)) + :foreground +purple+ + :text-style + + (make-text-style + :serif :roman 20))))) (define-application-frame test-frame2 () (a b c) @@ -153,3 +171,70 @@ :max-width +fill+ :height 300 :max-height +fill+))))) + + +(define-application-frame test-frame5 () + () + (:command-table test-frame) + (:panes + (a (silica::horizontally + () + (realize-pane 'silica::push-button :label "Press me") + (realize-pane 'silica::push-button :label "Squeeze me"))) + (b (realize-pane 'silica::toggle-button)) + (c (realize-pane 'silica::slider)) + (d (realize-pane 'silica::text-field)) + (e (silica::realize-pane + 'interactor-pane + :width 300 + :max-width +fill+ + :height 300 + :max-height +fill+))) + (:layout + (:default + (vertically + () + a b c (silica::scrolling () e))) + (:more + (vertically + () + a (silica::scrolling () e) b d)))) + + + +(define-test-frame-command (com-switch :name t :menu t) + () + (setf (frame-current-layout *application-frame*) + (ecase (frame-current-layout *application-frame*) + (:default :more) + (:more :default)))) + + +(define-test-frame-command (com-make-button :name t :menu t) + () + (let* ((stream *query-io*)) + (flet ((make-it (i) + (with-output-as-gadget (:stream stream) + (realize-pane + 'silica::push-button + :label (format nil "Amazing ~D" i))))) + (format-graph-from-root + '(a (c (x) (y))) + #'(lambda (node s) + (declare (ignore s)) + (make-it (if (consp node) (car node) node))) + #'cdr + :stream stream)))) + + +#+ignore +(formatting-table (stream) + (dotimes (i 3) + (formatting-row (stream) + (dotimes (j 3) + (formatting-cell (stream) + (make-it (+ (* i 3) j))))))) + + + + diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index c74e5d1c3aa90c0b28dbce5874ee87a91d6509ee..c0162d2ba4d556862a1e83d5632a49e03764a609 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xm-frames.cl,v 1.2 92/01/02 15:09:43 cer Exp Locker: cer $ (in-package :xm-silica) @@ -238,7 +238,8 @@ Can the basic motif stuff support lazy realization? (clim-internals::frame-command-table frame)) pane))) -(defclass motif-menubar (motif-leaf-pane) +(defclass motif-menubar (motif-leaf-pane + sheet-permanently-enabled-mixin) ((command-table :initarg :command-table))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-menubar)) @@ -329,3 +330,7 @@ Can the basic motif stuff support lazy realization? (make-instance 'presentation-event :sheet (frame-top-level-sheet frame) :value (second item)))) + +(defmethod clim-internals::port-dialog-view ((port motif-port)) + clim::+gadget-dialog-view+) + diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 0a97ab002686ac868bf7a490a549bcc2d6eb0e17..a054686bee4e3c6ed4e609809a4c0a60420e373b 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$ +;; $fiHeader: xm-gadgets.cl,v 1.3 92/01/02 15:32:57 cer Exp Locker: cer $ (in-package :xm-silica) @@ -67,19 +67,26 @@ ;;; We now need a lot of classes that mirror the xm classes. -(defclass motif-pane (silica::pane) (resources)) (defmethod allocate-space ((p motif-pane) width height) (when (sheet-mirror p) (tk::set-values (sheet-mirror p) :width width :height height))) +(defclass motif-pane (silica::pane) (#+ignoreresources)) + + +#+ignore (defmethod initialize-instance :after ((x motif-pane) &rest args) (setf (slot-value x 'resources) args)) +#+ignore (defmethod find-widget-class-and-initargs-for-sheet :around (port (sheet motif-pane)) (multiple-value-bind (x y) (call-next-method) - (values x (append y (slot-value sheet 'resources))))) + (clos::doplist (key value) (slot-value sheet 'resources) + (unless (getf y key) + (setf (getf y key) value))) + (values x y))) (defclass motif-composite-pane () ()) @@ -135,17 +142,24 @@ ;;; Push button -(defclass motif-push-button (motif-leaf-pane action-gadget motif-action-pane) ()) +(defclass motif-push-button (motif-leaf-pane + action-gadget + motif-action-pane + sheet-permanently-enabled-mixin + silica::foreground-background-and-text-style-mixin + silica::push-button) + ((label-string :initarg :label-string :initform ""))) (defmethod realize-pane-arglist (realizer (type (eql 'push-button)) &rest args &key (label "")) (list* :label-string label (with-rem-keywords (args args '(:label)) - (apply #'call-next-method args)))) + (apply #'call-next-method realizer type args)))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button)) - (values 'tk::xm-push-button nil)) + (values 'tk::xm-push-button + (list :label-string (slot-value sheet 'label-string)))) ;;; This widget knows how big it wants to be so asking it returns a ;;; meaningful answer. ie. Something other than the current size. @@ -168,8 +182,9 @@ mute-repainting-mixin) ()) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-drawing-area)) - (values 'tk::xm-drawing-area (list :margin-width 0 :margin-height - 0))) + (values 'tk::xm-drawing-area (list :margin-width 0 + :resize-policy :none + :margin-height 0))) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget) (tk::add-callback widget @@ -199,14 +214,16 @@ ;;; Slider -(defclass motif-slider (motif-leaf-pane value-gadget motif-value-pane) +(defclass motif-slider (motif-leaf-pane + sheet-permanently-enabled-mixin + value-gadget motif-value-pane) ((orientation :initarg :orientation)) (:default-initargs :orientation :horizontal)) (defmethod realize-pane-arglist (realizer (type (eql 'slider)) &rest args &key orientation) (append (and orientation (list :orientation orientation)) (with-rem-keywords (args args '(:orientation)) - (apply #'call-next-method args)))) + (apply #'call-next-method realizer type args)))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-slider)) (values 'tk::xm-scale nil)) @@ -241,7 +258,7 @@ &rest args &key orientation) (list* :orientation orientation (with-rem-keywords (args args '(:orientation)) - (apply #'call-next-method args)))) + (apply #'call-next-method realizer type args)))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-scrollbar)) (values 'tk::xm-scroll-bar nil)) @@ -301,7 +318,7 @@ #+ignore sheet mirrored-sheet-mixin sheet-multiple-child-mixin - + #+ignore sheet-transformation-mixin #+ignore standard-repainting-medium #+ignore standard-sheet-input-mixin @@ -355,12 +372,15 @@ (compose-space (car (sheet-children sheet)))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-top-level-sheet)) - (values 'tk::xm-drawing-area (list :margin-width 0 :margin-height 0))) + (values 'tk::xm-drawing-area + (list :resize-policy :none + :margin-width 0 :margin-height 0))) ;;;; text field (defclass motif-text-field (motif-leaf-pane value-gadget + sheet-permanently-enabled-mixin motif-value-pane motif-action-pane) ()) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-text-field)) @@ -368,7 +388,10 @@ ;;; Toggle button -(defclass motif-toggle-button (motif-leaf-pane motif-value-pane value-gadget) +(defclass motif-toggle-button (motif-leaf-pane + sheet-permanently-enabled-mixin + motif-value-pane + value-gadget) ()) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-toggle-button)) @@ -513,6 +536,7 @@ mirrored-sheet-mixin silica::sheet-single-child-mixin + sheet-permanently-enabled-mixin #+ignore sheet-transformation-mixin #+ignore standard-repainting-medium @@ -565,6 +589,8 @@ (defmethod find-widget-class-and-initargs-for-sheet (port (sheet xm-viewport)) (values 'tk::xm-drawing-area '(:scrolling-policy :application-defined + :margin-width 0 :margin-height 0 + :resize-policy :none :scroll-bar-display-policy :static))) ; From the days when the parent used to be a motif scroll window @@ -659,3 +685,52 @@ stream (silica::xm-viewport-viewport vp)))) + +(defmethod find-widget-class-and-initargs-for-sheet + ((port motif-port) + (sheet + silica::foreground-background-and-text-style-mixin)) + (multiple-value-bind + (class initargs) + (call-next-method) + (with-slots + (silica::foreground silica::background silica::text-style) + sheet + + ;; Background can either be a pixel of a bitmap + ;; Foreground has to be a pixel + ;; clx-decode-gadget-background + ;; clx-decode-gadget-foreground + + (when silica::background + (with-sheet-medium (medium sheet) + (setf initargs + (append (clx-decode-gadget-background medium sheet silica::background) + initargs)))) + + (when silica::foreground + (with-sheet-medium (medium sheet) + (setf initargs + (append (clx-decode-gadget-foreground medium sheet silica::foreground) + initargs)))) + + (when silica::text-style + (setf (getf initargs :font-list) + (realize-text-style port silica::text-style))) + + (values class initargs)))) + +(defmethod clx-decode-gadget-background (medium sheet ink) + (declare (ignore sheet)) + (let ((gc (clx-decode-ink ink medium))) + (if (tk::gcontext-tile gc) + (list :background-pixmap (tk::gcontext-tile gc)) + (list :background (tk::gcontext-foreground gc))))) + + +(defmethod clx-decode-gadget-foreground (medium sheet ink) + (declare (ignore sheet)) + (let ((gc (clx-decode-ink ink medium))) + (if (tk::gcontext-tile gc) + (error "Gadget foreground cannot be pixmap") + (list :foreground (tk::gcontext-foreground gc))))) diff --git a/tk-silica/xm-graphics.lisp b/tk-silica/xm-graphics.lisp index 26ac891c2fdfa61d447c8787f2b09951af93cdc9..8452b833c36832ea101f9aa95e533d2685595d89 100644 --- a/tk-silica/xm-graphics.lisp +++ b/tk-silica/xm-graphics.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xm-graphics.cl,v 1.2 92/01/02 15:09:46 cer Exp Locker: cer $ (in-package :xm-silica) @@ -53,6 +53,18 @@ :drawable drawable))) (recompute-gcs medium)))) +(defmethod silica::degraft-medium :after (medium (port motif-port) sheet) + (declare (ignore sheet)) + (with-slots + (foreground-gcontext background-gcontext flipping-gcontext) + medium + (macrolet ((loose-gc (gc) + `(when ,gc + (tk::free-gcontext ,gc) + (setf ,gc nil)))) + (loose-gc foreground-gcontext) + (loose-gc background-gcontext) + (loose-gc flipping-gcontext)))) (defun recompute-gcs (medium) (with-slots diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 2a6d620b6b2b7ff0575ce3bf45b0bc66f0737732..35d875d86d1a332206f2e22cd35cb2dcc22e9fe6 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xm-silica.cl,v 1.2 92/01/02 15:09:47 cer Exp Locker: cer $ (in-package :xm-silica) @@ -150,6 +150,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmethod silica::destroy-mirror ((port motif-port) sheet) + (tk::destroy-widget (sheet-direct-mirror sheet))) (defmethod realize-mirror ((port motif-port) sheet) (multiple-value-bind @@ -157,6 +159,7 @@ (find-widget-class-and-initargs-for-sheet port sheet) (let ((widget (apply #'make-instance class :parent (find-widget-parent port sheet) + :managed (sheet-enabled-p sheet) initargs))) (add-sheet-callbacks port sheet widget) widget))) @@ -326,7 +329,10 @@ (sheet-mirror ma)))) (defmethod find-shell-class-and-initargs (port sheet) - (values 'top-level-shell nil)) + (values 'top-level-shell + ;; Need this so that an interactive pane can have children + ;; but still accept the focus + '(:keyboard-focus-policy :pointer))) (defmethod enable-mirror (port sheet) (declare (ignore port)) @@ -334,6 +340,10 @@ (typecase (widget-parent mirror) (null) (top-level-shell + ;; this is a nasty hack just to make sure that the child is managed. + ;; top-level-sheets are created unmanaged because they are + ;; disabled to we have to do not! + (manage-child mirror) (popup (widget-parent mirror))) (t (manage-child mirror))))) @@ -406,7 +416,8 @@ (/= target-top ny) (/= w nw) (/= h nh)) - (warn "Geo set fail, ~S,~S" + (warn "Geo set fail, ~S, ~S,~S" + sheet (list target-left target-top w h) (list nx ny nw nh)))))) diff --git a/tk/defsys.lisp b/tk/defsys.lisp index 9eb4a5288808dec1b0931d521589b3e6b8c138f5..c5ca1272746a7622e9bd4bf4969d6c879236cb7e 100644 --- a/tk/defsys.lisp +++ b/tk/defsys.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: defsys.cl,v 1.2 92/01/02 15:08:37 cer Exp Locker: cer $ (defsys::defsystem :xm-tk @@ -57,7 +57,7 @@ (|xm-init|) (|xm-widgets|) - + (|xm-font-list|) (|xm-protocols|) (|examples|) diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp index 56aedb4863a32cbe80fda5b668a11d7f32cc39e9..d56129365dbc947f480e7c4876a638d3a87ab2ee 100644 --- a/tk/foreign-obj.lisp +++ b/tk/foreign-obj.lisp @@ -20,13 +20,17 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: foreign-obj.cl,v 1.2 92/01/02 15:08:42 cer Exp Locker: cer $ (in-package :tk) (defclass handle-class () ((handle :initarg :handle :reader object-handle))) +(defmethod invalidate-object-handle ((object handle-class) handle) + (declare (ignore handle)) + (slot-makunbound object 'handle)) + ;;; There should be multiple mappings: ;;; Xid -> object @@ -50,6 +54,10 @@ (setf (gethash handle *address->object-mapping*) object) object) +(defun unregister-address (object &optional (handle (object-handle object))) + (remhash handle *address->object-mapping*) + (invalidate-object-handle object handle)) + (defun register-xid (object &optional (handle (object-handle object))) (setf (gethash handle *xid->object-mapping*) object) object) diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 2214315bed4df31a7122275e3a3776c16cacaa02..0ff15838ef9a54f324b09b5f0bd4219123116560 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: gcontext.cl,v 1.2 92/01/02 15:08:43 cer Exp Locker: cer $ (in-package :tk) @@ -133,6 +133,14 @@ (when dashes (setf (gcontext-dashes gcontext) dashes)) gcontext) + + +(defun free-gcontext (gc) + (x11:xfreegc + (display-handle (object-display gc)) + (object-handle gc)) + (unregister-address gc)) + (defun lispify-function-name (name) (intern (substitute #\_ #\- (symbol-name (lispify-tk-name name))))) @@ -293,7 +301,12 @@ (or font (query-font display x))))) -(defun decode-pixmap (x) x) +(defun decode-pixmap (x) + (and (/= #16rffffffff x) + (intern-object-xid + x + 'pixmap))) + (defun decode-clip-mask (x) x) (defun decode-enum (x y) (or (elt y x) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 09511905e898664fa4425ccd8bc22660f0dc8795..d4da90e49553d7614c8733bfb274bd738cfdbb5c 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: make-classes.cl,v 1.2 92/01/02 15:08:52 cer Exp Locker: cer $ (in-package :tk) @@ -64,7 +64,7 @@ :type (lispify-resource-type (char*-to-string (x-resource-type (x-resource-list resources i))))) r)) - (x-free resources) + (xt_free resources) r))) (defun get-resource-list (class) diff --git a/tk/resources.lisp b/tk/resources.lisp index d64bba28d1c4065464aae55a0cc9686609533334..f2f7aec0a813d458075f2aef0b4fb34c74c82203 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: resources.cl,v 1.2 92/01/02 15:08:58 cer Exp Locker: cer $ (in-package :tk) @@ -119,9 +119,11 @@ (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value) (convert-resource-in class type value)) +(defconstant xm_string_default_char_set "") + (defmethod convert-resource-in (class (type (eql 'xm-string)) value) (with-ref-par ((string 0)) - (string_get_l_to_r value "" string) + (string_get_l_to_r value xm_string_default_char_set string) (char*-to-string (aref string 0)))) (defmethod convert-resource-out ((parent t) (type (eql 'separator-type)) value) @@ -277,3 +279,7 @@ +(defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) + (etypecase value + (pixmap + (encode-pixmap value)))) diff --git a/tk/widget.lisp b/tk/widget.lisp index 6150e57bc2bef99ba07babaa7bd37a5601548b81..53a0914a3f3cface88270cece6cdb574ed8c4ad5 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: widget.cl,v 1.4 92/01/02 15:32:53 cer Exp Locker: cer $ (in-package :tk) @@ -90,6 +90,12 @@ (unmanage_child (object-handle child))) +(defforeign 'destroy_widget + :entry-point "_XtDestroyWidget") + +(defun destroy-widget (widget) + (destroy_widget (object-handle widget))) + (defforeign 'create_popup_shell :entry-point "_XtCreatePopupShell") diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 4647a11a813ed366f182dd713fcb9c66c304d3ba..c0c13899641f9612bd070561da440fe779f4318f 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xlib.cl,v 1.2 92/01/02 15:09:01 cer Exp Locker: cer $ (in-package :tk) @@ -51,16 +51,20 @@ (defforeign 'x_create_pixmap :entry-point "_XCreatePixmap") -(defmethod initialize-instance :after ((p pixmap) &key width height - depth drawable) - (setf (slot-value p 'handle) - (x_create_pixmap - (display-handle display) - (object-handle drawable) - width - height - depth)) - (register-address p)) +(defmethod initialize-instance :after ((p pixmap) &key handle + width + height + depth + drawable) + (unless handle + (setf (slot-value p 'handle) + (x_create_pixmap + (display-handle display) + (object-handle drawable) + width + height + depth)) + (register-xid p))) (defun-c-callable x-error-handler (display (x :unsigned-long)) (error "x-error:~S" diff --git a/tk/xtk.lisp b/tk/xtk.lisp index c8b49cd2a6b703513dd8f594b6ed58c5c37d20e3..bfb02b6d68569d6752d9572a95717cbbed5d314f 100644 --- a/tk/xtk.lisp +++ b/tk/xtk.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xtk.cl,v 1.2 92/01/02 15:09:05 cer Exp Locker: cer $ (in-package :tk) @@ -57,7 +57,7 @@ (defforeign 'initialize-widget-class :entry-point "_XtInitializeWidgetClass") -(defforeign 'x-free :entry-point "_XtFree") +(defforeign 'xt_free :entry-point "_XtFree") (defforeign 'toolkit-initialize :entry-point "_XtToolkitInitialize") diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 9cffd016afb4f893a1fefd1fe1b26b655f8e3125..7df59fb305c31f170efa7fd259f3970b1bd9681c 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -88,13 +88,40 @@ (ignore type indicies) type `(,@indicies ,type)))))) +#+ignore (defmacro def-exported-foreign-function ((name &rest options) &rest args) `(progn (export ',name :x11) (foreign-functions:defforeign ',name :arguments ',(mapcar #'(lambda (x) x t) args) - :entry-point ,(second (assoc :name options))))) + :entry-point ,(second (assoc :name options))))) + + +;; delay version + +(defmacro def-exported-foreign-function ((name &rest options) &rest args) + `(progn + (export ',name :x11) + (eval-when (compile eval) + (delayed-defforeign + ',name + :arguments ',(mapcar #'(lambda (x) x t) args) + :entry-point ,(second (assoc :name options)))))) + +(defparameter *defforeigned-functions* nil + "A list of name and defforeign arguments") + +(defun delayed-defforeign (name &rest arguments) + (setf *defforeigned-functions* + (delete name *defforeigned-functions* :key #'car)) + (push (cons name arguments) *defforeigned-functions*)) + + +(defmacro defforeign-functions-now () + `(ff:defforeign-list ',*defforeigned-functions*)) + +;;; End of delay version (defmacro def-exported-foreign-macro ((name &rest options) &rest args) `(def-exported-foreign-function (,name ,@options) ,@args)) diff --git a/xlib/sysdcl.lisp b/xlib/sysdcl.lisp index c69b6686f1ca075f9c88259ac30c25607bdc6aa3..954cb6fbe0010a3e5a8b6efb5c30631063ec5018 100644 --- a/xlib/sysdcl.lisp +++ b/xlib/sysdcl.lisp @@ -1,4 +1,4 @@ -(defsys::defsystem :xlib +;; -*- mode: common-lisp; package: user -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,11 +18,15 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; - (:default-pathname (frob-pathname "xlib")) +;; $fiHeader$ + +(defsys::defsystem :xlib + (:default-pathname (frob-pathname "xlib")) (|pkg|) (|ffi|) (|xlib|) - (|x11-keysyms|)) + (|x11-keysyms|) + (|last|))