diff --git a/ChangeLog.n b/ChangeLog.n index 808bada58346ae4ed28c3f87415b6e13c06039bd..cf5fba2ffddb5af3e5b878ebdb848a8728d6979d 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,27 @@ +from cer: Mon Oct 25 09:13:49 PDT 1993 + +Makefile.defs Removed clim-motif_d.o from default build +clim/accept-values.lisp make-pane-from-view takes keywords to remove +clim/command-processor.lisp correct defaulting of translator :pointer-documentation +clim/db-stream.lisp Explicit max/min width/height overides :width/height :compute +clim/gadget-output.lisp make-pane-from-view takes keywords to remove + text-editor and list-pane views take :scroll-bars argument +clim/graph-formatting.lisp Implement :center-nodes t for tree layout +clim/graphics-recording.lisp Added with-half-thickness-1 for use in xt-graphics +clim/menus.lisp Removed bogus calling frame method + frame-manager-get-menu takes parent-frame argument +clim/recording-protocol.lisp Added COMMENTED OUT (setf stream-output-history) method +clim/view-defs.lisp make-pane-from-view takes keywords to remove +climtoys/ibparts.lisp Nothing serious +demo/demo-driver.lisp Added (*package* (find-package :clim-demo)) binding in demo-driver +demo/plot.lisp Removed bogus command +misc/undefinedsymbols.xt Added XtAppSetFallbackResources +silica/db-scroll.lisp Added x,y arguments to note-viewport-position-changed +test/test-clim.lisp Added test +test/test-driver.lisp If process does not terminate you now get an error. +test/test-suite.lisp Added centered node grapher test + + from cer: Wed Sep 22 14:19:31 PDT 1993 Makefile.defs -> devel.18 diff --git a/Makefile.defs b/Makefile.defs index 143958c13f6ea43499e887d534d460002ff6303e..64c3f8830cd23f88433867df6b501219b8096b5d 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.22 1993/09/22 18:26:12 layer Exp $ +# $fiHeader: Makefile.defs,v 1.23 1993/09/22 21:20:56 cer Exp $ # # Makefile.defs for CLIM 2.0 # @@ -141,7 +141,12 @@ OL_PUBLIC_OBJS= stub-olit.o olsupport.o PUBLIC_OBJS= $(GENERIC_PUBLIC_OBJS) $(XM_PUBLIC_OBJS) $(OL_PUBLIC_OBJS) OL_LICENSED_OBJS = clim-olit.o clim-olit_d.o -XM_LICENSED_OBJS = clim-motif_d.o clim-motif.o + +# mostly not used. +#CLIMMOTIF_D= clim-motif_d.o +CLIMMOTIF_D= + +XM_LICENSED_OBJS = $(CLIMMOTIF_D) clim-motif.o MOTIF_OBJS= $(GENERIC_PUBLIC_OBJS) $(XM_PUBLIC_OBJS) $(XM_LICENSED_OBJS) OPENLOOK_OBJS= $(GENERIC_PUBLIC_OBJS) $(OL_PUBLIC_OBJS) $(OL_LICENSED_OBJS) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 77030a42a49d1d2e409885a7018c2a60f99c9227..0b2997be3c6cda61f647730b8b88e2b275c7f27a 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.69 1993/09/17 19:04:56 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.70 1993/09/22 21:21:04 cer Exp $ (in-package :clim-internals) @@ -1577,7 +1577,7 @@ :resynchronize resynchronize))) (make-pane-from-view 'push-button - view + view () :id record :client client :activate-callback #'(lambda (button) (when (accept-values-query-valid-p nil record) ;---can't be right diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index 643697ebce7255465ad84b8296dcdf94f94720ff..3aff1bbd1af2c78e74569abfd059bbe7c282d6b3 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.22 1993/07/27 01:38:27 colin Exp $ +;; $fiHeader: command-processor.lisp,v 1.23 1993/09/17 19:05:00 cer Exp $ (in-package :clim-internals) @@ -852,12 +852,16 @@ :gesture ,gesture :tester ,tester :documentation ,documentation + ;; Old behavior ;; The pointer documentation defaults to the name of the command, ;; not the documentation. This is a speed bum. - :pointer-documentation ,(or pointer-documentation - (if (stringp documentation) - documentation - (command-name-from-symbol command-name))) + ;; New Behavior is to to the right thing. If only + ;; documentation is specified then rely on the + ;; appropriate defaulting down the line to ensure that + ;; we dont get duplicate functions. + ,@(and (or pointer-documentation (null documentation)) + `(:pointer-documentation ,(or pointer-documentation + (command-name-from-symbol command-name)))) :menu ,menu :priority ,priority :tester-definitive t diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index f6c2a8aae3e0cf78f4272acb33d60a680a698b23..367302c15ac118af37ff88bd5805107321d82eb0 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.56 1993/07/27 01:38:51 colin Exp $ +;; $fiHeader: db-stream.lisp,v 1.57 1993/08/12 16:02:59 cer Exp $ (in-package :clim-internals) @@ -177,95 +177,115 @@ ,@body))) (defmethod compose-space ((pane clim-stream-pane) &key width height) - (let ((sr (call-next-method))) - (labels + (compute-space-for-clim-stream-pane pane (call-next-method) width height)) + +(defun compute-space-for-clim-stream-pane (pane sr width height) + (labels ((process-compute-space-requirements () (with-space-requirement (sr) (when (do-with-space-req-components or - sr-component - (sr-width sr-min-width sr-max-width - sr-height sr-min-height sr-max-height) + sr-component + (sr-width sr-min-width sr-max-width + sr-height sr-min-height sr-max-height) (eq sr-component :compute)) (multiple-value-bind (width height) (let ((record - (let ((history (stream-output-history pane))) - (if (and history - (> (output-record-count history :fastp t) 0)) - history - (let ((*sizing-application-frame* t)) - (with-output-to-output-record (pane) - (funcall - (if (slot-value pane 'incremental-redisplay-p) - #'invoke-pane-redisplay-function - #'invoke-pane-display-function) - (pane-frame pane) pane - ;;--- Are all pane display functions prepared to - ;;--- ignore these arguments? I think not... - :max-width width - :max-height height))))))) + (let ((history (stream-output-history pane))) + (if (and history + (> (output-record-count history :fastp t) 0)) + history + (let ((*sizing-application-frame* t)) + (with-output-to-output-record (pane) + (funcall + (if (slot-value pane 'incremental-redisplay-p) + #'invoke-pane-redisplay-function + #'invoke-pane-display-function) + (pane-frame pane) pane + ;;--- Are all pane display functions prepared to + ;;--- ignore these arguments? I think not... + :max-width width + :max-height height))))))) (with-bounding-rectangle* (left top right bottom) record (values (- right (min 0 left)) (- bottom (min 0 top))))) (when (zerop width) (setq width 100)) (when (zerop height) (setq height 100)) + + (flet ((process-computes (size preferred min max) + (values + (if (eq preferred :compute) + (let ((size size)) + (when (numberp min) (maxf size min)) + (when (numberp max) (minf size max)) + size) + preferred) + (if (eq min :compute) size min) + (if (eq max :compute) size max)))) + (multiple-value-setq (sr-width sr-min-width sr-max-width) + (process-computes width sr-width sr-min-width sr-max-width)) + (multiple-value-setq (sr-height sr-min-height sr-max-height) + (process-computes height sr-height sr-min-height sr-max-height))) + + #+ignore (do-with-space-req-components progn - sr-component (sr-width sr-min-width sr-max-width) + sr-component (sr-width sr-min-width sr-max-width) (when (eq sr-component :compute) (setq sr-component width))) + #+ignore (do-with-space-req-components progn - sr-component (sr-height sr-min-height sr-max-height) + sr-component (sr-height sr-min-height sr-max-height) (when (eq sr-component :compute) (setq sr-component height)))) (setq sr (make-sr))))) - (process-unit-space-requirements () - (with-space-requirement (sr) - (let ((changed nil)) - (do-with-space-req-components progn - sr-component - (sr-width sr-min-width sr-max-width - sr-height sr-min-height sr-max-height) - (when (unit-space-requirement-p sr-component) - (setq sr-component (process-unit-space-requirement pane sr-component) - changed t))) - (when changed - (setq sr (make-sr)))))) - (process-relative-space-requirements () - (with-space-requirement (sr) - (unless (and (numberp sr-width) - (numberp sr-height) - (do-with-space-req-components and - sr-component - (sr-min-width sr-max-width - sr-min-height sr-max-height) - (or (numberp sr-component) - (relative-space-requirement-p sr-component)))) - (error "Illegal space requirement ~S" sr)) - (let ((changed nil)) - (when (relative-space-requirement-p sr-min-width) - (setq sr-min-width (- sr-width (process-unit-space-requirement + (process-unit-space-requirements () + (with-space-requirement (sr) + (let ((changed nil)) + (do-with-space-req-components progn + sr-component + (sr-width sr-min-width sr-max-width + sr-height sr-min-height sr-max-height) + (when (unit-space-requirement-p sr-component) + (setq sr-component (process-unit-space-requirement pane sr-component) + changed t))) + (when changed + (setq sr (make-sr)))))) + (process-relative-space-requirements () + (with-space-requirement (sr) + (unless (and (numberp sr-width) + (numberp sr-height) + (do-with-space-req-components and + sr-component + (sr-min-width sr-max-width + sr-min-height sr-max-height) + (or (numberp sr-component) + (relative-space-requirement-p sr-component)))) + (error "Illegal space requirement ~S" sr)) + (let ((changed nil)) + (when (relative-space-requirement-p sr-min-width) + (setq sr-min-width (- sr-width (process-unit-space-requirement pane (car sr-min-width))) - changed t)) - (when (relative-space-requirement-p sr-max-width) - (setq sr-max-width (+ sr-width (process-unit-space-requirement + changed t)) + (when (relative-space-requirement-p sr-max-width) + (setq sr-max-width (+ sr-width (process-unit-space-requirement pane (car sr-max-width))) - changed t)) - (when (relative-space-requirement-p sr-min-height) - (setq sr-min-height (- sr-height (process-unit-space-requirement + changed t)) + (when (relative-space-requirement-p sr-min-height) + (setq sr-min-height (- sr-height (process-unit-space-requirement pane (car sr-min-height))) - changed t)) - (when (relative-space-requirement-p sr-max-height) - (setq sr-max-height (+ sr-height (process-unit-space-requirement + changed t)) + (when (relative-space-requirement-p sr-max-height) + (setq sr-max-height (+ sr-height (process-unit-space-requirement pane (car sr-max-height))) - changed t)) - (when changed - (setq sr (make-sr))))))) - (declare (dynamic-extent #'process-compute-space-requirements - #'process-unit-space-requirements - #'process-relative-space-requirements)) - (process-compute-space-requirements) - (process-unit-space-requirements) - (process-relative-space-requirements) - sr))) + changed t)) + (when changed + (setq sr (make-sr))))))) + (declare (dynamic-extent #'process-compute-space-requirements + #'process-unit-space-requirements + #'process-relative-space-requirements)) + (process-unit-space-requirements) + (process-compute-space-requirements) + (process-relative-space-requirements) + sr)) (defun relative-space-requirement-p (sr) (and (consp sr) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 0b0ecbdd9fba4c3d362113d1629f6590813a06cb..0b1b8ad330595d34f6596e18f94d1766779f83d0 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.52 1993/07/27 01:39:32 colin Exp $ +;; $fiHeader: gadget-output.lisp,v 1.53 1993/09/07 21:45:50 colin Exp $ (in-package :clim-internals) @@ -484,7 +484,7 @@ (deactivate-gadget button)) (setf (gadget-value button) default))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let ((button (make-pane-from-view 'toggle-button view + (let ((button (make-pane-from-view 'toggle-button view () :label (and (stringp prompt) prompt) :value default :client stream :id query-identifier @@ -537,7 +537,7 @@ (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let ((slider ;;--- What other initargs do we pass along from the view? - (make-pane-from-view 'slider view + (make-pane-from-view 'slider view () :label (and (stringp prompt) prompt) :value (if default-supplied-p default min-value) :min-value min-value :max-value max-value @@ -589,7 +589,7 @@ (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let ((slider ;;--- What other initargs do we pass along from the view? - (make-pane-from-view 'slider view + (make-pane-from-view 'slider view () :label (and (stringp prompt) prompt) :value (if default-supplied-p default min-value) :min-value min-value :max-value max-value @@ -631,7 +631,7 @@ (object (type ,type) stream (view ,view) &key acceptably query-identifier prompt) (declare (ignore acceptably)) - (,function stream view t object t type prompt query-identifier nil))) + (,function stream view t object t type prompt query-identifier :editable-p nil))) types))) ;;--- Should there be a method specialized on T??? @@ -647,12 +647,12 @@ &key (prompt t) (active-p t)) (declare (ignore present-p)) (make-gadget-for-text-field-view - stream view active-p default default-supplied-p type prompt query-identifier t)) + stream view active-p default default-supplied-p type prompt query-identifier :editable-p t)) (defun make-gadget-for-text-field-view (stream view active-p default default-supplied-p type prompt query-identifier - &optional (editable-p t)) + &key (editable-p t)) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget text-field) (declare (ignore record gadget)) ;;-- This sucks @@ -665,7 +665,7 @@ "")))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let ((text-field (make-pane-from-view - 'text-field view + 'text-field view () :label (and (stringp prompt) prompt) :value (if default-supplied-p (present-to-string default type) @@ -724,7 +724,7 @@ &key (prompt t) (active-p t)) (declare (ignore default-supplied-p present-p)) (make-gadget-for-text-editor - stream view active-p default t type prompt query-identifier t)) + stream view active-p default t type prompt query-identifier :editable-p t)) (define-present-methods-for-types (make-gadget-for-text-editor text-editor-view) @@ -733,8 +733,7 @@ (defun make-gadget-for-text-editor (stream view active-p default default-supplied-p type prompt query-identifier - &optional (editable-p t)) - + &key (editable-p t)) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget button) (declare (ignore record gadget)) @@ -746,7 +745,7 @@ default "")))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let ((text-field (make-pane-from-view 'text-editor view + (let ((text-field (make-pane-from-view 'text-editor view '(:scroll-bars) :label (and (stringp prompt) prompt) :value (if default-supplied-p default @@ -765,7 +764,9 @@ ,stream ,query-identifier)) :active active-p :help-callback (make-gadget-help type)))) - (values (scrolling () text-field) text-field))))) + (values (scrolling (:scroll-bars (getf (view-gadget-initargs view) :scroll-bars :both)) + text-field) + text-field))))) ;;; List and option panes @@ -803,7 +804,7 @@ list-pane)) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let* ((pane (if (eq pane-type 'option-pane) - (make-pane-from-view pane-type view + (make-pane-from-view pane-type view () :items sequence :name-key name-key :value-key value-key @@ -818,7 +819,7 @@ stream query-identifier) :active active-p :help-callback (make-gadget-help type)) - (make-pane-from-view pane-type view + (make-pane-from-view pane-type view '(:scroll-bars) :items sequence :name-key name-key :value-key value-key @@ -832,7 +833,9 @@ stream query-identifier) :active active-p :help-callback (make-gadget-help type))))) - (values (if (eq pane-type 'list-pane) (scrolling () pane) pane) + (values (if (eq pane-type 'list-pane) + (scrolling (:scroll-bars (getf (view-gadget-initargs view) :scroll-bars :dynamic)) pane) + pane) pane))))) (define-presentation-method accept-present-default diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index a2067dc09fcad9918008459360eb1d131d9596cb..bc07daccae1cf3493874f65769b45142a8ca4ee1 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.31 1993/07/22 15:37:56 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.32 1993/09/17 19:05:10 cer Exp $ (in-package :clim-internals) @@ -364,6 +364,7 @@ (orientation (getf properties :orientation)) (generation-separation (getf properties :generation-separation)) (within-generation-separation (getf properties :within-generation-separation)) + (center-nodes (getf properties :center-nodes)) (start-x (coordinate 0)) (start-y (coordinate 0))) (dolist (root-node root-nodes) @@ -395,11 +396,15 @@ (my-breadth (+ ,breadth-var (round (max 0 (- total-child-breadth node-breadth)) 2)))) - (setf (node-depth-start ,node-var) ,depth-var + (setf (node-depth-start ,node-var) (if center-nodes + (+ ,depth-var + (round (- ,tallest-sibling-var (node-depth ,node-var)) + 2)) + ,depth-var) (node-breadth-start ,node-var) my-breadth) ;; Returns the breadth of the graph as a result (max total-child-breadth (node-breadth ,node-var)))))) - (ecase orientation + (ecase orientation ((:vertical :down) (macrolet ((node-breadth (node) `(bounding-rectangle-width ,node)) (node-depth (node) `(bounding-rectangle-height ,node)) diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 3876e5fdb0a43d571ff8a7c8b64ef6a3c52c74cf..322b101ba388e4ed24c1e2f3bf9925471abf9ffb 100644 --- a/clim/graphics-recording.lisp +++ b/clim/graphics-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-recording.lisp,v 1.23 1993/07/27 01:39:42 colin Exp $ +;; $fiHeader: graphics-recording.lisp,v 1.24 1993/09/07 21:45:57 colin Exp $ (in-package :clim-internals) @@ -199,18 +199,21 @@ ,@body)))))))))) (defmacro with-half-thickness ((lthickness rthickness) line-style &body body) - (let ((ls '#:line-style) - (thickness '#:thickness)) - `(let* ((,ls ,line-style) - (,thickness (if ,ls (line-style-thickness ,ls) 0)) - (,lthickness (floor ,thickness 2)) - (,rthickness (- ,thickness ,lthickness))) - ,@body))) + (let ((ls '#:line-style)) + `(let* ((,ls ,line-style)) + (with-half-thickness-1 (,lthickness ,rthickness) (if ,ls (line-style-thickness ,ls) 0) + ,@body)))) +(defmacro with-half-thickness-1 ((lthickness rthickness) thickness &body body) + (let ((thicky '#:thicky)) + `(let* ((,thicky ,thickness) + (,lthickness (floor ,thicky 2)) + (,rthickness (- ,thicky ,lthickness))) + ,@body))) (define-graphics-recording draw-point (ink line-style clipping-region) :bounding-rectangle - (with-half-thickness (lthickness rthickness) line-style + (with-half-thickness (lthickness rthickness) line-style (values (- x lthickness) (- y lthickness) (+ x rthickness) diff --git a/clim/menus.lisp b/clim/menus.lisp index 96dd751267a7606cbf9cf342f188234e735e1ac5..e9a9cd049587eb77c47093ededbfdac4f27416af 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.44 1993/05/05 01:38:44 cer Exp $ +;; $fiHeader: menus.lisp,v 1.45 1993/05/25 20:40:58 cer Exp $ (in-package :clim-internals) @@ -37,13 +37,16 @@ main))))) (:menu-bar nil)) -(defmethod frame-calling-frame ((frame menu-frame)) - ;; This is funny - (and (boundp '*application-frame*) - *application-frame*)) +;(defmethod frame-calling-frame ((frame menu-frame)) +; ;; This is funny +; ;; I suppose we are doing this because really the frame should have +; ;; the correct parent and there is no otherway of doing this +; (and (boundp '*application-frame*) +; *application-frame*)) ;; Returns a stream that corresponds to the pane holding the menu -(defmethod frame-manager-get-menu ((framem standard-frame-manager) &key scroll-bars label) +(defmethod frame-manager-get-menu ((framem standard-frame-manager) &key scroll-bars label parent-frame) + (declare (ignore parent-frame)) (let ((frame (make-application-frame 'menu-frame :label label :scroll-bars scroll-bars @@ -57,7 +60,10 @@ (defresource menu (associated-window root &key label (scroll-bars t)) :constructor (let* ((framem (if (null root) (find-frame-manager) (frame-manager root)))) - (frame-manager-get-menu framem :scroll-bars scroll-bars :label label)) + (frame-manager-get-menu framem + :scroll-bars scroll-bars + :label label + :parent-frame (pane-frame root))) :matcher (and (eq scroll-bars (menu-frame-scroll-bars (pane-frame menu))) (eq (not label) (not (menu-frame-label (pane-frame menu)))) (eq (frame-manager menu) (frame-manager root))) diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index a437ce89896840d73f6fe60d108cd500036024a8..244e90a0d1da7247a550c26f97b20b8e38cbb16c 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.35 1993/07/27 01:40:59 colin Exp $ +;; $fiHeader: recording-protocol.lisp,v 1.36 1993/09/17 19:05:23 cer Exp $ (in-package :clim-internals) @@ -1119,6 +1119,22 @@ (when (typep output-record 'stream-output-history-mixin) (setf (slot-value output-record 'stream) stream)))) + +;(defmethod (setf stream-output-history) ((history stream-output-history-mixin) +; (stream output-recording-mixin)) +; (let ((old (stream-output-history stream))) +; (when old (note-output-record-detached old))) +; (call-next-method) +; ;;--- Our OUTPUT-RECORDING-MIXIN expects extended output... +; (multiple-value-bind (x y) (stream-cursor-position stream) +; ;; I don't understand why the output record's initial position was set to +; ;; some untransformed "viewport" coordinate. The cursor position is the +; ;; right place, no? +; (output-record-set-position history x y)) +; ;; +; (setf (slot-value history 'stream) stream) +; history) + (defmethod clear-output-history ((stream output-recording-mixin)) (when (stream-output-history stream) (clear-output-record (stream-output-history stream))) diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index 5fe69fc917d1fbfca0441f106ce057da4ed861f2..cc649682aa5582102d910990df985c39b7267839 100644 --- a/clim/view-defs.lisp +++ b/clim/view-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: view-defs.lisp,v 1.13 1993/05/25 20:41:07 cer Exp $ +;; $fiHeader: view-defs.lisp,v 1.14 1993/09/17 19:05:29 cer Exp $ (in-package :clim-internals) @@ -92,6 +92,7 @@ (getf (view-gadget-initargs view) :decimal-places)) -(defmacro make-pane-from-view (class view &body initargs) - `(apply #'make-pane ,class (append (view-gadget-initargs ,view) (list ,@initargs)))) +(defmacro make-pane-from-view (class view ignore &body initargs) + `(apply #'make-pane ,class (append (remove-keywords (view-gadget-initargs ,view) ,ignore) + (list ,@initargs)))) diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp index 079d0e8fcd9e97b43cbc171cf878c511ff4a0560..7c8e1e06c20a87d51ce836170dacb039aee711c2 100644 --- a/demo/demo-driver.lisp +++ b/demo/demo-driver.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: demo-driver.lisp,v 1.26 1993/09/17 18:35:47 colin Exp $ +;; $fiHeader: demo-driver.lisp,v 1.27 1993/09/22 21:21:15 cer Exp $ (in-package :clim-demo) @@ -66,7 +66,8 @@ (defun run-demo (demo &key (port (find-port)) force) (let* ((entry (assoc port (demo-frames demo))) (frame (cdr entry)) - (activity-p (subtypep (demo-class demo) 'activity))) + (activity-p (subtypep (demo-class demo) 'activity)) + (*package* (find-package :clim-demo))) (when (or force (null frame)) (setq frame (apply (if activity-p #'make-instance diff --git a/demo/plot.lisp b/demo/plot.lisp index de1e560c49165a8814fee6f32ea790f5df1af4c1..32d35e9fb55e272e152a108a8dab16e4da657d42 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: plot.lisp,v 1.29 1993/09/17 19:05:59 cer Exp $ +;; $fiHeader: plot.lisp,v 1.30 1993/09/22 21:21:17 cer Exp $ (in-package :clim-demo) @@ -790,9 +790,3 @@ (define-demo "Plotting Demo" plot-demo) - -(define-plot-demo-command com-zoom-graph-point - ((point 'graph-point)) - (describe point)) - - diff --git a/misc/undefinedsymbols.motif b/misc/undefinedsymbols.motif index 7323b205fbc22f19b5b9567e2a338a12e35a0559..3b22ca45f77b9b37463b4e4cc2019d502aa2ca24 100644 --- a/misc/undefinedsymbols.motif +++ b/misc/undefinedsymbols.motif @@ -6,6 +6,9 @@ XmFontListInitFontContext XmFontListFreeFontContext XmFontListGetNextFont XmFontListCreate +XmFontListEntryCreate +XmFontListAppendEntry +XmFontListEntryGetFont XmAddProtocolCallback XmInternAtom XmIsTraversable diff --git a/misc/undefinedsymbols.xt b/misc/undefinedsymbols.xt index 3374cd8cdd5835a16a19160e76e4332a904439c0..06297f0372e7b2490bb0251d5029ae2ceeda9c17 100644 --- a/misc/undefinedsymbols.xt +++ b/misc/undefinedsymbols.xt @@ -41,3 +41,4 @@ XtUnmanageChildren XtWindow XtParseTranslationTable XtParseAcceleratorTable +XtAppSetFallbackResources diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index ac1874de3ef9f526e1ff36fc3aaa695188a977e6..2a96771288d9383d9949658c813e51898abc2f10 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.47 1993/06/04 16:06:35 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.48 1993/08/12 16:04:10 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -259,10 +259,10 @@ (repaint-sheet sheet region))))) (let ((frame (pane-frame sheet))) (when (and (/= left x) (/= top y) frame) - (note-viewport-position-changed frame sheet)))))))) + (note-viewport-position-changed frame sheet x y)))))))) -(defmethod note-viewport-position-changed (frame pane) - (declare (ignore frame pane)) +(defmethod note-viewport-position-changed (frame pane x y) + (declare (ignore frame pane x y)) nil) ;;; Given min1, max1 and value1 which is between them it will return diff --git a/test/test-clim-tests.lisp b/test/test-clim-tests.lisp index 288969ad2ca717cfa01c0890a56ecbdbdda7a343..16483062329f575204c0a0f43e62e2bc8c16846d 100644 --- a/test/test-clim-tests.lisp +++ b/test/test-clim-tests.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test-clim-tests.lisp,v 1.1 1993/08/12 16:04:23 cer Exp $ +;; $fiHeader: test-clim-tests.lisp,v 1.2 1993/09/17 19:06:22 cer Exp $ (in-package :clim-user) @@ -105,7 +105,12 @@ :abort ) +(define-frame-test more-simple-menu-test (clim-tests + :width 600 :height 600) + ((com-more-simple-menus)) + (exit-clim-tests)) + (define-frame-test more-clim-tests (clim-tests :width 600 :height 600) ((com-read-image-test) @@ -126,7 +131,7 @@ (com-text-formatting) (com-negative-extent) - (com-more-simple-menus) + (com-readonly-gadget-dialog) :abort (com-ozone-dialog) diff --git a/test/test-clim.lisp b/test/test-clim.lisp index 52f20fb01789474b4ddd23d259c7f3dd2f40cbe9..79a3997b904e3b15921ac0f6d0f0aeebe8ef8b38 100644 --- a/test/test-clim.lisp +++ b/test/test-clim.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test-clim.lisp,v 1.12 1993/08/12 16:04:25 cer Exp $ +;; $fiHeader: test-clim.lisp,v 1.13 1993/09/17 19:06:24 cer Exp $ (in-package :clim-user) @@ -451,3 +451,8 @@ (handler-case (accept-from-string '(subset :a :b) "a,c") (error (c) c) (:no-error (&rest ignore) ignore (error "subset bogus failed"))))) + + +(define-frame-test test-avv-text-fields-and-list-panes-with-scroll-bars (tf115) + () + (com-quit)) diff --git a/test/test-driver.lisp b/test/test-driver.lisp index fac7169be80e86845bbcb36c982c1f0f5c4efe9c..dcd88e7e64249cd746f17e262c3f395d425a38df 100644 --- a/test/test-driver.lisp +++ b/test/test-driver.lisp @@ -58,6 +58,7 @@ (defmethod destroy-invocation ((inv activity-invocation)) (destroy-activity (invocation-activity inv))) + (defun initialize-invocation (inv frame &optional process) (labels ((do-it (frame) (unwind-protect @@ -126,7 +127,7 @@ (unless (mp::process-stack-group process) (error "Frame terminated abnormally")) (execute-one-command invocation exit-command) (unless (wait-for-death process) - (warn "Process did not terminate")))) + (error "Process did not terminate")))) (defun wait-for-death (process) (let (done) @@ -270,10 +271,11 @@ (execute-commands-in-invocation invocation command-continuation)) (function (funcall command-continuation))) - (terminate-invocation invocation exit-command) - (mp::process-kill (invocation-process invocation)) - (unless (wait-for-death (invocation-process invocation)) - (warn "Process would not die when killed")) + (unwind-protect + (terminate-invocation invocation exit-command) + (mp::process-kill (invocation-process invocation)) + (unless (wait-for-death (invocation-process invocation)) + (warn "Process would not die when killed"))) (destroy-invocation invocation)))))) (if error (with-test-success-expected (test-name) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 275da5892264fe951dbf8f6619623d99e2e14178..3c5d60fbc4230a40fff40bfe15f641ced5062246 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.71 1993/09/17 00:21:17 colin Exp $ +;; $fiHeader: test-suite.lisp,v 1.72 1993/09/17 19:06:31 cer Exp $ (in-package :clim-user) @@ -1400,12 +1400,6 @@ people, shall not perish from the earth. (mapcar #'find-class '(clos:metaobject clos::dependee-mixin)) #'(lambda (o s) (let ((text (format nil "~A" (clos::class-name o)))) - #+ignore - (with-output-as-gadget (s) - (make-pane 'push-button :label text - :activate-callback #'(lambda (gadget) (print - text excl:*initial-terminal-io*)))) - #-ignore (multiple-value-bind (width height) (text-size s text) (with-new-output-record (s) (draw-rectangle* s 0 0 width height :filled t :ink color) @@ -1414,6 +1408,29 @@ people, shall not perish from the earth. :stream stream :merge-duplicates t))) +(define-test (simple-node-centered-graphs formatted-output) (stream) + "Two graphs, one with nodes centered" + (let ((color (make-gray-color 0.7))) + (with-text-size (stream :tiny) + (formatting-item-list (stream) + (dolist (center-nodes '(nil t)) + (formatting-cell (stream) + (format-graph-from-roots + ;; dependee-mixin no longer exported -- smh 18may93 + (mapcar #'find-class '(number)) + #'(lambda (o s) + (let ((text (format nil "~A" (clos::class-name o)))) + (multiple-value-bind (width height) (text-size s text) + (with-new-output-record (s) + (draw-rectangle* s 0 0 width height :filled t :ink color) + (draw-text* s text 0 0 :align-x :left :align-y :top))))) + #'clos::class-direct-subclasses + :stream stream + :center-nodes center-nodes + :merge-duplicates nil))))))) + + + (define-test (offset-graph formatted-output) (stream) "Draw a graph offset in the window. After refreshing, it should look the same." (let ((orientation :horizontal)) diff --git a/test/test.lisp b/test/test.lisp index 349dc8c09e3acbda289aa4c3184b3131a4a60281..f3f75848ba22d252cca05da13934152422c204b9 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.51 1993/08/12 16:04:35 cer Exp $ +;; $fiHeader: test.lisp,v 1.52 1993/09/07 21:46:57 colin Exp $ (in-package :clim-user) @@ -1186,3 +1186,30 @@ (setf (gadget-value cb) n2) (assert (equal n2 (check-box-current-selection cb)))))) + +(define-application-frame tf115 () + () + (:menu-bar nil) + (:command-table test-frame) + (:panes + (a :accept-values + :display-function '(accept-values-pane-displayer :displayer display-tf115) + :width :compute + :height :compute)) + (:layouts + (default a))) + +(defun display-tf115 (frame stream &key &allow-other-keys) + (formatting-table (stream) + (dolist (view '(list-pane-view text-editor-view)) + (formatting-row (stream) + (dolist (scroll-bars '(nil :both :vertical :horizontal)) + (formatting-cell (stream) + (accept (ecase view + (list-pane-view '(member a b c d e f)) + (text-editor-view 'string)) + :stream stream + :prompt nil + :query-identifier (cons view scroll-bars) + :view (cons view (and scroll-bars `(:scroll-bars ,scroll-bars)))))))))) + diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index b7af67856f18d531134f7ecbfe387489c73c0ed1..7a1c9d67b3a63a840ef2e4d83bee06c8bf9c644c 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.59 1993/08/12 16:05:03 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.60 1993/09/17 19:07:01 cer Exp $ (in-package :xm-silica) @@ -1444,6 +1444,17 @@ 'openlook-frame-pane 'openlook-scrolling-window)) +(defmethod make-pane-arglist ((framem openlook-frame-manager) + (class (eql 'scroller-pane)) + &rest options &key contents) + (declare (ignore type)) + (declare (non-dynamic-extent options)) + ;; This is annoying. Because we are making a different class we + ;; have to discard :scroll-bars + (if (gadget-includes-scrollbars-p contents) + (remove-keywords options '(:scroll-bars)) + options)) + (defmethod gadget-includes-scrollbars-p ((pane t)) nil) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index d67fe4c654969a4af3a2f2869621fd4350aa9bd5..8245b929e60db489559a02e2e32d69cd313ff84d 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.61 1993/07/27 01:55:21 colin Exp $ +;; $fiHeader: xm-frames.lisp,v 1.62 1993/09/17 19:07:07 cer Exp $ (in-package :xm-silica) @@ -568,7 +568,13 @@ (ok-button cancel-button help-button separator) (get-message-box-child dialog :ok :cancel :help :separator) (tk::unmanage-child help-button) - (xt::unmanage-child cancel-button) + ;; + (if (find-restart 'abort nil) + (tk::add-callback cancel-button :activate-callback #'(lambda (widget count process) + (declare (ignore widget count)) + (mp:process-interrupt process 'abort)) + mp:*current-process*) + (xt::unmanage-child cancel-button)) (tk::unmanage-child ok-button) (tk::unmanage-child separator)) (let ((slider @@ -622,12 +628,14 @@ (defmethod clim-internals::frame-manager-get-menu ((framem motif-frame-manager) &key scroll-bars - label) + label + parent-frame) (let ((frame (make-application-frame 'motif-menu-frame :scroll-bars scroll-bars :label label :frame-manager framem - :save-under t))) + :save-under t + :calling-frame parent-frame))) ;; This so that ports can do something interesting with popped-up ;; menu frames, such as implemented "click off menu to abort". (setf (getf (frame-properties frame) :menu-frame) t) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 4dbb7d95e624b8cd3d3ebcfa8fe69418d0c25481..8df4c59d3008e571d10b9315a3315cae0d80becd 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.81 1993/09/07 21:47:09 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.82 1993/09/17 19:07:10 cer Exp $ (in-package :xm-silica) @@ -688,7 +688,7 @@ (silica::scroller-pane-scroll-bar-policy p))))) (values 'tk::xm-text (append - `(:scroll-horizontal ,(and (member scroll-mode '(t :both :horizonal :dynamic)) t)) + `(:scroll-horizontal ,(and (member scroll-mode '(t :both :horizontal :dynamic)) t)) `(:scroll-vertical ,(and (member scroll-mode '(t :both :vertical :dynamic)) t)) (and (not editable) '(:cursor-position-visible nil)) (list :edit-mode :multi-line) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 84f85d5250341414c695d03ab165d51604126f98..b256889269effa8bd9e90f2518a0a64b3b8a3eb9 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.40 1993/09/17 00:21:27 colin Exp $ +;; $fiHeader: xt-frames.lisp,v 1.41 1993/09/17 19:07:17 cer Exp $ (in-package :xm-silica) @@ -157,34 +157,35 @@ (port-display port))) (declare (ignore ignore win1 win2 x y)) (tk::set-values menu :x root-x :y root-y) - - (catch 'menu-choose - (unwind-protect - (progn - (loop - (when (funcall closure) (return nil)) - - - (framem-enable-menu framem menu) - ;; Now we have to wait - (port-force-output port) - (with-toolkit-dialog-component (menu-choose items) - (wait-for-callback-invocation - port - #'(lambda () - ;;-- This is to deal - ;;-- with the race - ;;-- condition where - ;;-- the menu go down - ;;-- to quick - (or (funcall closure) - (not (framem-menu-active-p framem menu)))) - "Returned value"))) - (framem-popdown-menu framem menu)) - (unless cache - (framem-destroy-menu framem menu))) - (port-force-output port) - (values-list (nth-value 1 (funcall closure))))))) + (let ((aborted t)) + (catch 'menu-choose + (unwind-protect + (progn + (loop + (when (funcall closure) + (setq aborted nil) + (return nil)) + (framem-enable-menu framem menu) + ;; Now we have to wait + (port-force-output port) + (with-toolkit-dialog-component (menu-choose items) + (wait-for-callback-invocation + port + #'(lambda () + ;;-- This is to deal + ;;-- with the race + ;;-- condition where + ;;-- the menu go down + ;;-- to quick + (or (funcall closure) + (not (framem-menu-active-p framem menu)))) + "Returned value"))) + (framem-popdown-menu framem menu)) + (if cache + (when aborted (framem-popdown-menu framem menu)) + (framem-destroy-menu framem menu))) + (port-force-output port) + (values-list (nth-value 1 (funcall closure)))))))) (defmethod frame-manager-allows-menu-caching ((framem xt-frame-manager)) t) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 5ab70319848f9d6cd3837025b471eee0c3659cd8..d70f2701ef6b6005ac415fe08ff63bd89e0df752 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.80 1993/09/17 19:07:19 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.81 1993/09/22 21:21:26 cer Exp $ (in-package :tk-silica) @@ -822,6 +822,11 @@ (< (the fixnum ,x) 32000) (> (the fixnum ,x) -32000) (< (the fixnum ,y) 32000) (> (the fixnum ,y) -32000))) +(defmacro single-float-valid-point-p (x y) + `(and (< (the single-float ,x) 32000s0) + (> (the single-float ,x) -32000s0) + (< (the single-float ,y) 32000s0) + (> (the single-float ,y) -32000s0))) ;; ;; Here we implement a simple version of the Cohen-Sutherland clipping ;; algorithm. Specifically, we only try to clip the line so that it will @@ -954,9 +959,61 @@ then (return-from ,function-name) else (error "Coordinate(s) out of (signed-byte 16) range"))))) + +(defmacro single-float-discard-illegal-coordinates (function-name &rest positions) + (assert (evenp (length positions)) (positions) + "There must be an even number of elements in ~S" positions) + (let ((forms nil)) + (do () + ((null positions)) + (let* ((x (pop positions)) + (y (pop positions))) + (push `(single-float-valid-point-p ,x ,y) forms))) + `(unless (and ,@forms) + (if* *discard-illegal-graphics* + then (return-from ,function-name) + else (error "Coordinate(s) out of (signed-byte 16) range"))))) + + +(defmacro with-single-floats (variable-bindings &body body) + (flet ((binding-var (x) (if (atom x) x (car x))) + (binding-form (x) (if (atom x) x (second x)))) + `(let ,(mapcar #'(lambda (x) + `(,(binding-var x) (float ,(binding-form x) 0s0))) + variable-bindings) + (declare (single-float ,@(mapcar #'binding-var variable-bindings))) + ,@body))) + +(defmacro with-fixnums (variable-bindings &body body) + (flet ((binding-var (x) (if (atom x) x (car x))) + (binding-form (x) (if (atom x) x (second x)))) + `(let ,(mapcar #'(lambda (x) + `(,(binding-var x) (fix-coordinate ,(binding-form x)))) + variable-bindings) + (declare (fixnum ,@(mapcar #'binding-var variable-bindings))) + ,@body))) + +(defmacro with-mins-and-maxes (variables &body body) + `(let ,(mapcan #'(lambda (binding) + (destructuring-bind (min-var max-var form1 form2) binding + `((,min-var ,form1) + (,max-var ,form2)))) + variables) + (declare (single-float ,@(mapcar #'first variables) ,@(mapcar #'second variables))) + #+ignore (print-variables min-x min-y max-x max-y) + ,@(mapcar #'(lambda (binding) + (destructuring-bind (min-var max-var form1 form2) binding + (declare (ignore form1 form2)) + `(when (> ,min-var ,max-var) + (rotatef ,min-var ,max-var)))) + variables) + ,@body)) + + (defmethod medium-draw-point* ((medium xt-medium) x y) + (declare (optimize (speed 3) (safety 0))) (let ((drawable (medium-drawable medium))) (when drawable (let* ((ink (medium-ink medium)) @@ -964,10 +1021,10 @@ (thickness (line-style-thickness line-style)) (sheet (medium-sheet medium)) (transform (sheet-device-transformation sheet))) - ;;--rounding - (convert-to-device-coordinates transform x y) - (discard-illegal-coordinates medium-draw-point* x y) + (transform-positions transform x y) (cond ((< thickness 1.5) + (fix-coordinates x y) + (discard-illegal-coordinates medium-draw-point* x y) (tk::draw-point drawable (adjust-ink (decode-ink ink medium) @@ -975,19 +1032,24 @@ x y) x y)) (t - (setq thickness (round thickness)) - (tk::draw-ellipse - drawable - (adjust-ink (decode-ink ink medium) - medium - (the fixnum (- (the fixnum x) (the fixnum thickness))) - (the fixnum (- (the fixnum y) (the fixnum thickness)))) - x y - 0 - thickness - 0 - thickness 0 2pi - t))))))) + ;;--rounding + ;;--what is the most efficient way of doing this? + (with-single-floats (x y) + (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness + (declare (ignore rthickness)) + (with-fixnums ((min-x (- x lthickness)) + (min-y (- y lthickness)) + (size thickness)) + (discard-illegal-coordinates medium-draw-point* min-x min-y) + (tk::draw-ellipse-1 + drawable + (adjust-ink (decode-ink ink medium) + medium + min-x + min-y) + min-x min-y + size size 0 #.(* 360 64) + t)))))))))) (defmethod medium-draw-points* ((medium xt-medium) position-seq) (let ((drawable (medium-drawable medium))) @@ -1000,9 +1062,9 @@ (let* ((len (length position-seq)) (xpoints (/ len 2)) (j 0) - (minx (ash 1 15)) - (miny (ash 1 15))) - (declare (fixnum j xpoints minx miny)) + (minx #.(ash 1 15)) + (miny #.(ash 1 15))) + (declare (fixnum len j xpoints minx miny)) (macrolet ((inner-guts () `(if (listp position-seq) (loop @@ -1035,35 +1097,36 @@ j x11:coordmodeorigin))) (t - (setq thickness (round thickness)) - (let ((points (tk::make-xarc-array :number xpoints))) - (macrolet ((guts (x y) - `(let ((x ,x) - (y ,y)) - (convert-to-device-coordinates transform x y) - (when (valid-point-p x y) - (minf minx x) - (minf miny y) - (setf (tk::xarc-array-x points j) x - (tk::xarc-array-y points j) y - (tk::xarc-array-width points j) thickness - (tk::xarc-array-height points j) thickness - (tk::xarc-array-angle1 points j) 0 - (tk::xarc-array-angle2 points j) (* 360 64)) - (incf j))))) - (inner-guts)) - (x11::xfillarcs - (tk::object-display drawable) - drawable - (adjust-ink (decode-ink ink medium) - medium - ;;--rounding - ;;-- This seems like the wrong values - ;;-- need to subtract thickness - minx - miny) - points - j)))))))))) + (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness + (declare (ignore rthickness)) + (setq thickness (round thickness)) + (let ((points (tk::make-xarc-array :number xpoints))) + (macrolet ((guts (x y) + `(let ((x ,x) + (y ,y)) + (transform-positions transform x y) + (with-fixnums ((x (- x lthickness)) + (y (- y lthickness))) + (when (valid-point-p x y) + (minf minx x) + (minf miny y) + (setf (tk::xarc-array-x points j) x + (tk::xarc-array-y points j) y + (tk::xarc-array-width points j) thickness + (tk::xarc-array-height points j) thickness + (tk::xarc-array-angle1 points j) 0 + (tk::xarc-array-angle2 points j) #.(* 360 64)) + (incf j)))))) + (inner-guts)) + (x11::xfillarcs + (tk::object-display drawable) + drawable + (adjust-ink (decode-ink ink medium) + medium + minx + miny) + points + j))))))))))) (defmethod medium-draw-line* ((medium xt-medium) x1 y1 x2 y2) @@ -1137,7 +1200,35 @@ points i)))))))) -(defmethod medium-draw-rectangle* ((medium xt-medium) x1 y1 x2 y2 filled) +(defmacro with-clipped-fixnum-rectangle ((x1 y1 x2 y2) &body body) + `(with-single-floats ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2)) + (unless (single-float-valid-point-p x1 y1) + (setq x1 (min (max -32000s0 x1) 32000s0)) + (setq y1 (min (max -32000s0 y1) 32000s0))) + (unless (single-float-valid-point-p x2 y2) + (setq x2 (min (max -32000s0 x2) 32000s0)) + (setq y2 (min (max -32000s0 y2) 32000s0))) + (with-mins-and-maxes ((min-x max-x x1 x2) + (min-y max-y y1 y2)) + (with-fixnums ((fmin-x min-x) + (fmin-y min-y) + (fwidth (- max-x min-x)) + (fheight (- max-y min-y))) + ,@body)))) + +#+debugging +(defmacro print-variables (&rest variables) + `(format excl::*initial-terminal-io* + ,(with-output-to-string (s) + (dolist (var variables) + (format s "~S = " var) + (write-string "~S, " s)) + (write-string "~%" s)) + ,@variables)) + +(defmethod medium-draw-rectangle* ((medium xt-medium) ox1 oy1 ox2 oy2 filled) + #+this-would-be-nice (declare (optimize (safety 0) (speed 3))) + #-this-would-be-nice (declare (optimize (safety 3) (speed 0))) (let ((drawable (medium-drawable medium))) (when drawable (let* ((ink (medium-ink medium)) @@ -1145,28 +1236,21 @@ (transform (sheet-device-transformation sheet))) (assert (rectilinear-transformation-p transform)) ;;--rounding - (convert-to-device-coordinates transform x1 y1 x2 y2) + (transform-positions transform ox1 oy1 ox2 oy2) ;; Clipping a rectangle is ridiculously easy. - (unless (valid-point-p x1 y1) - (setq x1 (min (max -32000 (the fixnum x1)) 32000)) - (setq y1 (min (max -32000 (the fixnum y1)) 32000))) - (unless (valid-point-p x2 y2) - (setq x2 (min (max -32000 (the fixnum x2)) 32000)) - (setq y2 (min (max -32000 (the fixnum y2)) 32000))) - (let ((min-x (min (the fixnum x1) (the fixnum x2))) - (min-y (min (the fixnum y1) (the fixnum y2)))) - (declare (fixnum min-x min-y)) + (with-clipped-fixnum-rectangle (ox1 oy1 ox2 oy2) (tk::draw-rectangle drawable (adjust-ink (decode-ink ink medium) medium - min-x min-y) - min-x min-y - (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1)))) - (fast-abs (the fixnum (- (the fixnum y2) (the fixnum y1)))) + fmin-x fmin-y) + fmin-x fmin-y + fwidth + fheight filled)))))) (defmethod medium-draw-rectangles* ((medium xt-medium) rectangles filled) + (declare (optimize (speed 3) (safety 0))) (let ((drawable (medium-drawable medium))) (when drawable (let* ((ink (medium-ink medium)) @@ -1177,39 +1261,33 @@ (rects (xt::make-xrectangle-array :number nrects)) (overall-min-x #.(1- (ash 1 16))) (overall-min-y #.(1- (ash 1 16)))) + (declare (fixnum len nrects overall-min-x overall-min-y)) (assert (zerop (mod len 4)) () "Must be a multiple of 4") (assert (rectilinear-transformation-p transform)) (macrolet ((guts (x1 y1 x2 y2) `(let ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2)) - ;;--rounding - (convert-to-device-coordinates transform x1 y1 x2 y2) - ;; Clipping a rectangle is ridiculously easy. - (unless (valid-point-p x1 y1) - (setq x1 (min (max -32000 (the fixnum x1)) 32000)) - (setq y1 (min (max -32000 (the fixnum y1)) 32000))) - (unless (valid-point-p x2 y2) - (setq x2 (min (max -32000 (the fixnum x2)) 32000)) - (setq y2 (min (max -32000 (the fixnum y2)) 32000))) - (let ((min-x (min (the fixnum x1) (the fixnum x2))) - (min-y (min (the fixnum y1) (the fixnum y2))) - (max-x (max (the fixnum x1) (the fixnum x2))) - (max-y (max (the fixnum y1) (the fixnum y2)))) - (declare (fixnum min-x min-y max-x max-y)) - (minf overall-min-x min-x) - (minf overall-min-y min-y) - (setf (tk::xrectangle-array-x rects i) min-x - (tk::xrectangle-array-y rects i) min-y - (tk::xrectangle-array-width rects i) (- max-x min-x) - (tk::xrectangle-array-height rects i) (- max-y min-y)) + (transform-positions transform x1 y1 x2 y2) + (with-clipped-fixnum-rectangle (x1 y1 x2 y2) + (minf overall-min-x fmin-x) + (minf overall-min-y fmin-y) + (setf (tk::xrectangle-array-x rects i) fmin-x + (tk::xrectangle-array-y rects i) fmin-y + (tk::xrectangle-array-width rects i) fwidth + (tk::xrectangle-array-height rects i) fheight) (incf i))))) (let ((i 0)) + (declare (fixnum i)) (if (listp rectangles) (loop (when (null rectangles) (return nil)) (guts (pop rectangles) (pop rectangles) (pop rectangles) (pop rectangles))) (do ((j 0 (+ j 4))) ((= j len)) - (guts (aref rectangles j) (aref rectangles (+ 1 j)) (aref rectangles (+ 2 j)) (aref rectangles (+ 3 j)))))) + (declare (fixnum j)) + (guts (aref rectangles j) + (aref rectangles (+ 1 j)) + (aref rectangles (+ 2 j)) + (aref rectangles (+ 3 j)))))) (tk::draw-rectangles drawable (adjust-ink (decode-ink ink medium) @@ -1288,34 +1366,72 @@ center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) + (declare (optimize (speed 3) (safety 0))) (let ((drawable (medium-drawable medium))) (when drawable (let* ((sheet (medium-sheet medium)) (transform (sheet-device-transformation sheet))) - (convert-to-device-coordinates transform center-x center-y) - (discard-illegal-coordinates medium-draw-ellipse* center-x center-y) - (convert-to-device-distances transform - radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (transform-positions transform center-x center-y) + (transform-distances transform radius-1-dx radius-1-dy radius-2-dx radius-2-dy) ;;--- This is some magic that means that things get drawn ;;--- correctly. - (setq start-angle (- 2pi start-angle) - end-angle (- 2pi end-angle)) - (rotatef start-angle end-angle) - (when (< end-angle start-angle) - (setq end-angle (+ end-angle 2pi))) - ;;--rounding in draw-ellipse - (tk::draw-ellipse - drawable - (adjust-ink (decode-ink (medium-ink medium) medium) - medium - (- center-x - (abs (if (zerop radius-1-dx) radius-2-dx radius-1-dx))) - (- center-y - (abs (if (zerop radius-1-dy) radius-2-dy radius-1-dy)))) - center-x center-y - radius-1-dx radius-1-dy radius-2-dx radius-2-dy - start-angle end-angle - filled))))) + (with-single-floats (center-x center-y radius-1-dx radius-1-dy + radius-2-dx radius-2-dy + start-angle end-angle) + (setq start-angle (- 2pi start-angle) + end-angle (- 2pi end-angle)) + (rotatef start-angle end-angle) + (when (< end-angle start-angle) + (setq end-angle (+ end-angle 2pi))) + ;;--rounding in draw-ellipse + (with-single-floats ((x-radius 0) + (y-radius 0)) + + (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) + (setq x-radius (abs radius-2-dx) + y-radius (abs radius-1-dy))) + ((and (= radius-2-dx 0) (= radius-1-dy 0)) + (setq x-radius (abs radius-1-dx) + y-radius (abs radius-2-dy))) + (t + (let ((s-1 (+ (* radius-1-dx radius-1-dx) + (* radius-1-dy radius-1-dy))) + (s-2 (+ (* radius-2-dx radius-2-dx) + (* radius-2-dy radius-2-dy)))) + (if (= s-1 s-2) + (let ((r (sqrt s-1))) + (setq x-radius r y-radius r)) + ;; Degrade to drawing a rectilinear ellipse + (setq x-radius (sqrt s-1) + y-radius (sqrt s-2)))))) + + (setq start-angle (* start-angle #.(float (/ (* 360 64) (* 2 pi)) 0s0))) + (setq end-angle (* end-angle #.(float (/ (* 360 64) (* 2 pi)) 0s0))) + + ;;--rounding + (if (> end-angle start-angle) + (setq end-angle (- end-angle start-angle)) + (setq end-angle (- start-angle end-angle))) + + (with-fixnums ((x-min (- center-x x-radius)) + (y-min (- center-y y-radius)) + (width (* 2 x-radius)) + (height (* 2 y-radius)) + end-angle + start-angle) + (discard-illegal-coordinates medium-draw-ellipse* x-min y-min) + (tk::draw-ellipse-1 drawable + (adjust-ink (decode-ink (medium-ink medium) medium) + medium + x-min + y-min) + x-min + y-min + width + height + start-angle + end-angle + filled)))))))) (defmethod medium-draw-text* ((medium xt-medium) string-or-char x y start end @@ -1328,14 +1444,13 @@ (transform (sheet-device-transformation sheet)) (text-style (medium-merged-text-style medium)) (font (text-style-mapping port text-style)) - (ascent (tk::font-ascent font))) + (descent (tk::font-descent font)) + (ascent (tk::font-ascent font)) + (height (+ ascent descent))) ;;--rounding errors? - ;;--Well we do some arithmetic in some cases - ;;--so in theory it could go wrong. - (convert-to-device-coordinates transform x y) - (discard-illegal-coordinates medium-draw-text* x y) + (transform-positions transform x y) (when towards-x - (convert-to-device-coordinates transform towards-x towards-y)) + (transform-positions transform towards-x towards-y)) (when (typep string-or-char 'character) (setq string-or-char (string string-or-char))) (ecase align-x @@ -1353,18 +1468,20 @@ (:left nil)) (ecase align-y (:bottom - (let ((dy (text-style-descent text-style medium))) + (let ((dy descent)) (decf y dy) (when towards-y (decf towards-y dy)))) (:center - (let ((dy (- (text-style-descent text-style medium) - (floor (text-style-height text-style medium) 2)))) + (let ((dy (- descent + (floor height 2)))) (decf y dy) (when towards-y (decf towards-y dy)))) (:baseline nil) (:top (when towards-y (incf towards-y ascent)) (incf y ascent))) + (fix-coordinates x y) + (discard-illegal-coordinates medium-draw-text* x y) (let ((gc (adjust-ink (decode-ink (medium-ink medium) medium) medium diff --git a/tk/foreign.lisp b/tk/foreign.lisp index d293f50e8627cdd0808d41300b54a215abae9cb7..440306486eba0a2fe24f939bb0fd0c1a62b2d590 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign.lisp,v 1.14 93/01/11 15:45:37 colin Exp $ +;; $fiHeader: foreign.lisp,v 1.15 1993/07/27 01:52:52 colin Exp $ (in-package :tk) @@ -52,6 +52,8 @@ (defun create-application-context () (make-instance 'application-context)) +(defparameter *large-connection-quantum* 20) + (defun open-display (&key (context (create-application-context)) (host nil) (application-name "clim") @@ -61,14 +63,14 @@ (argc 0) (argv 0)) (let ((d (with-ref-par ((argc argc)) - (xt_open_display context - (or host 0) - application-name - application-class - options - num-options - argc - argv)))) + (let ((temp (mp:process-quantum mp:*current-process*))) + (unwind-protect + (progn (setf (mp:process-quantum mp:*current-process*) *large-connection-quantum*) + (mp:process-allow-schedule) + (xt_open_display context (or host 0) application-name application-class options + num-options argc argv)) + (setf (mp:process-quantum mp:*current-process*) temp) + (mp:process-allow-schedule)))))) (if (zerop d) (error "cannot open the display: ~A" host)) ;; Used for debugging: diff --git a/tk/graphics.lisp b/tk/graphics.lisp index 7f8084b72c0f521d34ab6167094d565b9c7442f8..fa90c3402d745ed20beb7fc952e1bf33a6df8058 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.14 1993/07/27 01:52:59 colin Exp $ +;; $fiHeader: graphics.lisp,v 1.15 1993/09/17 19:06:42 cer Exp $ (in-package :tk) @@ -43,60 +43,62 @@ y2)) -(defun draw-ellipse (drawable gcontext center-x - center-y - radius-1-dx - radius-1-dy - radius-2-dx - radius-2-dy - start-angle - end-angle - filled) - (multiple-value-bind (x-radius y-radius) - (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) - (values (round (abs radius-2-dx)) - (round (abs radius-1-dy)))) - ((and (= radius-2-dx 0) (= radius-1-dy 0)) - (values (round (abs radius-1-dx)) - (round (abs radius-2-dy)))) - (t - (let ((s-1 (+ (* radius-1-dx radius-1-dx) - (* radius-1-dy radius-1-dy))) - (s-2 (+ (* radius-2-dx radius-2-dx) - (* radius-2-dy radius-2-dy)))) - (if (= s-1 s-2) - (let ((r (round (sqrt s-1)))) - (values r r)) - ;; Degrade to drawing a rectilinear ellipse - (values (round (sqrt s-1)) - (round (sqrt s-2))))))) - (setq start-angle (round (* start-angle (/ (* 360 64) (* 2 pi))))) - (setq end-angle (round (* end-angle (/ (* 360 64) (* 2 pi))))) - ;;--rounding - (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) - drawable - gcontext - ;;--rounding - (- center-x x-radius) - (- center-y y-radius) - (* 2 x-radius) - (* 2 y-radius) - start-angle end-angle) - (x11:xdrawarc +;(defun draw-ellipse (drawable gcontext center-x +; center-y +; radius-1-dx +; radius-1-dy +; radius-2-dx +; radius-2-dy +; start-angle +; end-angle +; filled) +; (multiple-value-bind (x-radius y-radius) +; (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) +; (values (round (abs radius-2-dx)) +; (round (abs radius-1-dy)))) +; ((and (= radius-2-dx 0) (= radius-1-dy 0)) +; (values (round (abs radius-1-dx)) +; (round (abs radius-2-dy)))) +; (t +; (let ((s-1 (+ (* radius-1-dx radius-1-dx) +; (* radius-1-dy radius-1-dy))) +; (s-2 (+ (* radius-2-dx radius-2-dx) +; (* radius-2-dy radius-2-dy)))) +; (if (= s-1 s-2) +; (let ((r (round (sqrt s-1)))) +; (values r r)) +; ;; Degrade to drawing a rectilinear ellipse +; (values (round (sqrt s-1)) +; (round (sqrt s-2))))))) +; (setq start-angle (round (* start-angle (/ (* 360 64) (* 2 pi))))) +; (setq end-angle (round (* end-angle (/ (* 360 64) (* 2 pi))))) +; ;;--rounding +; (if (> end-angle start-angle) +; (setq end-angle (- end-angle start-angle)) +; (setq end-angle (- start-angle end-angle))) +; (draw-ellipse-1 drawable +; gcontext +; (- center-x x-radius) +; (- center-y y-radius) +; (* 2 x-radius) +; (* 2 y-radius) +; start-angle end-angle filled))) + + +(defun draw-ellipse-1 (drawable gcontext x y width height start-angle end-angle filled) + (if filled + (x11:xfillarc (object-display drawable) drawable gcontext - ;;--rounding - (- center-x x-radius) - (- center-y y-radius) - (* 2 x-radius) - (* 2 y-radius) - start-angle end-angle)))) + x y width height + start-angle end-angle) + (x11:xdrawarc + (object-display drawable) + drawable + gcontext + x y width height + start-angle end-angle))) (defun draw-rectangle (drawable gcontext x y width height &optional diff --git a/tk/widget.lisp b/tk/widget.lisp index 5560f24a81f8ea1f154f7ed6c01127e63c505c21..d0997495571e3e434c7e72cd3341be0dacf9b3fb 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.32 1993/08/12 16:04:46 cer Exp $ +;; $fiHeader: widget.lisp,v 1.33 1993/09/17 19:06:47 cer Exp $ (in-package :tk) @@ -277,16 +277,30 @@ ;; note that this is different from xt-initialize which calls ;; XtToolkitInitialize. This is closer to XtAppInitialize +(defvar *fallback-resources* '("clim*dragInitiatorProtocolStyle: DRAG_NONE" + "clim*dragreceiverprotocolstyle: DRAG_NONE" + ) + "A list of resource specification strings") + (defun initialize-toolkit (&rest args) - (let* ((context (create-application-context)) - (display (apply #'make-instance 'display - :context context - args)) - (app (apply #'app-create-shell - :display display - :widget-class 'application-shell - args))) - (values context display app))) + (let* ((context (create-application-context))) + (when *fallback-resources* + (xt_app_set_fallback_resources + context + (let* ((n (length *fallback-resources*)) + (v (make-array (1+ n) :element-type '(unsigned-byte 32)))) + (dotimes (i n) + (setf (aref v i) (ff:string-to-char* (nth i *fallback-resources*)))) + (setf (aref v n) 0) + v))) + (let* ((display (apply #'make-instance 'display + :context context + args)) + (app (apply #'app-create-shell + :display display + :widget-class 'application-shell + args))) + (values context display app)))) (defun xt-name (w) (char*-to-string (xt_name w))) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index d3546684789f067afd0cbad27e2e7c654317864c..7fefd48b26bb6a0077b3dd70b0a57fbaf61a52ca 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.20 1993/07/29 20:52:02 layer Exp $ +;; $fiHeader: xt-funs.lisp,v 1.21 1993/08/12 16:04:55 cer Exp $ ;; @@ -423,3 +423,10 @@ +(ff:defforeign 'xt_app_set_fallback_resources + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :entry-point (ff:convert-to-lang "XtAppSetFallbackResources") + :return-type :void) +