diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 5e2c2d9342c6240009042742410f170e16763954..52a6e2945441e8abd567a10cd5adb0eec9be1c00 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.42 92/11/09 10:54:03 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.43 92/11/09 19:54:44 cer Exp $ (in-package :clim-internals) @@ -1283,3 +1283,46 @@ :x 0 :y 0 :modifier-state 0 :button +pointer-left-button+))))))))) + +;;--- It seems a little bizarre having a prompt argument but +;;--- is there a better way. + +(defmethod stream-present ((stream accept-values-stream) object presentation-type + &rest present-args + &key view + (prompt nil prompt-p) + (query-identifier nil)) + + (declare (ignore prompt)) + (unless prompt-p (return-from stream-present (call-next-method))) + + (flet ((do-ppresent (stream) + (updating-output + (stream :unique-id query-identifier + :id-test #'equal + :cache-value object + :cache-test #'equal) + stream + ;;--- We did this because (sequence integer) reinvoked + ;;--- present with the prompt for each of components of + ;;--- the stream. so we end up back here and create badly + ;;--- identified updating-output records. + (apply #'stream-present (encapsulating-stream-stream stream) + object presentation-type present-args)))) + (declare (dynamic-extent #'do-ppresent)) + (let ((align-prompts (slot-value stream 'align-prompts))) + (cond (align-prompts + ;; The user has asked to line up the labels, so oblige him + (formatting-row (stream) + (formatting-cell (stream :align-x align-prompts) + (setq query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) presentation-type view present-args))) + (formatting-cell (stream :align-x :left) + (do-ppresent stream)))) + (t + (setq query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) presentation-type view present-args)) + (do-ppresent stream))))) + (values object)) diff --git a/clim/activities.lisp b/clim/activities.lisp index b6b36cf11d1164c8f5fafe87a209d3e1a2462046..880c730e3deb1258d6b8c961f15f32acd3643b46 100644 --- a/clim/activities.lisp +++ b/clim/activities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: activities.lisp,v 1.4 92/10/29 15:02:39 cer Exp $ +;; $fiHeader: activities.lisp,v 1.5 92/11/06 18:59:00 cer Exp $ (in-package :clim-internals) @@ -183,7 +183,9 @@ (select-activity-active-frame activity frame)))) (defmethod activity-frame-window-select :around ((activity-frame activity-frame)) - (unless (eq activity-frame (activity-active-frame (frame-activity activity-frame))) + (unless (let ((activity (frame-activity activity-frame))) + (and activity + (eq activity-frame (activity-active-frame activity)))) (call-next-method))) (defun select-activity-active-frame (activity frame) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index ce859ae5bc7e95dd2320263859377d04c33bc1a7..a16b0ef0138e7245ebdeac078ace1b013a343f6d 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.37 92/11/09 10:54:34 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.38 92/11/09 19:54:54 cer Exp $ (in-package :clim-internals) @@ -106,13 +106,7 @@ (output-record-stream record) (output-record-parent record)) (with-bounding-rectangle* (left top right bottom) record (translate-positions xoff yoff left top right bottom) - (with-bounding-rectangle* (gleft gtop gright gbottom) gadget - (unless (and (= left gleft) - (= top gtop) - (= right gright) - (= bottom gbottom)) - (move-and-resize-sheet gadget - left top (- right left) (- bottom top))))))))) + (move-and-resize-sheet gadget left top (- right left) (- bottom top))))))) ;;--- Flush this when REPLAY-OUTPUT-RECORD calls itself recursively (defmethod note-output-record-replayed ((record gadget-output-record) stream @@ -278,11 +272,13 @@ ;;; Completion gadget (define-presentation-method decode-indirect-view - ((type completion) (view gadget-dialog-view) - (framem standard-frame-manager) &key) + ((type completion) (view gadget-dialog-view) + (framem standard-frame-manager) &key read-only) ;;--- We can be clever and return different views depending on the ;;--- number of items, etc. - +radio-box-view+) + (if read-only + (call-next-method) + +radio-box-view+)) ;(define-presentation-method gadget-includes-prompt-p ; ((type completion) (stream t) (view radio-box-view)) @@ -362,9 +358,11 @@ ;;; Subset completion gadget (define-presentation-method decode-indirect-view - ((type subset-completion) (view gadget-dialog-view) - (framem standard-frame-manager) &key) - +check-box-view+) + ((type subset-completion) (view gadget-dialog-view) + (framem standard-frame-manager) &key read-only) + (if read-only + (call-next-method) + +check-box-view+)) ;(define-presentation-method gadget-includes-prompt-p ; ((type subset-completion) (stream t) (view check-box-view)) @@ -446,9 +444,11 @@ ;;; Boolean gadget (define-presentation-method decode-indirect-view - ((type boolean) (view gadget-dialog-view) - (framem standard-frame-manager) &key) - +toggle-button-view+) + ((type boolean) (view gadget-dialog-view) + (framem standard-frame-manager) &key read-only) + (if read-only + (call-next-method) + +toggle-button-view+)) (define-presentation-method gadget-includes-prompt-p ((type boolean) (stream t) (view toggle-button-view)) @@ -486,10 +486,25 @@ t) (define-presentation-method accept-present-default - ((type real) stream (view slider-view) - default default-supplied-p present-p query-identifier - &key (prompt t) (active-p t)) + ((type real) stream (view slider-view) + default default-supplied-p present-p query-identifier + &key (prompt t) (active-p t)) (declare (ignore present-p)) + (make-real-gadget-for-slider-view stream view active-p default + type prompt query-identifier + low high default-supplied-p t)) + +(define-presentation-method present + (object (type real) stream (view slider-view) &key acceptably query-identifier prompt) + (declare (ignore acceptably)) + (make-real-gadget-for-slider-view stream view t object + type prompt query-identifier + low high t nil)) + +(defun make-real-gadget-for-slider-view (stream view active-p default + type prompt query-identifier + low high default-supplied-p + &optional (editable-p t)) (move-cursor-to-view-position stream view) (let ((min-value (if (eq low '*) 0 low)) (max-value (if (eq high '*) 100 high))) @@ -505,24 +520,41 @@ (let ((slider ;;--- What other initargs do we pass along from the 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 - :orientation (gadget-orientation view) - :decimal-places (slider-decimal-places view) - :show-value-p (gadget-show-value-p view) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :active active-p))) + :label (and (stringp prompt) prompt) + :value (if default-supplied-p default min-value) + :min-value min-value :max-value max-value + :orientation (gadget-orientation view) + :decimal-places (or (slider-decimal-places view) 0) + :show-value-p (gadget-show-value-p view) + :client stream :id query-identifier + :value-changed-callback + (and editable-p + (make-accept-values-value-changed-callback + stream query-identifier)) + :active active-p + :editable-p editable-p))) (values (outlining () slider) slider)))))) (define-presentation-method accept-present-default - ((type integer) stream (view slider-view) - default default-supplied-p present-p query-identifier - &key (prompt t) (active-p t)) + ((type integer) stream (view slider-view) + default default-supplied-p present-p query-identifier + &key (prompt t) (active-p t)) (declare (ignore present-p)) + (make-integer-gadget-for-slider-view stream view active-p default + type prompt query-identifier + low high default-supplied-p t)) + +(define-presentation-method present + (object (type integer) stream (view slider-view) &key acceptably query-identifier prompt) + (declare (ignore acceptably)) + (make-integer-gadget-for-slider-view stream view t object + type prompt query-identifier + low high t nil)) + +(defun make-integer-gadget-for-slider-view (stream view active-p default + type prompt query-identifier + low high default-supplied-p + &optional (editable-p t)) (move-cursor-to-view-position stream view) (let ((min-value (if (eq low '*) 0 low)) (max-value (if (eq high '*) 100 high))) @@ -536,45 +568,75 @@ (if default-supplied-p default min-value)))) (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 - :label (and (stringp prompt) prompt) - :value (if default-supplied-p default min-value) - :min-value min-value :max-value max-value - :orientation (gadget-orientation view) - :number-of-quanta (- high low) :decimal-places 0 - :show-value-p (gadget-show-value-p view) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :active active-p))) + ;;--- What other initargs do we pass along from the 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 + :orientation (gadget-orientation view) + :number-of-quanta (- max-value min-value) + :decimal-places 0 + :show-value-p (gadget-show-value-p view) + :client stream :id query-identifier + :value-changed-callback + (and editable-p + (make-accept-values-value-changed-callback + stream query-identifier)) + :active active-p + :editable-p editable-p))) (values (outlining () slider) slider)))))) ;;; Text editing gadgets (define-presentation-method accept-present-default - ((type t) stream (view text-field-view) - default default-supplied-p present-p query-identifier - &key (prompt t) (active-p t)) + ((type t) stream (view text-field-view) + default default-supplied-p present-p query-identifier + &key (prompt t) (active-p t)) (declare (ignore default-supplied-p present-p)) + (make-gadget-for-text-field-view stream view active-p default type prompt query-identifier t)) + +;;;-- This is boring. We need a whole bunch of methods to shadow those +;;;-- in standard-types: +;;;-- eg.. + +(defmacro define-present-methods-for-types (function types view) + `(progn + ,@(mapcar #'(lambda (type) + `(define-presentation-method present + (object (type ,type) stream (view ,view) + &key acceptably query-identifier prompt) + (declare (ignore acceptably)) + (,function + stream view t object type prompt query-identifier nil))) + types))) + +;;;--- Should there be a method specialized on T??? + +(define-present-methods-for-types make-gadget-for-text-field-view + (real string pathname completion subset-completion sequence sequence-enumerated boolean) + text-field-view) + +(defun make-gadget-for-text-field-view (stream view active-p default type prompt query-identifier + &optional (editable-p t)) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget text-field) (declare (ignore record gadget)) ;;-- This sucks - (if active-p - (activate-gadget text-field) - (deactivate-gadget text-field)) + (if active-p + (activate-gadget text-field) + (deactivate-gadget text-field)) (setf (gadget-value text-field) (present-to-string default type)))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let ((text-field (make-pane-from-view 'text-field view - :label (and (stringp prompt) prompt) - :value (present-to-string default type) - :client stream :id query-identifier - :value-changed-callback - `(accept-values-string-field-changed-callback - ,stream ,query-identifier) - :active active-p))) + :label (and (stringp prompt) prompt) + :value (present-to-string default type) + :client stream :id query-identifier + :editable-p editable-p + :value-changed-callback + (and editable-p + `(accept-values-string-field-changed-callback + ,stream ,query-identifier)) + :active active-p))) (values text-field text-field))))) ;;--- This is mostly nonsense. If we enter something that is an error then @@ -599,34 +661,43 @@ (framem standard-frame-manager) &key) +text-field-view+) -(define-presentation-method accept-present-default - ((type string) stream (view text-field-view) - default default-supplied-p present-p query-identifier - &key (prompt t) (active-p t)) - (declare (ignore default-supplied-p present-p)) - (move-cursor-to-view-position stream view) - (flet ((update-gadget (record gadget button) - (declare (ignore record gadget)) - (if active-p - (activate-gadget button) - (deactivate-gadget button)) - (setf (gadget-value button) default))) - (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let ((text-field (make-pane-from-view 'text-field view - :label (and (stringp prompt) prompt) - :value default - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :active active-p))) - (values text-field text-field))))) +;;--- How does this differ from the default method for +;;--- accept-present-default +;(define-presentation-method accept-present-default +; ((type string) stream (view text-field-view) +; default default-supplied-p present-p query-identifier +; &key (prompt t) (active-p t)) +; (declare (ignore default-supplied-p present-p)) +; (move-cursor-to-view-position stream view) +; (flet ((update-gadget (record gadget button) +; (declare (ignore record gadget)) +; (if active-p +; (activate-gadget button) +; (deactivate-gadget button)) +; (setf (gadget-value button) default))) +; (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) +; (let ((text-field (make-pane-from-view 'text-field view +; :label (and (stringp prompt) prompt) +; :value default +; :client stream :id query-identifier +; :value-changed-callback +; (make-accept-values-value-changed-callback +; stream query-identifier) +; :active active-p))) +; (values text-field text-field))))) (define-presentation-method accept-present-default - ((type string) stream (view text-editor-view) - default default-supplied-p present-p query-identifier - &key (prompt t) (active-p t)) + ((type string) stream (view text-editor-view) + default default-supplied-p present-p query-identifier + &key (prompt t) (active-p t)) (declare (ignore default-supplied-p present-p)) + (make-gadget-for-text-editor stream view active-p default type prompt query-identifier t)) + +(define-present-methods-for-types make-gadget-for-text-editor (string) text-editor-view) + +(defun make-gadget-for-text-editor (stream view active-p default type prompt query-identifier + &optional (editable-p t)) + (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget button) (declare (ignore record gadget)) @@ -636,13 +707,15 @@ (setf (gadget-value button) default))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let ((text-field (make-pane-from-view 'text-editor view - :label (and (stringp prompt) prompt) - :value default - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :active active-p))) + :label (and (stringp prompt) prompt) + :value default + :client stream :id query-identifier + :value-changed-callback + (and editable-p + (make-accept-values-value-changed-callback + stream query-identifier)) + :active active-p + :editable-p editable-p))) (values (scrolling () text-field) text-field))))) @@ -744,4 +817,3 @@ (defmethod sheet-disown-child ((stream standard-encapsulating-stream) child) (sheet-disown-child (encapsulating-stream-stream stream) child)) - diff --git a/clim/present.lisp b/clim/present.lisp index 67ace546bc5a0ba827cf143d349b5ea016775469..f7316c9fc6aa49ecc4cbcdac2e41f112afadf5ae 100644 --- a/clim/present.lisp +++ b/clim/present.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: present.lisp,v 1.9 92/10/28 11:31:57 cer Exp $ +;; $fiHeader: present.lisp,v 1.10 92/11/06 19:00:17 cer Exp $ (in-package :clim-internals) @@ -8,7 +8,11 @@ (defun present (object &optional (presentation-type (presentation-type-of object)) &rest present-args - &key (stream *standard-output*) &allow-other-keys) + &key (stream *standard-output*) + (view (stream-default-view stream)) + (for-context-type presentation-type) + query-identifier + &allow-other-keys) (declare (dynamic-extent present-args)) (declare (arglist object &optional (presentation-type (presentation-type-of object)) &key (stream *standard-output*) @@ -17,9 +21,34 @@ (for-context-type presentation-type) (single-box nil) (allow-sensitive-inferiors *allow-sensitive-inferiors*) (sensitive *allow-sensitive-inferiors*) - (record-type 'standard-presentation))) - (with-keywords-removed (present-args present-args '(:stream)) - (apply #'stream-present stream object presentation-type present-args))) + (record-type 'standard-presentation) + prompt + query-identifier)) + + (multiple-value-bind (expansion expanded) + (expand-presentation-type-abbreviation presentation-type) + (when expanded + (when (eq for-context-type presentation-type) + (setq for-context-type expansion)) + (setq presentation-type expansion))) + + (unless (eq for-context-type presentation-type) + (multiple-value-bind (expansion expanded) + (expand-presentation-type-abbreviation for-context-type) + (when expanded + (setq for-context-type expansion)))) + + (typecase view + (null) + (symbol (setq view (make-instance view))) + (cons (setq view (apply #'make-instance view)))) + + (setq view (decode-indirect-view presentation-type view (frame-manager stream) + :read-only t + :query-identifier query-identifier)) + + (with-keywords-removed (present-args present-args '(:stream :view)) + (apply #'stream-present stream object presentation-type :view view present-args))) ;; Specialize on T since this method is good for all stream classes (defmethod stream-present ((stream t) object presentation-type @@ -28,7 +57,8 @@ (for-context-type presentation-type) (single-box nil) (allow-sensitive-inferiors *allow-sensitive-inferiors*) (sensitive *allow-sensitive-inferiors*) - (record-type 'standard-presentation)) + (record-type 'standard-presentation) + (prompt nil prompt-p)) ;; The arguments are allowed to be presentation type abbreviations (multiple-value-bind (expansion expanded) @@ -61,13 +91,15 @@ :single-box single-box :allow-sensitive-inferiors allow-sensitive-inferiors :record-type record-type) - (funcall-presentation-generic-function present + (apply-presentation-generic-function present object presentation-type stream view - :acceptably acceptably :for-context-type for-context-type)) + :acceptably acceptably :for-context-type for-context-type + (and prompt-p (list :prompt prompt)))) (let ((*allow-sensitive-inferiors* allow-sensitive-inferiors)) - (funcall-presentation-generic-function present + (apply-presentation-generic-function present object presentation-type stream view - :acceptably acceptably :for-context-type for-context-type)))) + :acceptably acceptably :for-context-type for-context-type + (and prompt-p (list :prompt prompt)))))) (defun present-to-string (object &optional (presentation-type (presentation-type-of object)) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index ed89baa036eb217bfb3c27d7517b97e16bc8939f..b4a2fb2c83ff4b997734ec32c126b3609a628d8d 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes1.lisp,v 1.18 92/10/28 11:31:59 cer Exp $ +;; $fiHeader: ptypes1.lisp,v 1.19 92/11/06 19:00:20 cer Exp $ (in-package :clim-internals) @@ -335,6 +335,9 @@ ;;; This hash table is keyed by the presentation type name and yields the class. (defvar *presentation-type-class-table* (make-hash-table)) +;;; Keyed by name, yields the function that translates one type specifier into another +(defvar *presentation-type-abbreviation-table* (make-hash-table)) + #+CCL-2 (defvar *presentation-class-type-table* (make-hash-table)) @@ -498,8 +501,7 @@ ;;;; Presentation Type Abbreviations -;;; Keyed by name, yields the function that translates one type specifier into another -(defvar *presentation-type-abbreviation-table* (make-hash-table)) + ;;; Define a "macro" that expands one presentation type specifier into another (defmacro define-presentation-type-abbreviation (name parameters expansion &key options diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index dbfb90c05b65e5298112ad94b0916fec49194520..de5ce133630d8bb1f9cd6b7b0d5bea2f3d169c16 100644 --- a/clim/ptypes2.lisp +++ b/clim/ptypes2.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes2.lisp,v 1.18 92/11/09 10:54:42 cer Exp $ +;; $fiHeader: ptypes2.lisp,v 1.19 92/11/09 19:55:03 cer Exp $ (in-package :clim-internals) @@ -501,9 +501,9 @@ (declare (ignore presentation-type framem query-identifier)) view) -(defun decode-indirect-view (type view frame-manager &rest args &key query-identifier) - (declare (dynamic-extent args)) - (declare (ignore query-identifier)) +(defun decode-indirect-view (type view frame-manager &rest args &key query-identifier read-only) + (declare (dynamic-extent args) + (ignore query-identifier read-only)) (apply-presentation-generic-function decode-indirect-view type view frame-manager args)) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index e9e31d5c3719ec23e8542bec59344db009adfbca..9ec293c945d5f8ad124a0f6a420e1360d9a20a0d 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.17 92/10/28 11:32:07 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.18 92/11/06 19:00:31 cer Exp $ (in-package :clim-internals) @@ -563,11 +563,11 @@ (define-presentation-method accept ((type completion) stream (view textual-view) &key) (flet ((possibility-printer (possibility type stream) - (declare (ignore type)) - (funcall printer - (funcall name-key (find (second possibility) sequence - :key value-key :test test)) - stream))) + (with-output-as-presentation (stream (funcall value-key (second possibility)) type) + (funcall printer + (funcall name-key (find (second possibility) sequence + :key value-key :test test)) + stream)))) (declare (dynamic-extent #'possibility-printer)) (values (completing-from-suggestions @@ -746,10 +746,11 @@ (make-array 2 :initial-contents (list separator #\space))))) (flet ((possibility-printer (possibility type stream) (declare (ignore type)) - (funcall printer - (funcall name-key (find (second possibility) sequence - :key value-key :test test)) - stream))) + (with-output-as-presentation (stream (funcall value-key (second possibility)) type) + (funcall printer + (funcall name-key (find (second possibility) sequence + :key value-key :test test)) + stream)))) (declare (dynamic-extent #'possibility-printer)) (loop (let ((element diff --git a/misc/undefinedsymbols.olit b/misc/undefinedsymbols.olit index 2bd8b9d592c6ee8524ecde775b897dd022226024..80d6e97edab395a3330050cea2ef3a1f73745fc7 100644 --- a/misc/undefinedsymbols.olit +++ b/misc/undefinedsymbols.olit @@ -23,6 +23,7 @@ _flatNonexclusivesWidgetClass _flatWidgetClass _footerPanelWidgetClass _formWidgetClass +_gaugeWidgetClass _helpWidgetClass _listPaneWidgetClass _magWidgetClass diff --git a/misc/undefinedsymbols.xt b/misc/undefinedsymbols.xt index 3d9d3d03fb69e2a7a859e69ab4b59a263c379dfb..856f2d7d608f6eed71e1e2114755ace35a80d90e 100644 --- a/misc/undefinedsymbols.xt +++ b/misc/undefinedsymbols.xt @@ -3,3 +3,4 @@ _XtGetResourceList _XtGetValues _XtSetValues _XtSetSensitive +_XtLastTimestampProcessed diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp index 1c6ca1f0c1f4b65413098fb03aacd7e7cd4f2c29..3f6e5bdad5474ceb7b2fd1153f378ef61b333b31 100644 --- a/postscript/postscript-medium.lisp +++ b/postscript/postscript-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-medium.lisp,v 1.7 92/10/02 15:21:16 cer Exp $ +;; $fiHeader: postscript-medium.lisp,v 1.8 92/10/28 11:33:27 cer Exp $ (in-package :postscript-clim) @@ -41,6 +41,7 @@ (dashes (line-style-dashes line-style))) (format printer-stream " ~D setlinewidth~%" thickness) (when dashes + (when (eq dashes t) (setq dashes '(4 4))) (making-ps-array (printer-stream) (let ((limit (length dashes))) (dotimes (i limit) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 49920e939814999e13261e7843afde0c754070b2..46211a6e9c4333b77be329e3a7015d8b3aeb7b5e 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.37 92/10/28 11:30:48 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.38 92/11/06 19:03:51 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -223,14 +223,16 @@ (max-label :initarg :max-label) (range-label-text-style :initarg :range-label-text-style) (number-of-tick-marks :initarg :number-of-tick-marks) - (number-of-quanta :initarg :number-of-quanta)) + (number-of-quanta :initarg :number-of-quanta) + (editable-p :initarg :editable-p :accessor gadget-editable-p)) (:default-initargs :decimal-places 0 :show-value-p nil :min-label nil :max-label nil :range-label-text-style *default-slider-range-label-text-style* :number-of-tick-marks 0 - :number-of-quanta nil)) + :number-of-quanta nil + :editable-p t)) (defmethod initialize-instance :after ((pane slider) &key (decimal-places 0 places-p) @@ -403,9 +405,12 @@ ;;; Text edit ;;--- Do we want to specify a binding to commands? + (defclass text-field - (value-gadget action-gadget) - ()) + (value-gadget action-gadget) + ((editable-p :initarg :editable-p :accessor + gadget-editable-p)) + (:default-initargs :editable-p t)) (defclass text-editor (text-field) ((ncolumns :initarg :ncolumns diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 160fcdae69284dff5834405d3b5a9b4485e02175..d31633872851cad3bc35a7e652fce003986f936a 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.43 92/11/06 19:04:13 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.44 92/11/09 19:55:44 cer Exp $ (in-package :clim-user) @@ -684,6 +684,23 @@ people, shall not perish from the earth. (draw-text* stream "Dont be silly in the City." x 200 :towards-x x :towards-y 0))))) +(define-test (pixmap-test graphics) (stream) + "Test pixmap code" + (with-sheet-medium (medium stream) + (let ((pixmap (with-output-to-pixmap (ps stream :width 100 :height 100) + (draw-rectangle* ps 0 0 100 100 :ink +red+) + (surrounding-output-with-border (ps) + (draw-text* ps "hello" 10 50))))) + (dotimes (i 5) + (sleep 0.25) + (copy-from-pixmap pixmap 0 0 100 100 medium (* i 100) (* i 100)))) + (dotimes (j 5) + (let ((pixmap (copy-to-pixmap medium (* j 100) (* j 100) 100 100))) + (dotimes (i 5) + (unless (= i j) + (sleep 0.25) + (copy-from-pixmap pixmap 0 0 100 100 medium (* j 100) (* i 100)))))))) + (defparameter *named-colors* '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+ "snow" "ghost-white" "white-smoke" "gainsboro" "floral-white" "old-lace" @@ -1791,9 +1808,82 @@ Luke Luck licks the lakes Luke's duck likes.")) :line-cap-shape :round)))))))))) (define-test (gadgets-dialog menus-and-dialogs) (stream) - "An own-window ACCEPTING-VALUES dialog that has graphics inside of it." + "An own-window ACCEPTING-VALUES dialog that has lots of gadgets inside of it." (gadgets-dialog-internal stream nil)) +(define-test (ozone-dialog menus-and-dialogs) (stream) + "Test of gadgets out in hyper space" + (let ((x "hello")) + (accepting-values (stream :own-window nil :label "Gadgets dialog") + (stream-set-cursor-position stream 100000 0) + (setq x (accept 'string :view +text-field-view+ + :stream stream + :default x)) + (terpri stream)))) + + +(define-test (readonly-gadget-dialog menus-and-dialogs) (stream) + " Create a bunch of readonly gadgets" + (accepting-values (stream :own-window nil :label "Gadgets dialog" + :align-prompts t) + (macrolet ((do-presents (view &rest p) + `(progn + ,@(mapcar #'(lambda (x) + `(progn + (present ',(car x) ',(cadr x) + ,@(and view `(:view ,view)) + :prompt (format nil "~A,~A" + ',(cadr x) + (if ,view (type-of ,view) :default)) + :stream stream) + (terpri stream))) + p)))) + (do-presents + nil + (5.0 real) + ("xxx" string) + (#P"/tmp/fooo" pathname) + (:a (member :a :b)) + ((:a :b) (subset :a :b)) + (( 3 4) (sequence integer)) + ;; sequence-enumerated + (t boolean)) + + (do-presents + +text-field-view+ + (5.0 real) + ("xxx" string) + (#P"/tmp/fooo" pathname) + (:a (member :a :b)) + ((:a :b) (subset :a :b)) + (( 3 4) (sequence integer)) + ;; sequence-enumerated + (t boolean)) + + + (do-presents + '(text-editor-view :nlines 5 :ncolumns 30) + (" (do-presents + +text-field-view+ + (5.0 real) + (xxx string) + (#P/tmp/fooo pathname) + (:a (member :a :b)) + ((:a :b) (subset :a :b)) + (( 3 4) (sequence integer)) + ;; sequence-enumerated + (t boolean)) " + string)) + + (do-presents + +slider-view+ + (5.0 float) + (1 integer))))) + + + + + (defun gadgets-dialog-internal (stream &optional own-window) (macrolet ((accepts (&rest accepts) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index de0d17fe8b4da7ab323faa39e67796aa3342f969..8236d62f82bfcac4df06ef0d6af4cff156c18b1d 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.29 92/10/04 14:16:48 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.30 92/10/28 11:33:15 cer Exp $ (in-package :xm-silica) @@ -51,15 +51,14 @@ ;;;;;;;;;;;;;;;;;;;; (defclass openlook-scroll-bar (scroll-bar + xt-oriented-gadget xt-leaf-pane) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-scroll-bar)) - (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::scrollbar - (list :orientation orientation)))) + (values 'tk::scrollbar nil)) (defmethod (setf scroll-bar-size) (nv (sb openlook-scroll-bar)) ;; (tk::set-values (sheet-direct-mirror sb) :slider-size nv) @@ -451,11 +450,15 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-text-field)) - (with-accessors ((value gadget-value)) sheet - (values 'tk::text-field - (append - `(:chars-visible ,(if (zerop (length value)) 30 (length value))) - (and value `(:string ,value)))))) + (with-accessors ((value gadget-value) + (editable gadget-editable-p)) sheet + (if editable + (values 'tk::text-field + (append + `(:chars-visible ,(if (zerop (length value)) 30 (length value))) + (and value `(:string ,value)))) + (values 'tk::static-text + `(:string ,value))))) (defun openlook-text-field-edit-widget (tf &optional (mirror (sheet-direct-mirror tf))) (tk::get-values mirror :text-edit-widget)) @@ -599,31 +602,6 @@ (with-no-value-changed-callbacks (tk::set-values (sheet-mirror gadget) :set nv)))) - - - -;;; - -;; Openlook-orriented-gadget - -(defclass openlook-oriented-gadget () ()) - -(defmethod find-widget-class-and-initargs-for-sheet :around ((port openlook-port) - (parent t) - (sheet openlook-oriented-gadget)) - (multiple-value-bind - (class initargs) - (call-next-method) - (with-accessors ((orientation gadget-orientation)) sheet - (unless (getf initargs :orientation) - (setf (getf initargs :orientation) orientation))) - (values class initargs))) - -(defmethod (setf gadget-orientation) :after (nv (gadget openlook-oriented-gadget)) - (when (sheet-direct-mirror gadget) - (tk::set-values (sheet-direct-mirror gadget) :orientation nv))) - - ;; (defclass openlook-radio-box (openlook-geometry-manager @@ -737,7 +715,7 @@ (defclass openlook-slider (#+ignore openlook-range-pane - #+ignore openlook-oriented-gadget + xt-oriented-gadget xt-leaf-pane slider) ()) @@ -748,14 +726,13 @@ (with-accessors ((label gadget-label) (show-value-p gadget-show-value-p) (value gadget-value) - (orientation gadget-orientation)) sheet + (editable gadget-editable-p)) sheet (multiple-value-bind (smin smax) (gadget-range* sheet) (let ((mmin 0) (mmax 100)) - (values 'tk::slider + (values (if editablep 'tk::slider 'tk::gauge) (append - (list :orientation orientation) #+dunno (and label (list :title-string label)) (list :slider-min mmin @@ -871,9 +848,11 @@ openlook-text-editor)) (with-accessors ((value gadget-value) (ncolumns gadget-columns) - (nlines gadget-lines)) sheet + (nlines gadget-lines) + (editable gadget-editable-p)) sheet (values 'tk::text-edit (append + `(and (not editable) `(:edit-type :text-read)) (and ncolumns (list :chars-visible ncolumns)) (and nlines (list :lines-visible nlines)) (and value `(:source ,value)))))) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index df54ab8fb3e7254e5e88c2f39922f8f086ad56cb..cd99952c5393ea96202c1cd44acc3f6e75d8a9c8 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.14 92/09/22 19:38:05 cer Exp $ +;; $fiHeader: ol-silica.lisp,v 1.15 92/10/02 15:20:56 cer Exp $ (in-package :xm-silica) @@ -53,15 +53,17 @@ (let ((window (tk::widget-window mirror))) (with-port-event-lock (port) (excl:without-interrupts - (tk:with-server-grabbed ((port-display port)) - (when (eq (tk::window-map-state window) :viewable) - ;;--- There could very well be a race condition involving - ;;--- a couple of processes. Another process could have made - ;;--- this window go away at this point - (tk::ol_set_input_focus - mirror - 2 ; RevertToParent - 0)))))))))) + (let ((display (port-display port))) + (tk:with-server-grabbed (display) + (when (eq (tk::window-map-state window) :viewable) + ;;--- There could very well be a race condition involving + ;;--- a couple of processes. Another process could have made + ;;--- this window go away at this point + (tk::ol_set_input_focus + mirror + 2 ; RevertToParent + ;;-- This is not exact but it might work better. + (xt::xt-last-timestamp-processed display)))))))))))) (defmethod change-widget-geometry ((parent tk::draw-area) child &rest args diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index f3832ff0898c20285ec8aeeeee59e9fcf3f8f5be..81d8e365405638abf9544cf8599c3e8b94023855 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.55 92/11/09 10:56:09 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.56 92/11/09 19:56:00 cer Exp $ (in-package :xm-silica) @@ -133,25 +133,6 @@ (:center :center) (:right :end))))) -;; Motif-orriented-gadget - -(defclass motif-oriented-gadget () ()) - -(defmethod find-widget-class-and-initargs-for-sheet :around ((port motif-port) - (parent t) - (sheet motif-oriented-gadget)) - (multiple-value-bind - (class initargs) - (call-next-method) - (with-accessors ((orientation gadget-orientation)) sheet - (unless (getf initargs :orientation) - (setf (getf initargs :orientation) orientation))) - (values class initargs))) - -(defmethod (setf gadget-orientation) :after (nv (gadget motif-oriented-gadget)) - (when (sheet-direct-mirror gadget) - (tk::set-values (sheet-direct-mirror gadget) :orientation nv))) - ;;; Motif widgets that support the activate callback (defclass motif-action-pane () ()) @@ -258,7 +239,7 @@ ;;; -(defclass motif-separator (motif-oriented-gadget +(defclass motif-separator (xt-oriented-gadget xt-leaf-pane silica::separator) ()) @@ -270,8 +251,19 @@ ;;; Slider +(defclass motif-oriented-sliding-gadget (xt-oriented-gadget) + ()) + +(defmethod set-widget-orientation ((gadget motif-oriented-sliding-gadget) nv) + (tk::set-values (sheet-direct-mirror gadget) + :processing-direction + (case nv + (:vertical :max-on-top) + (:horizontal :max-on-right)) + :orientation nv)) + (defclass motif-slider (motif-range-pane - motif-oriented-gadget + motif-oriented-sliding-gadget xt-leaf-pane slider) ()) @@ -294,7 +286,7 @@ (mmax 100) (decimal-points 0) (decimal-places (slider-decimal-places sheet))) - (cond ((and (or (null decimal-places) (zerop decimal-places)) + (cond ((and (zerop decimal-places) (typep smin '(signed-byte 32)) (typep smax '(signed-byte 32))) (setq mmin smin mmax smax decimal-points 0)) @@ -353,7 +345,7 @@ (defclass motif-scroll-bar (scroll-bar - motif-oriented-gadget + motif-oriented-sliding-gadget xt-leaf-pane) ()) @@ -513,9 +505,12 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-text-field)) - (with-accessors ((value gadget-value)) sheet + (with-accessors ((editable gadget-editable-p) + (value gadget-value)) sheet (values 'tk::xm-text-field (append + (and (not editable) '(:cursor-position-visible nil)) + `(:editable ,editable) (and value `(:value ,value)))))) ;;; @@ -537,6 +532,7 @@ (nlines gadget-lines)) sheet (values 'tk::xm-text (append + (and (not editable) '(:cursor-position-visible nil)) (list :edit-mode :multi-line) (list :editable editable) (and ncolumns (list :columns ncolumns)) @@ -682,7 +678,7 @@ (defclass motif-radio-box (motif-geometry-manager mirrored-sheet-mixin - motif-oriented-gadget + xt-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin radio-box @@ -701,7 +697,7 @@ (defclass motif-check-box (motif-geometry-manager mirrored-sheet-mixin - motif-oriented-gadget + xt-oriented-gadget sheet-multiple-child-mixin sheet-permanently-enabled-mixin check-box diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 32168a7c37e777d0546ce2100ed977be14b1524d..6dd32bbb510db931812e0a163ff60a495fad0889 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.23 92/10/02 15:21:06 cer Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.24 92/10/28 13:17:44 cer Exp $ (in-package :xm-silica) @@ -190,3 +190,26 @@ (clim-internals::keyboard-event-matches-gesture-name-p event gesture port)) (top-level-sheet-accelerator-gestures (frame-top-level-sheet frame)))))) + +;; Xt-orriented-gadget + +(defclass xt-oriented-gadget () ()) + +(defmethod find-widget-class-and-initargs-for-sheet :around ((port xt-port) + (parent t) + (sheet xt-oriented-gadget)) + (multiple-value-bind + (class initargs) + (call-next-method) + (with-accessors ((orientation gadget-orientation)) sheet + (unless (getf initargs :orientation) + (setf (getf initargs :orientation) orientation))) + (values class initargs))) + +(defmethod (setf gadget-orientation) :after (nv (gadget xt-oriented-gadget)) + (when (sheet-direct-mirror gadget) + (set-widget-orientation gadget nv))) + +(defmethod set-widget-orientation ((gadget xt-oriented-gadget) nv) + (tk::set-values (sheet-direct-mirror gadget) :orientation nv)) + diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp index c7ce3e1b0ba33726307b4c51401715d71ad0e48b..a6cb1c1f3d941b52da42a9d38f649266d6f08055 100644 --- a/tk-silica/xt-pixmaps.lisp +++ b/tk-silica/xt-pixmaps.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-pixmaps.lisp,v 1.10 92/09/08 15:19:21 cer Exp $ +;; $fiHeader: xt-pixmaps.lisp,v 1.11 92/10/02 15:21:10 cer Exp $ (in-package :xm-silica) @@ -115,6 +115,32 @@ (unless event (return)))))))))))) + +(defmethod medium-copy-area + ((pixmap tk::pixmap) from-x from-y width height + (to-medium xt-medium) to-x to-y) + (let ((transform (sheet-native-transformation (medium-sheet to-medium)))) + (convert-to-device-coordinates transform to-x to-y) + (let* ((window (medium-drawable to-medium)) + (copy-gc (port-copy-gc (port to-medium)))) + (tk::copy-area + pixmap copy-gc from-x from-y width height + window to-x to-y)))) + + +(defmethod medium-copy-area + ((from-medium xt-medium) from-x from-y width height + (pixmap tk::pixmap) to-x to-y) + ;;; What about the graphics exposure event problem + (let ((transform (sheet-native-transformation (medium-sheet from-medium)))) + (convert-to-device-coordinates transform from-x from-y) + (convert-to-device-distances transform width height) + (let* ((window (medium-drawable from-medium)) + (copy-gc (port-copy-gc (port from-medium)))) + (tk::copy-area + window copy-gc from-x from-y width height + pixmap to-x to-y)))) + ;;; I dont understand the need for these methods ;;; Also what is the xt-pixmap class below. @@ -149,27 +175,3 @@ pixmap copy-gc from-x from-y width height window to-x to-y)))) -#+ignore -(defmethod medium-copy-area - ((from-medium xt-medium) from-x from-y width height - (pixmap tk::pixmap) to-x to-y) - (let ((transform (sheet-native-transformation (medium-sheet from-medium)))) - (convert-to-device-coordinates transform from-x from-y) - (convert-to-device-distances transform width height) - (let ((window (medium-drawable from-medium)) - (copy-gc (make-instance 'tk::gcontext :drawable window))) - (tk::copy-area - window copy-gc from-x from-y width height - pixmap to-x to-y)))) - -#+ignore -(defmethod medium-copy-area - ((pixmap tk::pixmap) from-x from-y width height - (to-medium xt-medium) to-x to-y) - (let ((transform (sheet-native-transformation (medium-sheet to-medium)))) - (convert-to-device-coordinates transform to-x to-y) - (let ((window (medium-drawable to-medium)) - (copy-gc (make-instance 'tk::gcontext :drawable window))) - (tk::copy-area - pixmap copy-gc from-x from-y width height - window to-x to-y)))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 919e85ecaecfb305e4c6d7a67af8d47da6c1addc..9f8a67ba82a35092c4fcc9dcac3ffcac254754c2 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.55 92/11/05 17:16:01 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.56 92/11/06 19:04:44 cer Exp $ (in-package :xm-silica) @@ -47,7 +47,9 @@ (defmethod port-type ((port xt-port)) ':xt) + (defmethod port-copy-gc ((port xt-port)) + ;;-- Assume 1-1 port-graft mapping? (with-slots (copy-gc display) port (or copy-gc (setf copy-gc @@ -927,6 +929,26 @@ (apply #'tk::set-values child args)) +(defmethod change-widget-geometry :around (parent child &key x y width height) + ;;-- Nasty use of (widget-callback-data child) field + (unless (and (typep x '(signed-byte 16)) + (typep (+ x width) '(signed-byte 16)) + (typep y '(signed-byte 16)) + (typep (+ y height) '(signed-byte 16))) + (let ((window (tk::widget-window child nil))) + (when (and window (not (assoc 'widget-is-cached (tk::widget-callback-data child)))) + (push (cons 'widget-is-cached t) (tk::widget-callback-data child)) + (x11::xunmapwindow (xt::widget-display child) window))) + (return-from change-widget-geometry nil)) + ;; Make sure its mapped + (let ((x (assoc 'widget-is-cached (tk::widget-callback-data child)))) + (when x + (setf (tk::widget-callback-data child) (delete x (tk::widget-callback-data child))) + (let ((window (tk::widget-window child nil))) + (when window (x11::xmapwindow (xt::widget-display child) window))))) + ;; + (call-next-method)) + (defmethod popup-frame-p ((frame application-frame)) (typep frame '(or clim-internals::menu-frame clim-internals::accept-values-own-window))) diff --git a/tk/ol-classes.lisp b/tk/ol-classes.lisp index c7558796d005bcb857eeca28f68fb47103642528..06163a398b3a520fe55a3a488d1aea3f86b89fe0 100644 --- a/tk/ol-classes.lisp +++ b/tk/ol-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-classes.lisp,v 1.6 92/06/23 08:19:12 cer Exp $ +;; $fiHeader: ol-classes.lisp,v 1.7 92/08/18 17:53:40 cer Exp $ (in-package :tk) @@ -65,6 +65,7 @@ "_flatWidgetClass" "_footerPanelWidgetClass" "_formWidgetClass" + "_gaugeWidgetClass" "_helpWidgetClass" "_listPaneWidgetClass" "_magWidgetClass" diff --git a/tk/resources.lisp b/tk/resources.lisp index 549ade1a67157d880b108e9a7ce2adfcf4b9338e..c05d514344fe9de5c71cdd66d4fc783f090d853a 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.35 92/10/04 14:16:04 cer Exp $ +;; $fiHeader: resources.lisp,v 1.36 92/11/10 08:56:23 cer Exp $ (in-package :tk) @@ -630,3 +630,9 @@ (make-instance 'font :display (widget-display parent) :foreign-address value)) + + +(define-enumerated-resource processing-direction (:max-on-top + :max-on-bottom + :max-on-left + :max-on-right)) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 111cc0590c2125aad5118fb4b48d1685fe2fb96d..ec156e914fc4441c2eaeaf3d025d690ea67c5867 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.12 92/09/22 19:36:41 cer Exp $ +;; $fiHeader: xt-funs.lisp,v 1.13 92/10/02 15:18:02 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -315,3 +315,11 @@ :arg-checking nil :return-type :fixnum) + +(defforeign 'xt-last-timestamp-processed + :entry-point "_XtLastTimestampProcessed" + :call-direct t + :arguments '(foreign-address ; display + ) + :arg-checking nil + :return-type :unsigned-integer)