diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 3a0b6549059698dfc54eddb878fc94b020c49f20..a72de6c787fac43e838cfd200ee22543cf73c518 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.61 1993/05/05 01:38:12 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.62 1993/05/13 16:22:58 cer Exp $ (in-package :clim-internals) @@ -138,6 +138,8 @@ (setf (accept-values-query-changed-p query) nil))))) ;; Probably should be keyword arguments... + + (defmethod find-or-add-query ((stream accept-values-stream) query-identifier ptype prompt default default-supplied-p view active-p) (let ((avv-record (slot-value stream 'avv-record))) @@ -180,7 +182,8 @@ ;; can change values without changing the query itself. :default (if (accept-values-query-changed-p query) (accept-values-query-value query) - (setf (accept-values-query-value query) default)) + (setf (accept-values-query-error-p query) nil + (accept-values-query-value query) default)) :history ptype :present-p `(accept-values-choice ,query) :query-identifier query @@ -449,9 +452,9 @@ (setq initial-query (find-query avv-record (car initially-select-query-identifier)))) - (if (cdr initially-select-query-identifier) - (com-modify-avv-choice initial-query) - (com-edit-avv-choice initial-query)) + (move-focus-to-query stream + initial-query + (not (cdr initially-select-query-identifier))) (redisplay avv stream :check-overlapping check-overlapping)) (loop (let ((command @@ -561,6 +564,32 @@ (move-cursor-beyond-output-record (encapsulating-stream-stream stream) avv))))))))) +(defun find-query-gadget (query) + (let ((record (accept-values-query-presentation query))) + (when record + (labels ((find-gadget-output-record (record) + (typecase record + (gadget-output-record + (return-from find-query-gadget (output-record-gadget record))) + (output-record + (map-over-output-records #'find-gadget-output-record record))))) + (declare (dynamic-extent #'find-gadget-output-record)) + (find-gadget-output-record record))))) + +(defun move-focus-to-query (stream query &optional (editp t)) + (declare (ignore stream)) + ;;-- If there is a gadget then we should move the focus to that + ;;-- otherwise edit the field + (let ((gadget (find-query-gadget query))) + (cond (gadget + (move-focus-to-gadget gadget)) + ;;-- This stuff will still loose on old style CLIM + ;;-- member fields + (editp + (com-edit-avv-choice query)) + (t + (com-modify-avv-choice query))))) + (defmethod display-view-background (stream (view view)) nil) @@ -593,36 +622,16 @@ (loop (read-gesture :stream stream))) (defmethod frame-manager-display-help - ((framem standard-frame-manager) (frame accept-values-own-window) stream continuation) + (framem (frame accept-values-own-window) (stream standard-input-editing-stream) continuation) (declare (dynamic-extent continuation)) - (when (null (slot-value frame 'help-window)) - (setf (slot-value frame 'help-window) - (allocate-resource 'menu stream (window-root stream)))) - (let ((help-window (slot-value frame 'help-window)) - (own-window (slot-value frame 'own-window))) - (setf (window-visibility help-window) nil) - ;; You might think that we should bind *INPUT-CONTEXT* to NIL, but - ;; by not doing the translators from the ACCEPT-VALUES dialog apply - ;; to any items presented in the help window. Cool, huh? - (let ((*original-stream* nil)) - (window-clear help-window) - (with-output-recording-options (help-window :draw t :record t) - (with-end-of-line-action (help-window :allow) - (with-end-of-page-action (help-window :allow) - (funcall continuation help-window) - (fresh-line help-window) - (with-text-face (help-window :italic) - (write-line "Press any key to remove this window" help-window))))) - (size-frame-from-contents help-window) - (multiple-value-bind (x y) (bounding-rectangle-position own-window) - (position-sheet-carefully - (frame-top-level-sheet (pane-frame help-window)) x y)) - (setf (window-visibility help-window) t) - (clear-input help-window) - (unwind-protect - (with-input-focus (help-window) - (read-gesture :stream help-window)) - (setf (window-visibility help-window) nil))))) + ;;-- Yuck but think of a better way + (let ((old-help *accept-help*)) + (accepting-values (stream :exit-boxes '(:exit) + :label "Input editor help" + :own-window t) + (let ((*accept-help* old-help)) + (funcall continuation stream))))) + (defmethod accept-values-top-level :around ((frame accept-values-own-window) &rest args) (declare (ignore args)) @@ -667,14 +676,17 @@ (define-presentation-type accept-values-exit-box ()) -(defmacro with-exit-box-decoded ((value label text-style) exit-box labels &body body) +(defmacro with-exit-box-decoded ((value label text-style documentation) exit-box labels &body body) `(let* ((,value (if (consp ,exit-box) (first ,exit-box) ,exit-box)) (,label (or (and (consp ,exit-box) (second ,exit-box)) (second (assoc ,value ,labels)))) (,text-style (or (and (consp ,exit-box) (getf (cddr ,exit-box) :text-style)) - (getf (cddr (assoc ,value ,labels)) :text-style)))) + (getf (cddr (assoc ,value ,labels)) :text-style))) + (,documentation (or (and (consp ,exit-box) + (getf (cddr ,exit-box) :documentation)) + (getf (cddr (assoc ,value ,labels)) :documentation)))) ,@body)) ;;; Applications can create their own AVV class and specialize this method in @@ -689,7 +701,8 @@ (updating-output (stream :unique-id stream :cache-value 'exit-boxes) (with-slots (exit-boxes) frame (dolist (exit-box exit-boxes) - (with-exit-box-decoded (value label text-style) exit-box labels + (with-exit-box-decoded (value label text-style documentation) exit-box labels + (declare (ignore documentation)) (when label (with-text-style (stream text-style) (with-output-as-presentation (stream value 'accept-values-exit-box) @@ -884,21 +897,88 @@ (define-gesture-name :abort-dialog :keyboard (:abort)) (define-accept-values-command (com-exit-avv :keystroke :exit-dialog) () - (with-slots (stream) *application-frame* - (let ((avv-record (slot-value stream 'avv-record)) - (query-ids nil)) - (map-over-accept-values-queries avv-record - #'(lambda (record unique-id) - (declare (ignore record)) - (when (accept-values-query-error-p (find-query avv-record unique-id)) - (push unique-id query-ids)))) - (if query-ids - (notify-user *application-frame* - (format nil "The following fields are not valid:~{ ~A~}" - (mapcar #'cadr (nreverse query-ids))) - :title "Invalid Fields" - :style :error :exit-boxes '(:exit)) - (frame-exit *application-frame*))))) + (let ((frame *application-frame*)) + (with-slots (stream) frame + (when (verify-queries frame stream (slot-value stream 'avv-record)) + (frame-exit *application-frame*))))) + + +(defun verify-queries (frame stream avv-record) + (let ((queries nil)) + (maphash + #'(lambda (query-identifier query) + (declare (ignore query-identifier)) + (when (and (accept-values-query-active-p query) + (output-record-stream (accept-values-query-presentation query)) + (accept-values-query-error-p query)) + (push query queries))) + (slot-value avv-record 'query-table)) + (if queries + (progn + (verify-queries-1 frame stream queries) + nil) + t))) + +(defun verify-queries-1 (frame stream queries) + (display-invalid-queries + frame + stream + (mapcar #'(lambda (query) + (list + query + (slot-value query 'query-identifier) + (let ((condition (accept-values-query-error-p query))) + (and (not (eq condition t)) condition)))) + queries)) + (move-focus-to-query stream (car queries))) + + + +(defmethod display-invalid-queries ((frame standard-application-frame) stream query-info) + (declare (ignore stream)) + (notify-user frame + (format nil "The following fields are not valid:~{ ~{~A~:[~;~:* : ~A~]~}~}" + (mapcar #'(lambda (query-stuff) + (destructuring-bind (query id condition) query-stuff + (declare (ignore query)) + (list + (if (and (consp id) + (eq (car id) :query-identifier) + (consp (cdr id)) + (stringp (second id))) + (second id) + id) + (and (not (eq condition t)) condition)))) + query-info)) + :title "Invalid Fields" + :style :error : + exit-boxes '(:exit))) + +(defmethod display-invalid-queries ((frame accept-values-own-window) stream queries) + (display-invalid-queries (frame-calling-frame frame) stream queries)) + +#+ignore +(defmethod (setf accept-values-query-error-p query) :around (value (query accept-values-query)) + (let ((old-value (accept-values-query-error-p query))) + (call-next-method) + (unless (eq value old-value) + (note-query-validity-changed query value)))) + +#+ignore +(defmethod note-query-validity-changed (query errorp) + (let ((gadget (find-query-gadget query))) + (when (and gadget (typep gadget '(or text-field text-editor))) + (if errorp + (setf (gadget-original-background gadget) (gadget-background gadget) + (gadget-background gadget) +red+) + (setf (gadget-background gadget) (gadget-original-background gadget)))))) + +;; Focus-in callback/ value changed - establish normal +;; Focus-out callback - establish error condition +;; Need to save away contents, cursor position, colors. +;; What about the case when we are changing it back to ok cos some one +;; has changed the value? +;; Perhaps the old value come from present-to-string the query value. (define-accept-values-command (com-abort-avv :keystroke :abort-dialog) () (abort)) @@ -926,33 +1006,34 @@ (define-presentation-type accept-values-command-button ()) -(defmacro accept-values-command-button ((&optional stream &rest options) prompt - &body body &environment env) +(defmacro accept-values-command-button ((&optional stream &rest options &key (view nil viewp) &allow-other-keys) prompt + &body body &environment env) #+Genera (declare (zwei:indentation 1 3 2 1)) #-(or Genera Minima) (declare (ignore env)) (declare (arglist ((&optional stream - &key documentation query-identifier - (cache-value t) (cache-test #'eql) - view resynchronize) + &key documentation query-identifier + (cache-value t) (cache-test #'eql) + view resynchronize) prompt &body body))) (default-input-stream stream accept-values-command-button) - (let ((constant-prompt-p - (and (constantp prompt #+(or Genera Minima) env) - (stringp (eval prompt #+(or Genera Minima-Developer) env))))) - `(flet ((avv-command-button-body () ,@body) - ,@(unless constant-prompt-p - `((avv-command-button-prompt (,stream) ,prompt)))) - ,@(unless constant-prompt-p - `((declare (dynamic-extent #'avv-command-button-prompt)))) - (invoke-accept-values-command-button - ,stream - #'avv-command-button-body ,(getf options :view `(stream-default-view ,stream)) - ,(if constant-prompt-p - (eval prompt #+(or Genera Minima-Developer) env) - '#'avv-command-button-prompt) - ,@options)))) - -(defmethod invoke-accept-values-command-button + (with-keywords-removed (options options '(:view)) + (let ((constant-prompt-p + (and (constantp prompt #+(or Genera Minima) env) + (stringp (eval prompt #+(or Genera Minima-Developer) env))))) + `(flet ((avv-command-button-body () ,@body) + ,@(unless constant-prompt-p + `((avv-command-button-prompt (,stream) ,prompt)))) + ,@(unless constant-prompt-p + `((declare (dynamic-extent #'avv-command-button-prompt)))) + (invoke-accept-values-command-button + ,stream + #'avv-command-button-body ,(if viewp view `(stream-default-view ,stream)) + ,(if constant-prompt-p + (eval prompt #+(or Genera Minima-Developer) env) + '#'avv-command-button-prompt) + ,@options))))) + +(defmethod invoke-accept-values-command-button-1 (stream continuation (view t) prompt &key (documentation (if (stringp prompt) prompt @@ -960,8 +1041,10 @@ (funcall prompt stream)))) (query-identifier (list ':button documentation)) (cache-value t) (cache-test #'eql) - resynchronize) - (declare (dynamic-extent prompt)) + resynchronize + active-p) + (declare (dynamic-extent prompt) + (ignore active-p)) (updating-output (stream :unique-id query-identifier :id-test #'equal :cache-value cache-value :cache-test cache-test) (with-output-as-presentation (stream @@ -1301,8 +1384,8 @@ :cache-value 'exit-boxes) (formatting-table (stream :equalize-column-widths nil) (dolist (exit-box exit-boxes) - (with-exit-box-decoded (value label text-style) exit-box labels - (when label + (with-exit-box-decoded (value label text-style documentation) exit-box labels + (when label (when text-style (setq text-style `(:text-style ,text-style))) (formatting-column (stream) @@ -1310,6 +1393,7 @@ (with-output-as-gadget (stream) (apply #'make-pane 'push-button :label label + :help-callback documentation :client frame :id value :activate-callback #'handle-exit-box-callback text-style)))))))))))) @@ -1357,8 +1441,42 @@ `(,#'accept-values-value-changed-callback ,stream ,query)) ;; This is how we associate an output-record with the button -(defmethod invoke-accept-values-command-button - (stream continuation (view gadget-dialog-view) prompt + +(defun invoke-accept-values-command-button (stream continuation view prompt + &rest options + &key (documentation (if (stringp prompt) + prompt + ;;-- What is the right thing to do? + (ignore-errors + (with-output-to-string (stream) + (funcall prompt stream))))) + (query-identifier (list ':button documentation)) + &allow-other-keys) + (typecase view + (null) + (symbol (setq view (make-instance view))) + (cons (setq view (apply #'make-instance view)))) + (apply #'invoke-accept-values-command-button-1 + stream + continuation + (decode-indirect-view + 'accept-values-command-button + view + (frame-manager stream) + :query-identifier query-identifier) + prompt + :documentation documentation + :query-identifier query-identifier + options)) + +(define-presentation-method decode-indirect-view + ((type accept-values-command-button) (view gadget-dialog-view) + (framem standard-frame-manager) &key read-only) + (declare (ignore read-only)) + +push-button-view+) + +(defmethod invoke-accept-values-command-button-1 + (stream continuation (view push-button-view) prompt &key (documentation (if (stringp prompt) prompt ;;-- What is the right thing to do? @@ -1367,44 +1485,59 @@ (funcall prompt stream))))) (query-identifier (list ':button documentation)) (cache-value t) (cache-test #'eql) - resynchronize) + resynchronize + (active-p t)) (declare (dynamic-extent prompt)) + (move-cursor-to-view-position stream view) (updating-output (stream :unique-id query-identifier :id-test #'equal - :cache-value cache-value :cache-test cache-test) - (flet ((doit (stream) - (with-output-as-gadget (stream) - (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) - (client (make-instance 'accept-values-command-button - :continuation continuation - :documentation documentation - :resynchronize resynchronize))) - (make-pane 'push-button - :id record :client client - :activate-callback - #'(lambda (button) - (when (accept-values-query-valid-p nil record) ;---can't be right - (let ((sheet (sheet-parent button))) - (process-command-event - sheet - (allocate-event 'presentation-event - :sheet sheet - :echo nil - :presentation-type 'command - :value `(com-avv-command-button ,client ,record) - :frame *application-frame*))))) - - :label (if (stringp prompt) - prompt - ;;-- Does this suck or what??? - ;;-- If you do a - ;;surrounding-output-with-border without - ;;this write-string output does not get bordered. - (let ((*original-stream* nil)) - (pixmap-from-menu-item stream - prompt - #'funcall - nil)))))))) - (let ((align-prompts (slot-value stream 'align-prompts)) query) + :cache-value (cons active-p cache-value) + :cache-test #'(lambda (x y) + (and (eq (car x) (car y)) + (funcall cache-test (cdr x) (cdr y))))) + (labels ((update-gadget (record gadget) + (declare (ignore record)) ;;-- This sucks + (setf (gadget-label gadget) (compute-prompt)) + (if active-p + (activate-gadget gadget) + (deactivate-gadget gadget))) + (compute-prompt () + (if (stringp prompt) + prompt + ;;-- Does this suck or what??? + ;;-- If you do a + ;;surrounding-output-with-border without + ;;this write-string output does not get bordered. + (let ((*original-stream* nil)) + (pixmap-from-menu-item stream + prompt + #'funcall + nil)))) + (doit (stream) + (with-output-as-gadget (stream :update-gadget #'update-gadget) + (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) + (client (make-instance 'accept-values-command-button + :continuation continuation + :documentation documentation + :resynchronize resynchronize))) + (make-pane-from-view + 'push-button + view + :id record :client client + :activate-callback #'(lambda (button) + (when (accept-values-query-valid-p nil record) ;---can't be right + (let ((sheet (sheet-parent button))) + (process-command-event + sheet + (allocate-event 'presentation-event + :sheet sheet + :echo nil + :presentation-type 'command + :value `(com-avv-command-button ,client ,record) + :frame *application-frame*))))) + :label (compute-prompt) + :help-callback documentation + :active active-p))))) + (let ((align-prompts (slot-value stream 'align-prompts))) (if align-prompts (formatting-row (stream) (formatting-cell (stream) stream) @@ -1412,3 +1545,7 @@ (doit stream)))))) + + + + diff --git a/clim/activities.lisp b/clim/activities.lisp index 5b56eea69194811f39619be6789f4c7efface055..c934c5c0615abfbb44395e3baef44e2ef073e4d8 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.11 93/03/19 09:43:12 cer Exp $ +;; $fiHeader: activities.lisp,v 1.12 1993/05/05 01:38:17 cer Exp $ (in-package :clim-internals) @@ -21,7 +21,8 @@ (input-buffer :initform (make-locking-queue) :accessor frame-input-buffer) (auto-select :initform nil :initarg :auto-select :accessor activity-auto-select) (frame-manager :initform nil :initarg :frame-manager - :accessor frame-manager))) + :accessor frame-manager) + (actual-pointer-documentation-pane :initform nil :accessor frame-actual-pointer-documentation-pane))) (defmethod initialize-instance :after ((activity activity) &key pretty-name) (setf (frame-pretty-name activity) @@ -29,6 +30,7 @@ (unless (frame-manager activity) (setf (frame-manager activity) (find-frame-manager)))) + (defmethod frame-name ((activity activity)) (type-of activity)) @@ -147,6 +149,15 @@ (defclass activity-frame (standard-application-frame) ((activity :initform nil :accessor frame-activity :initarg :activity))) +(defmethod frame-actual-pointer-documentation-pane ((frame activity-frame)) + (let ((act (frame-activity frame))) + (and act (frame-actual-pointer-documentation-pane act)))) + +(defmethod (setf frame-actual-pointer-documentation-pane) (value (frame activity-frame)) + (let ((act (frame-activity frame))) + (when act (setf (frame-actual-pointer-documentation-pane act) value))) + value) + (defmethod frame-top-level-process ((frame activity-frame)) (let ((act (frame-activity frame))) (and act (slot-value act 'top-level-process)))) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 638a841c4273af96961f465a8dbc1688034da7b2..3a1a1b4c5d9ae3c19eebe679cc23cc03827bb079 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.51 93/05/13 16:23:01 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.52 1993/05/13 16:28:41 colin Exp $ (in-package :clim-internals) @@ -347,79 +347,65 @@ (defclass command-menu-pane (clim-stream-pane) ()) -(defmethod compose-space :before ((pane command-menu-pane) &key width height) - (declare (ignore width height)) - ;;------ !!!!!!!!!!!!!!!!!!!!!! - ;; - #+ignore - (window-clear pane)) - - -;; This is a macro because it counts on being expanded inside of a call -;; to WITH-LOOK-AND-FEEL-REALIZATION -(defmacro make-clim-stream-pane (&rest options - &key (type ''clim-stream-pane) - label - (label-alignment #+Genera :bottom #-Genera :top) - (scroll-bars ':vertical) - (borders t) - (display-after-commands nil dac-p) - (background nil background-p) - name - &allow-other-keys) - (setq options (remove-keywords options '(:type :scroll-bars :borders - :label :background - :label-alignment :display-after-commands))) - (let* ((stream '#:clim-stream) - (display-time - (and dac-p - `(:display-time ,(cond ((eq display-after-commands t) :command-loop) - ((eq display-after-commands :no-clear) :no-clear) - (t nil))))) - (background-var (and background (gensym))) - (pane - `(setq ,stream (make-pane ,type - ,@display-time - ,@(and background-p `(:background ,background-var)) - ,@options)))) - (when scroll-bars - (setq pane `(scrolling - (:scroll-bars ,scroll-bars - :name ,name - ,@(and background-p `(:background ,background-var))) - ,pane))) - (when label - (let ((label (if (stringp label) - `(make-pane 'label-pane - :label ,label - :max-width +fill+ - ,@(and background-p `(:background ,background-var))) - `(make-pane 'label-pane - :label ,(first label) - :max-width +fill+ ,@(rest label) - ,@(and background-p `(:background ,background-var)))))) - (ecase label-alignment - (:bottom - (setq pane `(vertically - (,@(and background-p `(:background ,background-var))) - ,pane - ,label))) - (:top - (setq pane `(vertically - (,@(and background-p `(:background ,background-var))) - ,label - ,pane)))))) - (when borders - (setq pane `(outlining - (:thickness 1 - :name ,name - ,@(and background-p `(:background ,background-var))) - (spacing (:thickness 1 - ,@(and background-p `(:background ,background-var))) - ,pane)))) - `(let ((,stream) - ,@(and background-p `((,background-var ,background)))) - (values ,pane ,stream)))) +(defun make-clim-stream-pane-1 (framem frame + &rest options + &key (type 'clim-stream-pane) + label + (label-alignment #+Genera :bottom #-Genera :top) + (scroll-bars ':vertical) + (borders t) + (display-after-commands nil dac-p) + (background nil background-p) + name + &allow-other-keys) + (with-look-and-feel-realization (framem frame) + (setq options (remove-keywords options '(:type :scroll-bars :borders + :label :background + :label-alignment :display-after-commands))) + (when dac-p + (setf (getf options :display-time) + (cond ((eq display-after-commands t) :command-loop) + ((eq display-after-commands :no-clear) :no-clear) + (t nil)))) + + (let* ((stream (apply #'make-pane type options)) + (pane stream)) + + (when scroll-bars + (setq pane (apply #'make-pane 'scroller-pane + :contents pane + :name name + (and background-p `(:background ,background))))) + + (when label + (let ((label (if (stringp label) + (apply #'make-pane 'label-pane + :label label + :max-width +fill+ + (and background-p `(:background ,background))) + (apply #'make-pane 'label-pane + :label (first label) + :max-width +fill+ + (append (rest label) + (and background-p `(:background ,background))))))) + (setq pane (apply #'make-pane 'vbox-pane + :contents + (ecase label-alignment + (:bottom (list pane label)) + (:top (list label pane))) + (and background-p `(:background ,background)))))) + (when borders + (setq pane + (apply #'make-pane 'outlined-pane + :name name + :thickness 1 + :contents (apply #'make-pane 'spacing-pane + :name name + :thickness 1 + :contents pane + (and background-p `(:background ,background))) + (and background-p `(:background ,background))))) + (values pane stream)))) (defmacro make-clim-interactor-pane (&rest options) `(make-clim-stream-pane :type 'interactor-pane ,@options)) @@ -680,54 +666,3 @@ (values (floor (- right left) char-width) (floor (- bottom top) line-height))))) - -;;; This is too useful to simply omit -(defun open-window-stream (&key left top right bottom width height - (foreground +black+) (background +white+) - text-style default-text-style - (vertical-spacing 2) - (end-of-line-action :allow) - (end-of-page-action :allow) - output-record (draw t) (record t) - (initial-cursor-visibility :off) - text-margin default-text-margin - save-under input-buffer - (scroll-bars :vertical) borders label) - (declare (ignore borders input-buffer)) - (when (or width height) - (assert (and (null right) (null bottom)))) - (when (null left) (setq left 0)) - (when (null top) (setq top 0)) - (when (or (null width) (null height)) - (if (or (null right) (null bottom)) - (setq width 100 - height 100) - (setq width (- right left) - height (- bottom top)))) - (let* ((stream - ;;-- This should call frame-manager-get-menu to get - ;;-- the right kind of menu-frame - (frame-manager-get-menu (find-frame-manager) - ;;-- what about :save-under - :label label - :scroll-bars scroll-bars)) - (port (port stream))) - (setf (medium-foreground stream) foreground - (medium-background stream) background - (medium-default-text-style stream) (or default-text-style *default-text-style*) - (medium-text-style stream) (or text-style *default-text-style*) - (stream-vertical-spacing stream) vertical-spacing - (stream-end-of-line-action stream) end-of-line-action - (stream-end-of-page-action stream) end-of-page-action - (stream-recording-p stream) record - (stream-drawing-p stream) draw - (cursor-visibility (stream-text-cursor stream)) initial-cursor-visibility - (stream-text-margin stream) text-margin - (stream-default-text-margin stream) default-text-margin) - (when output-record - (stream-output-history stream) (make-instance output-record)) - (window-set-inside-size stream width height) - (window-set-viewport-position stream 0 0) - (position-sheet-carefully - (frame-top-level-sheet (pane-frame stream)) width height) - stream)) diff --git a/clim/frames.lisp b/clim/frames.lisp index f6b52a557daf33830c526d80bf73459c9cd5c4fe..0f5569dba8fe8c9ef476cd283729380ab421c5d3 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.66 1993/05/05 01:38:23 cer Exp $ +;; $fiHeader: frames.lisp,v 1.67 1993/05/13 16:23:04 cer Exp $ (in-package :clim-internals) @@ -55,7 +55,8 @@ (top-level-process :initform nil :reader frame-top-level-process) (command-queue :initform (make-locking-queue) :reader frame-command-queue) (input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer) - (pane-to-avv-stream-table :initform nil :accessor frame-pane-to-avv-stream-table)) + (pane-to-avv-stream-table :initform nil :accessor frame-pane-to-avv-stream-table) + (actual-pointer-documentation-pane :initform nil :accessor frame-actual-pointer-documentation-pane)) (:default-initargs :pointer-documentation nil :layouts nil :resize-frame nil @@ -886,61 +887,62 @@ (defmethod default-frame-top-level ((frame standard-application-frame) &key command-parser command-unparser - partial-command-parser - (prompt "Command: ")) + partial-command-parser + (prompt "Command: ")) ;; Enable the frame now (unless (eq (frame-state frame) :enabled) (enable-frame frame)) (loop (let* ((*standard-output* - (or (frame-standard-output frame) *standard-output*)) + (or (frame-standard-output frame) *standard-output*)) (*standard-input* - (or (frame-standard-input frame) *standard-output*)) + (or (frame-standard-input frame) *standard-output*)) (*query-io* - (or (frame-query-io frame) *standard-input*)) + (or (frame-query-io frame) *standard-input*)) (*error-output* - (or (frame-error-output frame) *standard-output*)) + (or (frame-error-output frame) *standard-output*)) (*pointer-documentation-output* - (frame-pointer-documentation-output frame)) + (frame-pointer-documentation-output frame)) (interactor - (not (null (find-frame-pane-of-type frame 'interactor-pane)))) + (not (null (find-frame-pane-of-type frame 'interactor-pane)))) (*command-parser* - (or command-parser - (if interactor - #'command-line-command-parser - #'menu-command-parser))) + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-command-parser))) (*command-unparser* - (or command-unparser - #'command-line-command-unparser)) + (or command-unparser + #'command-line-command-unparser)) (*partial-command-parser* - (or partial-command-parser - (if interactor - #'command-line-read-remaining-arguments-for-partial-command - #'menu-read-remaining-arguments-for-partial-command))) + (or partial-command-parser + (if interactor + #'command-line-read-remaining-arguments-for-partial-command + #'menu-read-remaining-arguments-for-partial-command))) (command-stream - ;;--- We have to ask the frame since we do not want to - ;;--- just pick up a stream from the dynamic environment - (let ((si (or (frame-standard-input frame) - (frame-standard-output frame)))) - (typecase si - (output-protocol-mixin si) - (t (frame-top-level-sheet frame)))))) + ;;--- We have to ask the frame since we do not want to + ;;--- just pick up a stream from the dynamic environment + (let ((si (or (frame-standard-input frame) + (frame-standard-output frame)))) + (typecase si + (output-protocol-mixin si) + (t (frame-top-level-sheet frame)))))) ;; The read-eval-print loop for applications... - (loop - ;; Redisplay all the panes - (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) - (redisplay-frame-panes frame) - (when interactor - (fresh-line *standard-input*) - (if (stringp prompt) - (write-string prompt *standard-input*) - (funcall prompt *standard-input* frame))) - (let ((command (read-frame-command frame :stream command-stream))) + (letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*)) + (loop + ;; Redisplay all the panes + (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) + (redisplay-frame-panes frame) (when interactor - (terpri *standard-input*)) - ;; Need this check in case the user aborted out of a command menu - (when command - (execute-frame-command frame command)))))))) + (fresh-line *standard-input*) + (if (stringp prompt) + (write-string prompt *standard-input*) + (funcall prompt *standard-input* frame))) + (let ((command (read-frame-command frame :stream command-stream))) + (when interactor + (terpri *standard-input*)) + ;; Need this check in case the user aborted out of a command menu + (when command + (execute-frame-command frame command))))))))) ;; Generic because someone might want :BEFORE or :AFTER (defmethod frame-exit ((frame standard-application-frame)) @@ -1207,10 +1209,15 @@ (defmethod execute-frame-command ((frame standard-application-frame) command) (apply (command-name command) (command-arguments command))) +(defmethod command-defined-p ((frame standard-application-frame) command) + (or (not (symbolp command)) + (fboundp command))) + (defmethod command-enabled (command-name (frame standard-application-frame)) (with-slots (disabled-commands) frame (or *assume-all-commands-enabled* - (and (not (member command-name disabled-commands)) + (and (command-defined-p frame command-name) + (not (member command-name disabled-commands)) (command-accessible-in-command-table-p command-name (frame-command-table frame)))))) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index b69d40feff12970ef66f1b1f824e1dcdceb5852b..c9c491b53cd139b01561bbc6e3b65e344d87a28c 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.49 93/05/13 16:23:07 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.50 1993/05/13 16:28:50 colin Exp $ (in-package :clim-internals) @@ -356,7 +356,8 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier) - :active active-p))))) + :active active-p + :help-callback (make-gadget-help type)))))) (values (if radio-box-label (outlining () (vertically () @@ -445,7 +446,8 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier) - :active active-p))))) + :active active-p + :help-callback (make-gadget-help type)))))) (values (if check-box-label (outlining () (vertically () @@ -489,7 +491,8 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier) - :active active-p))) + :active active-p + :help-callback (make-gadget-help type)))) (values (outlining () button) button))))) @@ -547,7 +550,8 @@ (make-accept-values-value-changed-callback stream query-identifier)) :active active-p - :editable-p editable-p))) + :editable-p editable-p + :help-callback (make-gadget-help type)))) (values (outlining () slider) slider)))))) (define-presentation-method accept-present-default @@ -599,7 +603,8 @@ (make-accept-values-value-changed-callback stream query-identifier)) :active active-p - :editable-p editable-p))) + :editable-p editable-p + :help-callback (make-gadget-help type)))) (values (outlining () slider) slider)))))) @@ -663,7 +668,8 @@ (and editable-p `(accept-values-string-field-changed-callback ,stream ,query-identifier)) - :active active-p))) + :active active-p + :help-callback (make-gadget-help type)))) (values text-field text-field))))) (defmethod accept-values-note-text-field-changed-callback @@ -687,8 +693,12 @@ ;; correctly (see tk-silica/ol-gadgets) (assert (= index (length new-value))) object) - (error () - (setf (accept-values-query-error-p query) t)) + (error (c) + (setf (accept-values-query-error-p query) c) + (let ((frame (pane-frame stream))) + (unless (typep *application-frame* 'accept-values) + (verify-queries-1 frame stream (list query)) + (setf (accept-values-query-changed-p query) nil)))) (:no-error (object) (setf (accept-values-query-error-p query) nil) (do-avv-command object stream query)))))) @@ -734,7 +744,8 @@ (make-accept-values-value-changed-callback stream query-identifier)) :active active-p - :editable-p editable-p))) + :editable-p editable-p + :help-callback (make-gadget-help type)))) (values (scrolling () text-field) text-field))))) @@ -786,7 +797,8 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier) - :active active-p) + :active active-p + :help-callback (make-gadget-help type)) (make-pane-from-view pane-type view :items sequence :name-key name-key @@ -799,7 +811,8 @@ :value-changed-callback (make-accept-values-value-changed-callback stream query-identifier) - :active active-p)))) + :active active-p + :help-callback (make-gadget-help type))))) (values (if (eq pane-type 'list-pane) (scrolling () pane) pane) pane))))) @@ -842,3 +855,8 @@ (defmethod sheet-disown-child ((stream standard-encapsulating-stream) child) (sheet-disown-child (encapsulating-stream-stream stream) child)) + +;; + +(defun make-gadget-help (ptype) + `(make-help-from-presentation-type ,ptype)) diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index a525ff4667a4063c5947608a95588751005be0fc..43427a1c72186b58da08d969e7b55997e9470e32 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -1,6 +1,6 @@ M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-defs.lisp,v 1.17 93/03/19 09:43:36 cer Exp $ +;; $fiHeader: input-defs.lisp,v 1.18 1993/05/05 01:38:30 cer Exp $ (in-package :clim-internals) @@ -80,7 +80,7 @@ M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (defun sheets-nearest-common-ancestor (sheet1 sheet2) (if (eq sheet1 sheet2) sheet1 - (do ((sheet sheet1 (sheet-parent sheet1))) + (do ((sheet sheet1 (sheet-parent sheet))) ((null sheet)) (when (sheet-ancestor-p sheet2 sheet) (return sheet))))) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index de0ae8c9c72e54c0afa732b78b015c8474929236..8b727509019c6595bd4c741cdcc4bc08861acf0b 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-protocol.lisp,v 1.26 93/05/13 16:23:19 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.27 1993/05/13 16:29:07 colin Exp $ (in-package :clim-internals) @@ -1025,7 +1025,7 @@ (declare (ignore framem frame)) ;;-- Yuck but think of a better way (let ((old-help *accept-help*)) - (if (typep (encapsulating-stream-stream stream) 'accept-values-pane) + (if (typep (encapsulating-stream-stream stream) '(or accept-values-pane accept-values-stream)) (accepting-values (stream :exit-boxes '(:exit) :label "Input editor help" :own-window t) diff --git a/clim/menus.lisp b/clim/menus.lisp index 1f526375fec25e90c0158180c629bac076ec5042..96dd751267a7606cbf9cf342f188234e735e1ac5 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.43 93/04/16 09:44:55 cer Exp $ +;; $fiHeader: menus.lisp,v 1.44 1993/05/05 01:38:44 cer Exp $ (in-package :clim-internals) @@ -619,3 +619,86 @@ (return-from menu-choose (values (menu-item-value item) item gesture))))))))) + + +;;; This is too useful to simply omit + +(define-application-frame open-window-stream-frame () + ((type :initarg :type) + (scroll-bars :initarg :scroll-bars) + (borders :initarg :borders) + stream + pane) + (:command-definer nil) + (:menu-bar nil) + (:pane + (with-slots (pane stream type scroll-bars borders) *application-frame* + (multiple-value-setq (pane stream) + (make-clim-stream-pane + :type type + :scroll-bars scroll-bars + :borders borders)) + pane))) + +(defun open-window-stream (&key (left nil leftp) + (top nil topp) + (right nil rightp) + (bottom nil bottomp) + width height + (foreground +black+) (background +white+) + text-style default-text-style + (vertical-spacing 2) + (end-of-line-action :allow) + (end-of-page-action :allow) + output-record (draw t) (record t) + (initial-cursor-visibility :off) + text-margin default-text-margin + save-under input-buffer + (scroll-bars :vertical) borders label + (type 'application-pane) + parent) + (declare (ignore save-under)) + (when (or width height) + (assert (and (null right) (null bottom)))) + (when (null left) (setq left 0)) + (when (null top) (setq top 0)) + (when (or (null width) (null height)) + (if (or (null right) (null bottom)) + (setq width 100 + height 100) + (setq width (- right left) + height (- bottom top)))) + (let* ((frame (make-application-frame 'open-window-stream-frame + :resize-frame t + :pretty-name label + :type type + :scroll-bars scroll-bars + :borders borders + :input-buffer input-buffer + :frame-manager + (etypecase parent + ((or pane standard-application-frame) + (frame-manager parent)) + (frame-manager parent) + (null (find-frame-manager))))) + (stream (slot-value frame 'stream))) + (setf (medium-foreground stream) foreground + (medium-background stream) background + (medium-default-text-style stream) (or default-text-style *default-text-style*) + (medium-text-style stream) (or text-style *default-text-style*) + (stream-vertical-spacing stream) vertical-spacing + (stream-end-of-line-action stream) end-of-line-action + (stream-end-of-page-action stream) end-of-page-action + (stream-recording-p stream) record + (stream-drawing-p stream) draw + (cursor-visibility (stream-text-cursor stream)) initial-cursor-visibility + (stream-text-margin stream) text-margin + (stream-default-text-margin stream) default-text-margin) + (when output-record + (stream-output-history stream) (make-instance output-record)) + (window-set-inside-size stream width height) + (window-set-viewport-position stream 0 0) + (when (or leftp topp rightp bottomp) + (position-sheet-carefully + (frame-top-level-sheet (pane-frame stream)) left top)) + stream)) diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index ab59840293b2a1ecb0b5c20da78a95d23ab0f971..2c09c54ac0e34d25dd55aa504f46cfae1d2dddd7 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.32 93/04/07 09:06:50 cer Exp $ +;; $fiHeader: recording-protocol.lisp,v 1.33 1993/05/05 01:38:56 cer Exp $ (in-package :clim-internals) @@ -1150,25 +1150,44 @@ (replay text-output-record stream region))))))) (defmethod erase-output-record (record (stream output-recording-mixin) &optional (errorp t)) - (let ((parent (output-record-parent record))) - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates stream parent) - (with-bounding-rectangle* (left top right bottom) record - (with-output-recording-options (stream :record nil) - (if (or (= left right) (= top bottom)) - ;; Handle specially, since a thin line is wider than a - ;; rectangle of zero width or height - (draw-line-internal stream xoff yoff - left top right bottom - +background-ink+ nil) - (draw-rectangle-internal stream xoff yoff - left top right bottom - +background-ink+ nil))))) - (when parent - (delete-output-record record parent errorp)) - ;; Use the output record itself as the replay region, and replay - ;; the stuff that might have been obscured by the erased output - (frame-replay *application-frame* stream record))) + (macrolet ((draw-it () + `(if (or (= left right) (= top bottom)) + ;; Handle specially, since a thin line is wider than a + ;; rectangle of zero width or height + (draw-line-internal stream xoff yoff + left top right bottom + +background-ink+ nil) + (draw-rectangle-internal stream xoff yoff + left top right bottom + +background-ink+ nil)))) + (if (listp record) + (let ((replay-region +nowhere+)) + (with-output-recording-options (stream :record nil) + (dolist (record record) + (let ((parent (output-record-parent record))) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates stream parent) + (with-bounding-rectangle* (left top right bottom) record + (draw-it) + (when parent + (delete-output-record record parent errorp)) + (translate-coordinates xoff yoff left top right bottom) + (setq replay-region + (region-union + replay-region + (make-bounding-rectangle left top right bottom)))))))) + (frame-replay *application-frame* stream replay-region)) + (let ((parent (output-record-parent record))) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates stream parent) + (with-bounding-rectangle* (left top right bottom) record + (with-output-recording-options (stream :record nil) + (draw-it)))) + (when parent + (delete-output-record record parent errorp)) + ;; Use the output record itself as the replay region, and replay + ;; the stuff that might have been obscured by the erased output + (frame-replay *application-frame* stream record))))) (defmethod invoke-with-output-recording-options ((stream output-recording-mixin) continuation record draw) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 3bfb6df8552a790e28a70adcf814333c59f4a562..9c0e2fbebbb18db04d83ceb525277fcc4466d433 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.27 93/03/19 09:43:48 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.28 1993/05/13 16:23:22 cer Exp $ (in-package :clim-internals) @@ -614,7 +614,7 @@ (let ((position 0) (last (1- (length sequence)))) (map nil #'(lambda (item) - (write-string (funcall name-key item) stream) + (funcall printer (funcall name-key item) stream) (unless (= position last) (write-string (if (= last 1) " " ", ") stream) (when (= (incf position) last) diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index 0bf65ea1993a7f6e9c03b19eaca29d490aac21ed..4dc14cea2970387d2aad449112b4ead63ae8be0e 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.11 92/09/24 09:39:33 cer Exp Locker: cer $ +;; $fiHeader: view-defs.lisp,v 1.12 92/10/28 08:19:42 cer Exp $ (in-package :clim-internals) @@ -64,6 +64,8 @@ (define-gadget-view toggle-button) +(define-gadget-view push-button) + (define-gadget-view radio-box) (define-gadget-view check-box) diff --git a/demo/cload-demos.lisp b/demo/cload-demos.lisp index edb23ca30594cf2de488709c5f6286a436af5894..a86487e6967b67c9b21f6da7c68dd647bc5fe073 100644 --- a/demo/cload-demos.lisp +++ b/demo/cload-demos.lisp @@ -20,9 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: cload-demos.lisp,v 1.4 92/10/07 14:43:20 cer Exp Locker: cer $ +;; $fiHeader: cload-demos.lisp,v 1.5 92/10/12 17:54:30 cer Exp $ -(in-package :user) +(in-package :clim-user) (defvar *demo-files* '( diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp index 6aa5e9a2ed613b53802813f0ac48cebfccf1e0ba..5c93659a80533a92be09ceebcd898e2b2242104a 100644 --- a/demo/graphics-editor.lisp +++ b/demo/graphics-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-editor.lisp,v 1.18 93/04/27 14:35:44 cer Exp $ +;; $fiHeader: graphics-editor.lisp,v 1.19 93/04/27 15:49:36 cer Exp $ (in-package :clim-graphics-editor) @@ -262,7 +262,7 @@ graphics-editor-edit-commands graphics-editor-option-commands) :inherit-menu :keystrokes - :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F) + :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F :documentation "File commands") ("Edit" :menu graphics-editor-edit-commands :mnemonic #\E ) ("Options" :menu graphics-editor-option-commands :mnemonic #\O)))) (:pointer-documentation t) @@ -305,10 +305,15 @@ ;;; Presentation types -(define-presentation-type-abbreviation line-thickness () - '((member 1 2 3 4) :name-key identity - :printer present-line-thickness - :highlighter highlight-line-thickness)) +(define-presentation-type line-thickness () + :inherit-from `((completion (1 2 3 4)) + :name-key identity + :printer present-line-thickness + :highlighter highlight-line-thickness)) + +(define-presentation-method describe-presentation-type ((type line-thickness) stream plural-count) + (declare (ignore plural-count)) + (write-string "Specify one of four line thicknesses" stream)) (defun present-line-thickness (object stream &key acceptably) (declare (ignore acceptably)) @@ -323,10 +328,15 @@ (surrounding-output-with-border (stream) (funcall continuation object stream))) -(define-presentation-type-abbreviation line-style-type () - '((member :solid :dashed) :name-key identity - :printer present-line-style - :highlighter highlight-line-style)) +(define-presentation-type line-style-type () + :inherit-from `((completion (:solid :dashed)) + :name-key identity + :printer present-line-style + :highlighter highlight-line-style)) + +(define-presentation-method describe-presentation-type ((type line-style-type) stream plural-count) + (declare (ignore plural-count)) + (write-string "Specify solid or dashed line style" stream)) (defun present-line-style (object stream &key acceptably) (declare (ignore acceptably)) @@ -347,6 +357,16 @@ :printer present-object-shape :highlighter highlight-object-shape)) +(define-presentation-type object-shape () + :inherit-from `((completion (:oval :rectangle)) + :name-key identity + :printer present-object-shape + :highlighter highlight-object-shape)) + +(define-presentation-method describe-presentation-type ((type object-shape) stream plural-count) + (declare (ignore plural-count)) + (write-string "Specify rectangle or oval shape" stream)) + (defun present-object-shape (object stream &key acceptably) (declare (ignore acceptably)) (let ((y (stream-line-height stream))) @@ -505,7 +525,9 @@ ;; Deselect an object by clicking the Deselect menu button, or by ;; clicking over blank area without moving the mouse. (define-command (com-deselect-object :command-table graphics-editor-edit-commands - :menu "Deselect") () + :menu ("Deselect" + :documentation "Deselect all objects")) + () (when (frame-selected-object *application-frame*) (deselect-object *application-frame* (frame-selected-object *application-frame*)))) @@ -565,7 +587,10 @@ (move-handle handle (- x dx) (- y dy)))))) ;; OK, I added a menu button to clear the window. -(define-command (com-clear :command-table graphics-editor-edit-commands :menu t) nil +(define-command (com-clear :command-table + graphics-editor-edit-commands + :menu ("Clear" :documentation "Clear all graphics")) + () (with-slots (objects selected-object last-box) *application-frame* (setq objects nil selected-object nil @@ -575,15 +600,21 @@ ;; OK, I added a menu button to redisplay the window, too, although ;; it's only here for debugging. (define-command (com-redisplay :command-table graphics-editor-edit-commands - :keystroke (:r :meta) :menu t) () + :keystroke (:r :meta) + :menu ("Redisplay" :documentation "Redisplay windows")) + () (redisplay-frame-pane *application-frame* 'display :force-p t)) (define-command (com-quit :command-table graphics-editor-file-commands - :keystroke (:x :meta) :menu t) () + :keystroke (:x :meta) + :menu ("Quit" :documentation "Quit application")) () (frame-exit *application-frame*)) (define-command (com-change-layout :command-table graphics-editor-option-commands - :keystroke (:l :meta) :menu t) () + :keystroke (:l :meta) + :menu ("Change application layout" + :documentation "Change layout")) + () (let ((layouts (frame-all-layouts *application-frame*))) (setf (frame-current-layout *application-frame*) (or (second (member (frame-current-layout *application-frame*) layouts)) diff --git a/misc/climgccursor.c b/misc/climgccursor.c index 479feaf12b73e78d6971e924e3d0d6bdeb11cce2..0e6e2095d36e587db7fce5e0ec113cfa5be6307f 100644 --- a/misc/climgccursor.c +++ b/misc/climgccursor.c @@ -1,7 +1,6 @@ #include <X11/Intrinsic.h> #include <X11/StringDefs.h> #include <signal.h> -#include <stdio.h> static Widget gc_widget = (Widget)NULL; @@ -26,8 +25,6 @@ int cursor; if (XFindContext(display, root, context, &font_cursor)) { font_cursor = XCreateFontCursor(display, cursor); - fprintf(stderr, "Making cursor\n"); - fflush(stderr); XSaveContext(display, root, context, font_cursor); } return (font_cursor); @@ -73,8 +70,6 @@ Widget client_data; int *call_data; { if (gc_widget == client_data) { - fprintf(stderr, "Removing gc cursor\n"); - fflush(stderr); gc_widget = 0; } } diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index a0bdfabb0e318b0cb67c839e1c3dddf60acda660..ff5c7d703669f1a96ec4b64fdd81e451f8d67674 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.21 93/04/02 13:36:29 cer Exp $ +;; $fiHeader: compile-1.lisp,v 1.22 93/04/23 09:18:00 cer Exp $ (in-package :user) @@ -71,6 +71,8 @@ (compile-file-if-needed "test/test-suite") + (load "test/test-suite") + (load "demo/sysdcl") (clim-defsys::compile-system 'clim-demo :propagate t) (clim-defsys::load-system 'clim-demo) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index d3b2d21fee045868600899daba6e0a77cf996e87..8fb1be95b9ef67d2320b207d8a32d4f95c3fb30d 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.26 93/04/23 09:18:01 cer Exp $ +;; $fiHeader: dev-load-1.lisp,v 1.27 1993/05/05 01:39:30 cer Exp $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -70,7 +70,12 @@ (clim-defsys::load-system 'clim-demo) - (ignore-errors (tenuring (require :composer))) + (ignore-errors + (tenuring + (let ((*default-pathname-defaults* #P"/hyper/qa/4.2.beta2.0/solaris1/lib/code/")) + (require :composer) + (set (intern '#:*clm-binary-directory* :xtk) + #P"/hyper/qa/4.2.beta2.0/solaris1/lib/")))) (dolist (file '("test/test-driver" "test/test-clim" @@ -86,7 +91,11 @@ (clim-defsys::fake-load-system (cons sys '(postscript-clim clim-toys clim-demo)) :recurse t) - + +; (warn "Loading patch file") +; (load "/net/vapor/usr/tech/cer/patches/clos-precache.fasl" +; :if-does-not-exist nil) + (ignore-errors (load (case sys (motif-clim "misc/clos-preloadxm.fasl") diff --git a/misc/undefinedsymbols.motif b/misc/undefinedsymbols.motif index 67d0199b0e85253a6ea8d2c091e97bb2d21083ef..84f3324916ea3ed59e057fc9e9d6a42c5ae645b3 100644 --- a/misc/undefinedsymbols.motif +++ b/misc/undefinedsymbols.motif @@ -8,7 +8,7 @@ XmFontListGetNextFont XmFontListCreate XmAddProtocolCallback XmInternAtom -XmIsTraverable +XmIsTraversable XmMainWindowSetAreas XmProcessTraversal XmMessageBoxGetChild diff --git a/misc/undefinedsymbols.xt b/misc/undefinedsymbols.xt index b65c48f7dc0cec59ad6bd97d8a3145d897562546..a02db064593c76f4be6b4b1baf41a37789ec0154 100644 --- a/misc/undefinedsymbols.xt +++ b/misc/undefinedsymbols.xt @@ -38,3 +38,5 @@ XtUngrabPointer XtUnmanageChild XtUnmanageChildren XtWindow +XtParseTranslationTable +XtParseAcceleratorTable diff --git a/notes/profiles/.cvsignore b/notes/profiles/.cvsignore new file mode 100755 index 0000000000000000000000000000000000000000..7dd20dfb51bd2caa80470d6c580621a59a21eedc --- /dev/null +++ b/notes/profiles/.cvsignore @@ -0,0 +1 @@ +*.*-profile.lisp diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index b7f8e2ab277c0aba15b169465d1e2a103ccfe237..132d5563e08a5aed5b43aed64da6fb7a3013be99 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.43 93/03/19 09:44:39 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.44 1993/05/05 01:39:41 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -97,12 +97,12 @@ (update-scroll-bar vertical-scroll-bar top bottom vtop vbottom - (line-scroll-amount scroller :vertical nil))) + :vertical)) (when horizontal-scroll-bar (update-scroll-bar horizontal-scroll-bar left right vleft vright - (line-scroll-amount scroller :horizontal nil))))))))) + :horizontal)))))))) (defmethod note-sheet-grafted :before ((sheet scroll-bar)) (setf (scroll-bar-current-size sheet) nil)) @@ -110,7 +110,7 @@ ;;--- In the case where the viewport is bigger than the window this ;;--- code gets things wrong. Check out the thinkadot demo. It's ;;--- because (- (--) (- vmin)) is negative. -(defun update-scroll-bar (scroll-bar min max vmin vmax line-scroll) +(defun update-scroll-bar (scroll-bar min max vmin vmax orientation) (declare (optimize (safety 0) (speed 3))) ;;-- Is this really the right thing to do? ;;-- If in an interactor some draws at -ve coordinates but the @@ -137,28 +137,19 @@ (the single-float (if (= max min) 1.0 - (min 1.0 (the single-float - (/ viewport-range contents-range)))))))) + (min 1.0 (the single-float + (/ viewport-range contents-range)))))))) ;;-- This does not scale by the range (pos (the single-float (min 1.0s0 (max 0.0s0 (if (<= contents-range viewport-range) 0.0 - (/ (float (- vmin min) 0.0s0) - ;;--- Uh-oh, the home-grown scroll bars - ;;--- seem to have a different contract - ;;--- from Motif/OpenLook. Fix them! - #+Allegro (- contents-range viewport-range) - #-Allegro contents-range)))))) - (line-scroll #+ignore - (* range (/ line-scroll viewport-range)) - (if (zerop contents-range) - 0 ;-- Who knows - (* range (/ line-scroll contents-range))) - #+ignore - (if (< contents-range viewport-range) - 0 ;-- Who knows - (* range (/ line-scroll (- contents-range viewport-range)))))) + (/ (float (- vmin min) 0.0s0) + ;;--- Uh-oh, the home-grown scroll bars + ;;--- seem to have a different contract + ;;--- from Motif/OpenLook. Fix them! + #+Allegro (- contents-range viewport-range) + #-Allegro contents-range))))))) (declare (type single-float pos size)) (unless (and current-size current-value @@ -166,10 +157,15 @@ (= current-value pos)) (setf (scroll-bar-current-value scroll-bar) pos) (setf (scroll-bar-current-size scroll-bar) size) - (change-scroll-bar-values scroll-bar - :slider-size size - :value pos - :line-increment line-scroll)))))) + ;;-- It would be nice if we could do this at the point of scrolling + (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client) orientation nil)) + (line-scroll (if (zerop contents-range) + 0 ;-- Who knows + (* range (/ line-scroll contents-range))))) + (change-scroll-bar-values scroll-bar + :slider-size size + :value pos + :line-increment line-scroll))))))) (defmethod scroll-bar-value-changed-callback (sheet (client scroller-pane) id value size) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 39703116e3da8317881cc8d20c5cf7552edeb2db..93f37da5f3ca39367d0ab3bbac306d16fee94a80 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.51 1993/05/05 01:39:49 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.52 1993/05/13 16:24:04 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -17,7 +17,10 @@ :reader gadget-armed-callback) (disarmed-callback :initarg :disarmed-callback :initform nil :reader gadget-disarmed-callback) - (active :initarg :active :accessor gadget-active-p)) + (active :initarg :active :accessor gadget-active-p) + (help-callback :initform nil + :initarg :help-callback + :accessor gadget-help-callback)) (:default-initargs :active t)) ;;; Arming and disarming @@ -733,3 +736,9 @@ (defmethod handle-event ((gadget focus-gadget) (event focus-in-gadget-event)) (focus-in-callback gadget (gadget-client gadget) (gadget-id gadget))) + +(defun move-focus-to-gadget (gadget) + (port-move-focus-to-gadget (port gadget) gadget)) + +(defmethod port-move-focus-to-gadget ((port t) (gadget t)) + nil) diff --git a/silica/macros.lisp b/silica/macros.lisp index ec32d09229a013300067fba7f1a7c76e49ad01ba..3d79bceb5282289401bfcd16f8b3b273111863ab 100644 --- a/silica/macros.lisp +++ b/silica/macros.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: macros.lisp,v 1.13 92/08/18 17:23:48 cer Exp $ +;; $fiHeader: macros.lisp,v 1.14 92/09/24 09:37:45 cer Exp $ (in-package :silica) @@ -43,10 +43,13 @@ (setq frame `*application-frame*)) `(flet ((make-pane (pane-class &rest pane-options) (declare (dynamic-extent pane-options)) - (apply #'make-pane-1 - ,frame-manager ,frame pane-class pane-options))) - (declare (dynamic-extent #'make-pane)) - #'make-pane ;prevent spurious compiler warnings + (apply #'make-pane-1 ,frame-manager ,frame pane-class pane-options)) + (make-clim-stream-pane (&rest pane-options) + (declare (dynamic-extent pane-options)) + (apply #'clim-internals::make-clim-stream-pane-1 ,frame-manager ,frame pane-options))) + (declare (dynamic-extent #'make-pane #'make-clim-stream-pane)) + #'make-pane ;prevent spurious compiler warnings + #'make-clim-stream-pane ,@forms)) #+Genera (zwei:defindentation (make-pane 1 1)) @@ -55,3 +58,7 @@ (warn "~S not inside a call to ~S" 'make-pane 'with-look-and-feel-realization)) +(defun make-clim-stream-pane (&rest pane-options) + (declare (ignore pane-options)) + (warn "~S not inside a call to ~S" + 'make-clim-stream-pane 'with-look-and-feel-realization)) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 902fc3cb90639721b55aafd0f745e8a3bfca2bb1..93173631f57a98d42b76c992254cede71e389681 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sheet.lisp,v 1.35 93/02/08 15:57:40 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.36 93/03/18 14:38:23 colin Exp $ (in-package :silica) @@ -498,3 +498,4 @@ ((port basic-port) (sheet basic-sheet) cursor) (declare (ignore cursor)) nil) + diff --git a/test/test-clim.lisp b/test/test-clim.lisp index afd9037ed52cf51f27415e7e57cfa36bf760ae39..a150ed4d0f32711be56de008178fbaf88308cad5 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.5 1993/05/05 01:40:05 cer Exp $ +;; $fiHeader: test-clim.lisp,v 1.6 1993/05/13 16:24:16 cer Exp $ (in-package :clim-user) @@ -57,7 +57,7 @@ (define-command-sequence clim-tests-commands (com-draw-some-bezier-curves) - (:commands do-avv-test) + (:commands do-avv-test) (com-input-editor-tests) "This is (sexp) and a string" :ie-backward-character @@ -97,18 +97,20 @@ (:presentation-click display-pane integer) (:presentation-click display-pane integer) :abort - - (com-read-image-test) + ) + + +(define-frame-test more-clim-tests (clim-tests + :width 600 :height 600) + ((com-read-image-test) (com-filled-output) + (:presentation-click display-pane string) ;; This would be nice but moving to the top right of the ;; presentation does not work when they are circular! ;; (com-ordering-test-1) ;; (:presentation-click display-pane integer) - - - (:presentation-click display-pane string) (com-ordering-test-2a) (:presentation-click display-pane integer) @@ -196,6 +198,9 @@ (com-rotated-scaled-rectangles) (com-draw-some-rectangles)) + (exit-clim-tests) + ) + (define-frame-test test-drag-and-drop (clim-tests :width 600 :height 600 :history-class r-tree-output-history @@ -508,15 +513,70 @@ (push 'find-frame-manager-test *frame-tests*) (defun find-frame-manager-test () - (handler-case (let ((fm (find-frame-manager))) - (with-frame-manager (fm) - (let ((*default-server-path* - `(,(if (excl::featurep :clim-motif) - :motif :openlook) - :display "mysparc10:0"))) - (assert (eq fm (find-frame-manager)))))) - (error (c) - (note-test-failed 'find-frame-manager-test c)) - (:no-error (&rest ignore) - (declare (ignore ignore)) - (note-test-succeeded 'find-frame-manager-test)))) + (with-test-success-expected ('find-frame-manager-test) + (let ((fm (find-frame-manager))) + (with-frame-manager (fm) + (let ((*default-server-path* + `(,(if (excl::featurep :clim-motif) + :motif :openlook) + :display "mysparc10:0"))) + (assert (eq fm (find-frame-manager)))))))) + +;; + +(push 'open-window-stream-test *frame-tests*) + +;; Stewart introduced bugs here...................... + +(defun open-window-stream-test () + (with-test-success-expected ('open-window-stream-test) + (let* (stream1 stream2 stream3) + (setq stream1 (open-window-stream :label "Fred" :scroll-bars :vertical)) + (window-expose stream1) + (setq stream2 (open-window-stream :label "Joh" :scroll-bars :vertical :parent stream1)) + (window-expose stream2) + (setq stream3 (open-window-stream :label "Joh" :scroll-bars :vertical :left 500 :top 500)) + (window-expose stream3) + (sleep 10) + (setf (window-visibility stream1) nil + (window-visibility stream2) nil + (window-visibility stream3) nil)))) + + +;; + +(push 'multiple-value-setf-test *frame-tests*) + +(defun multiple-value-setf-test () + (with-test-success-expected ('multiple-value-setf-test) + (let ((x (make-bounding-rectangle 0 0 10 10))) + (setf (bounding-rectangle* x) + (values 12 12 13 14))))) + +(push 'filling-output-on-plain-stream-test *frame-tests*) + +(defun filling-output-on-plain-stream-test () + (with-test-success-expected ('filling-output-on-plain-stream-test) + (filling-output (*standard-output* :fill-width '(20 :character)) + (write-string *gettysburg-address* *standard-output*)))) + + + +(macrolet ((define-profile-clim-tests () + `(define-frame-test profile-clim-tests (clim-tests :width 600 :height 600) + ,(mapcan #'(lambda (benchmark-group) + (mapcar #'list (cdr benchmark-group))) + *summary-contributions*) + (exit-clim-tests)))) + (define-profile-clim-tests)) + +(push 'run-profile-clim-tests *frame-tests*) + +(defun run-profile-clim-tests () + (let ((prof::*hidden-packages* nil) + (prof::*significance-threshold* 0.001) + (prof::*fractional-significance-threshold* .002)) + (with-test-success-expected ('run-profile-clim-tests-time) + (do-frame-test-with-profiling 'profile-clim-tests :type :time)) + (with-test-success-expected ('run-profile-clim-tests-space) + (do-frame-test-with-profiling 'profile-clim-tests :type :space)))) diff --git a/test/test-driver.lisp b/test/test-driver.lisp index 56a74013ff3b7a9c41157956bbabfa879089e24f..73ae6ee666ecf3382c490868a0ff04649a8d85db 100644 --- a/test/test-driver.lisp +++ b/test/test-driver.lisp @@ -122,13 +122,19 @@ #'(lambda () (setq done (not (mp::process-stack-group process))))) done)) +(defvar *execute-one-command-hook* nil) (defun execute-commands-in-invocation (invocation commands) (do ((commands commands (cdr commands))) ((or (not (invocation-active-p invocation)) (null commands))) - (execute-one-command invocation (car commands)) - (wait-for-clim-input-state invocation))) + (let ((command (car commands))) + (flet ((do-it () + (execute-one-command invocation command) + (wait-for-clim-input-state invocation))) + (if *execute-one-command-hook* + (funcall *execute-one-command-hook* invocation command #'do-it) + (do-it)))))) (defvar *command-sequence-table* (make-hash-table)) @@ -190,6 +196,17 @@ (wait-for-clim-input-state invocation timeout))) (execute-command-in-frame (or avv-frame (invocation-frame invocation)) command))))))))) +(defmacro with-test-success-expected ((test-name) &body body) + (let ((tname (gensym))) + `(let ((,tname ,test-name)) + (handler-case (progn ,@body) + (error (c) + (note-test-failed ,tname c)) + (:no-error (&rest ignore) + (declare (ignore ignore)) + (note-test-succeeded ,tname)))))) + + (defun exercise-frame (test-name class initargs commands exit-command &key (error *catch-errors-in-tests*) (invocation-class 'frame-invocation)) @@ -205,12 +222,8 @@ (warn "Process would not die when killed")) (destroy-invocation invocation))))) (if error - (handler-case (doit) - (error (condition) - (note-test-failed test-name condition)) - (:no-error (&rest ignore) - (declare (ignore ignore)) - (note-test-succeeded test-name))) + (with-test-success-expected (test-name) + (doit)) (doit)))) @@ -665,6 +678,27 @@ ;; How can we wait for a frame to be created. Grab hold of it and then ;; run some commands on it. +(eval-when (compile load eval) + (require :prof)) + +(defun do-frame-test-with-profiling (test &key (type :time)) + (flet ((profiling-hook (invocation command continuation) + ;;-- it would be nice to restrict it to the invocation process + (if (or (atom command) + (equal command '(exit-clim-tests))) + (funcall continuation) + (progn + (unwind-protect + (progn + (prof::start-profiler :type type :verbose nil) + (funcall continuation)) + (profiler:stop-profiler)) + (with-open-file (*standard-output* (format nil "notes/profiles/~A.~A-profile.lisp" (car command) type) + :direction :output :if-exists :supersede) + (prof:show-call-graph) + (prof:show-flat-profile)))))) + (let ((*execute-one-command-hook* #'profiling-hook)) + (funcall test)))) ;;; This should be at the end: ;;; make the training selective. @@ -677,3 +711,4 @@ ;; This stops warnings happening asynchronously and causing confusion. (setq excl:*global-gc-behavior* nil) + diff --git a/test/test-suite.lisp b/test/test-suite.lisp index d6c15b39e5cee296dc77b30d86211c1970ee9966..b1feb3924ca2cdcc2e0ce8c42daeefa2260fa37e 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.63 93/05/13 16:24:24 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.63 1993/05/13 16:24:24 cer Exp $ (in-package :clim-user) @@ -776,7 +776,7 @@ people, shall not perish from the earth. (define-test (read-image-test graphics) (stream) "Test image reading code" (formatting-table (stream) - (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus")) + (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus" "calculator")) (formatting-row (stream) (formatting-cell (stream) (write-string name stream)) @@ -1050,6 +1050,20 @@ people, shall not perish from the earth. (sleep 2) (window-refresh stream))) +(define-test (multiple-erases output-recording) (stream) + "The four overlapping circles and a line and erase three of them" + (flet ((circle (x y r n) + (with-output-as-presentation (stream n 'integer) + (draw-circle* stream x y r :ink (make-contrasting-inks 4 n))))) + (circle 100 50 40 1) + (let ((records (list + (circle 75 100 40 2) + (circle 125 100 40 3) + (circle 200 200 40 3)))) + (draw-line* stream 100 50 200 200 :ink +white+) + (sleep 2) + (erase-output-record records stream)))) + ;;; Formatted output @@ -1796,8 +1810,10 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-test (simple-menu menus-and-dialogs) (stream) "A simple test of MENU-CHOOSE." (write-string - (menu-choose '("Whistle" - ("Pat head" :items + (menu-choose '(("Whistle" :documentation "Select whistle") + ("Pat head" + :documentation "Pat head in various ways" + :items (("with right hand" . "Pat head with right hand") ("with left hand" . "Pat head with left hand"))) ("Rub Tummy" :items @@ -2074,6 +2090,16 @@ Luke Luck licks the lakes Luke's duck likes.")) (g (integer 0 10) :view '(slider-view :orientation :vertical))) (terpri stream))))) +(define-test (list-pane-dialog menus-and-dialogs) (stream) + "Various list panes" + (let ((x :a-one)) + (accepting-values (stream) + (setf x (accept '(member :a-one :b-two :c-three :d-four) + :stream stream + :view +list-pane-view+ + :default x + :prompt "Value for X"))))) + (define-test (readonly-gadget-dialog menus-and-dialogs) (stream) "Create a bunch of readonly gadgets" (accepting-values (stream :own-window nil :label "Gadgets dialog" diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp index cea90d8d396be37fb11d6bb67c5d1c738a906d22..300f903cd328bd60e215fc065a4694f6fd7ade24 100644 --- a/tk-silica/ol-frames.lisp +++ b/tk-silica/ol-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-frames.lisp,v 1.23 93/04/08 13:18:52 colin Exp $ +;; $fiHeader: ol-frames.lisp,v 1.24 1993/05/13 16:31:25 colin Exp $ (in-package :xm-silica) @@ -77,7 +77,8 @@ :managed nil)) (menu (tk::get-values menu-shell :menu-pane)) (font (and text-style (text-style-mapping (port framem) text-style))) - (font-args (and font (list :font font)))) + (font-args (and font (list :font font))) + (frame (pane-frame associated-window))) (let ((title (cond ((null label) "Choose") ((atom label) label) @@ -121,13 +122,9 @@ button #'tk::destroy-image image) button)))) - #+dunno - (when (clim-internals::menu-item-documentation item) - (tk::add-callback button - :help-callback - 'display-motif-help - port - (clim-internals::menu-item-documentation item))) + (add-documentation-callbacks + frame button + (clim-internals::menu-item-documentation item)) button)) (construct-menu-from-items (menu items) (map nil #'(lambda (item) @@ -181,6 +178,8 @@ (setf value-returned nil return-value nil) (values value-returned return-value)))))) + + (defmethod framem-enable-menu ((framem openlook-frame-manager) menu) (tk::ol_menu_post menu)) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 6a413ac616413db7b7c7cde1cfa4d670c3f7b926..417d5d711f9d2e7a1d5e04180a6c439a7951a2c1 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.49 93/05/13 16:24:53 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.50 1993/05/13 16:31:32 colin Exp $ (in-package :xm-silica) @@ -325,8 +325,9 @@ ;; submenus then it creates one with a menu of its own (let* ((mirror (call-next-method)) - (text-style (pane-text-style sheet)) - (font-list (list :font (text-style-mapping port text-style)))) + (text-style (pane-text-style sheet)) + (font-list (list :font (text-style-mapping port text-style))) + (frame (pane-frame sheet))) (labels ((compute-options (item) (let ((text-style (getf (command-menu-item-options item) :text-style))) (if text-style @@ -373,21 +374,6 @@ (mapc #'tk::destroy-widget children) (make-command-for-command-table-1 mb item))))) - ;;--- This does not get called. - #+ignore - (xt::add-callback - shell :popup-callback - #'(lambda (shell) - (declare (ignore shell)) - (let ((children - (tk::widget-children menu-pane))) - (when (or (null children) - (/= tick - (setq tick - (slot-value ct 'clim-internals::menu-tick)))) - (mapc #'tk::destroy-widget children) - (make-command-for-command-table-1 mb item))))) - (tk::remove-all-callbacks shell :popup-callback) (tk::add-callback shell :popup-callback #'update-menu-item-sensitivity @@ -417,11 +403,15 @@ ) (:menu (make-command-for-command-table-1 - (apply #'make-instance 'tk::menu-button - :parent parent - :label menu - (compute-options item)) - item)) + (let ((button + (apply #'make-instance 'tk::menu-button + :parent parent + :label menu + (compute-options item)))) + (add-documentation-callbacks + frame button (getf (command-menu-item-options item) :documentation)) + button) + item)) (t (let ((button @@ -434,6 +424,10 @@ (slot-value sheet 'silica::frame)) (compute-options item)))) + (add-documentation-callbacks + frame button + (getf (command-menu-item-options item) :documentation)) + (when top (push (cons (car (command-menu-item-value item)) button) (menu-bar-command-name-to-button-table sheet))) @@ -1488,11 +1482,11 @@ + ;;; (defclass openlook-list-pane (list-pane xt-leaf-pane) - ((item-list :accessor list-pane-item-list) - (token-list :accessor list-pane-token-list) + ((token-list :accessor list-pane-token-list) (current-tokens :initform nil :accessor list-pane-current-tokens))) @@ -1502,8 +1496,10 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-list-pane)) - (with-accessors () sheet - (values 'xt::ol-list nil))) + (with-accessors ((visible-items gadget-visible-items) + (items set-gadget-items)) sheet + (values 'xt::ol-list + `(:view-height ,(max 1 (or visible-items (length items))))))) (defmethod realize-mirror :around ((port openlook-port) (sheet openlook-list-pane)) (let ((widget (call-next-method))) @@ -1512,7 +1508,7 @@ (defun add-items-to-list-pane-widget (sheet widget) - (let ((item-list nil) + (let ( (token-list nil) selected-tokens (count 0) @@ -1541,11 +1537,9 @@ 0 x))) (push (list token count) token-list) - (when selected-p (push token selected-tokens)) - (push x item-list)) + (when selected-p (push token selected-tokens))) (incf count))) - (setf (list-pane-item-list sheet) (nreverse item-list) - (list-pane-token-list sheet) token-list + (setf (list-pane-token-list sheet) token-list (list-pane-current-tokens sheet) selected-tokens)))) (defmethod (setf gadget-value) :after (new-value (gadget openlook-list-pane) &key invoke-callback) @@ -1562,11 +1556,11 @@ (setf (tk::ol-list-item-attr toolkit-item) (dpb (if selectedp 1 0) '#.tk::ol_b_list_attr_current - (dpb position '#.tk::ol_b_list_attr_appl 0))) + (dpb position '#.tk::ol_b_list_attr_appl (tk::ol-list-item-attr toolkit-item)))) (touch-list-pane-item widget token) - (when selectedp (push token-and-position selected-tokens)) - (setf (list-pane-current-tokens gadget) - selected-tokens))))))) + (when selectedp (push token selected-tokens))))) + (setf (list-pane-current-tokens gadget) + selected-tokens)))) (defmethod (setf set-gadget-items) :after (items (gadget openlook-list-pane)) (declare (ignore items)) @@ -1656,22 +1650,30 @@ (vertical-margins (ceiling (* 2 4 (/ 90 72)))) (horizontal-margins (ceiling (* (+ 6 8) (/ 90 72)))) (vertical-spacing (ceiling (* 6 (/ 90 72)))) - (fudge 5) ; This seems to be necessary to make + (fudge 6) ; This seems to be necessary to make ; the right number of items visible - (item-max-length + (item-max-width (let ((max 0)) (dolist (item items max) - (maxf max (length (funcall name-key item)))))) + (maxf max (let ((string (funcall name-key item))) + (x11:xtextwidth + font string (length string))))))) (height (+ (* (or visible-items (length items)) (+ vertical-spacing (tk::font-height font))) vertical-margins fudge)) - (width (+ horizontal-margins - (* (tk::font-width font) - item-max-length) + (width (+ -5 + horizontal-margins + item-max-width scroll-bar-width))) (make-space-requirement :width width :height height)))))) +(defmethod change-widget-geometry :after (parent (child tk::ol-list) &key width) + (declare (ignore parent)) + (tk::set-values (tk::get-values child :list-pane) + :pref-max-width width + :pref-min-width width)) + ;;; (defclass openlook-option-pane (option-pane xt-leaf-pane) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index a9b286e31eb203fec6074c002b70f15297549569..e53c5cf6475784c854fd4e495dbecc670f228d69 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.55 93/04/23 09:18:45 cer Exp $ +;; $fiHeader: xm-frames.lisp,v 1.56 93/04/27 14:36:09 cer Exp $ (in-package :xm-silica) @@ -125,7 +125,8 @@ (text-style (pane-text-style sheet)) (font-list (list :font-list (text-style-mapping port text-style))) (ct (menu-bar-command-table sheet)) - (flatp (flat-command-table-menu-p ct))) + (flatp (flat-command-table-menu-p ct)) + (frame (pane-frame sheet))) (labels ((compute-options (item) (let ((text-style (getf (command-menu-item-options item) :text-style))) (if text-style @@ -149,7 +150,7 @@ (tk::remove-all-callbacks parent :map-callback) (tk::add-callback parent :map-callback #'update-menu-item-sensitivity - (pane-frame sheet) + frame commands-and-buttons)))) (make-submenu (parent menu item) (let* ((shell (make-instance 'xt::xm-menu-shell @@ -167,14 +168,19 @@ :managed nil :parent shell :row-column-type :menu-pulldown)) - (cb (apply #'make-instance 'xt::xm-cascade-button-gadget + (cb (apply #'make-instance 'xt::xm-cascade-button :parent parent :label-string menu :sub-menu-id submenu (compute-options item)))) (unless flatp (set-button-mnemonic sheet - cb (getf (command-menu-item-options item) :mnemonic))) + cb (getf + (command-menu-item-options + item) :mnemonic))) + + (add-documentation-callbacks + frame cb (getf (command-menu-item-options item) :documentation)) (let* ((ct (find-command-table (second item))) (tick (slot-value ct 'clim-internals::menu-tick))) @@ -244,6 +250,9 @@ (push (list item button) commands-and-buttons) + (add-documentation-callbacks + frame button (getf (command-menu-item-options item) :documentation)) + (when flatp (push (cons (car (command-menu-item-value item)) button) @@ -256,16 +265,9 @@ (set-button-mnemonic sheet - button (getf (command-menu-item-options item) :mnemonic))) - - (when (getf (command-menu-item-options item) :documentation) - (tk::add-callback - button - :help-callback - 'display-motif-help - port - (getf (command-menu-item-options - item) :documentation))) + button (getf + (command-menu-item-options + item) :mnemonic))) (tk::add-callback button @@ -281,10 +283,11 @@ ct mirror (not flatp))) mirror)) -(defun display-motif-help (widget port documentation) +(defun display-motif-help (widget framem documentation) (frame-manager-notify-user - (find-frame-manager :port port) ;--- frame manager should be passed in + framem documentation + ;;-- Gross :associated-window widget)) @@ -335,7 +338,8 @@ 1)) :managed nil)) (font (and text-style (text-style-mapping port text-style))) - (font-list (and (or label simplep) font (list :font-list (list font))))) + (font-list (and (or label simplep) font (list :font-list (list font)))) + (frame (pane-frame associated-window))) (when label (let ((title (if (atom label) label (car label)))) (check-type title string) @@ -383,13 +387,10 @@ (xt::add-widget-cleanup-function button #'tk::destroy-pixmap pixmap) - button)))) - (when (clim-internals::menu-item-documentation item) - (tk::add-callback button - :help-callback - 'display-motif-help - port - (clim-internals::menu-item-documentation item))) + button)))) + (add-documentation-callbacks + frame button + (clim-internals::menu-item-documentation item)) button)) (construct-menu-from-items (menu items) (map nil #'(lambda (item) @@ -446,6 +447,8 @@ (setf value-returned nil return-value nil) (values value-returned return-value)))))) + + (defmethod frame-manager-allows-menu-caching ((framem motif-frame-manager)) ;; Deal with the problem of motif installing passive grabs nil) @@ -555,3 +558,22 @@ ;; menu frames, such as implemented "click off menu to abort". (setf (getf (frame-properties frame) :menu-frame) t) (values (slot-value frame 'clim-internals::menu) frame))) + +(defmethod add-documentation-callbacks (frame (button tk::xm-push-button) documentation) + (when documentation + (tk::add-callback + button :arm-callback + 'pointer-documentation-callback-function + frame documentation t) + (tk::add-callback + button :disarm-callback + 'pointer-documentation-callback-function + frame documentation nil))) + +(defmethod add-documentation-callbacks :after (frame (button t) documentation) + (when documentation + (tk::add-callback button + :help-callback + 'display-motif-help + (frame-manager frame) + documentation))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 93442e5ec654ae49a1ccefe3043f04502428f4f1..31f8dbcf5cb7f6dd0380f89eabec19f72bd326d3 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.74 93/05/13 16:25:00 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.74 1993/05/13 16:25:00 cer Exp $ (in-package :xm-silica) @@ -1747,3 +1747,47 @@ :accelerator-text accel-text)))) + +;; Support for help + +(defmethod add-sheet-callbacks :after + ((port motif-port) (sheet gadget) (widget xt::xm-primitive)) + (add-help-callback sheet widget)) + +(defmethod add-sheet-callbacks :after + ((port motif-port) (sheet gadget) (widget xt::xm-manager)) + (add-help-callback sheet widget)) + +(defun add-help-callback (sheet widget) + (when (silica::gadget-help-callback sheet) + (tk::add-callback widget + :help-callback + 'help-callback-function + sheet))) + +(defun help-callback-function (widget sheet) + (declare (ignore widget)) + (distribute-event + (port sheet) + (allocate-event 'gadget-help-event + :gadget sheet))) + +(defclass gadget-help-event (gadget-event) + ()) + +(defmethod handle-event ((sheet basic-gadget) (event gadget-help-event)) + (let ((help (silica::gadget-help-callback sheet))) + (etypecase help + (string (display-motif-help sheet (frame-manager sheet) help)) + (cons (apply (car help) sheet (cdr help)))))) + + +(defun clim-internals::make-help-from-presentation-type (stream presentation-type) + ;;-- We have to do it this way because describe methods might invoke + ;;-- presentations etc etc + (accepting-values (stream :exit-boxes '(:exit) + :label "Help" + :own-window t) + (describe-presentation-type presentation-type stream))) + + diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 1a693b20e796e327721bdae3679c048138402683..1c923180106b360fa5cb85f7dc20828c96e31f3c 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.35 93/04/16 09:46:02 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.36 1993/05/13 16:32:02 colin Exp $ (in-package :xm-silica) @@ -179,4 +179,10 @@ (defun xm-get-focus-widget (widget) (tk::intern-widget (tk::xm_get_focus_widget widget))) +(defmethod port-move-focus-to-gadget ((port xm-silica::motif-port) gadget) + ;;-- If this is composite then it should find the first child + ;;-- that can take the focus + (let ((m (sheet-direct-mirror gadget))) + (when m (tk::xm_process_traversal m 0)))) + diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 9f03397f0f06e42c7986b4a903683df4f46f142a..a672a23f996562513293764c339171bb048649df 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.33 93/04/16 09:46:04 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.34 93/04/23 09:18:48 cer Exp $ (in-package :xm-silica) @@ -190,8 +190,8 @@ (defmethod frame-manager-exit-box-labels ((framem xt-frame-manager) frame view) (declare (ignore frame view)) - '((:exit "Ok") - (:abort "Cancel"))) + '((:exit "OK" :documentation "Exit from dialog") + (:abort "Cancel" :documentation "Cancel dialog"))) (defmethod frame-manager-default-exit-boxes ((framem xt-frame-manager)) '((:exit) (:abort))) @@ -291,3 +291,17 @@ (destructuring-bind (&key name &allow-other-keys) (clim-internals::frame-icon frame) ;;-- Dialog shells do not have :icon-name resource (tk::set-values shell :icon-name (or name (frame-pretty-name frame))))))) + +(defmethod add-documentation-callbacks (frame button documentation) + (declare (ignore frame button documentation))) + +(defun pointer-documentation-callback-function (widget frame documentation showp) + (declare (ignore widget)) + (let ((pointer-documentation-pane + (clim-internals::frame-actual-pointer-documentation-pane frame))) + (when pointer-documentation-pane + (frame-manager-display-pointer-documentation-string + (frame-manager frame) + frame + pointer-documentation-pane + (and showp documentation))))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index b7bf730966840c02666bf7d015eed4e53d118ea5..e3f556d271678ac28de445ff4d85357a84c37847 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.72 93/05/13 16:25:03 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.73 1993/05/13 16:32:11 colin Exp $ (in-package :tk-silica) @@ -1748,3 +1748,6 @@ (defmethod medium-finish-output ((medium xt-medium)) (x11:xsync (port-display (port medium)) 0)) + +(defmacro with-medium-state-cached ((medium) &body body) + `(prog ,medium ,@body)) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index f2e87b0a82466bd59245383069dbb09a34b6804f..1bda4f901cf7986c42aade0e50f3866e221babf7 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.82 93/05/13 16:25:07 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.83 1993/05/13 16:32:28 colin Exp $ (in-package :xm-silica) @@ -1696,9 +1696,6 @@ the geometry of the children. Instead the parent has control. ")) (tk::destroy-pixmap pixmap) (when mask (tk::destroy-pixmap mask)))))))) - - - (defvar *pointer-grabbed* nil) diff --git a/tk/event.lisp b/tk/event.lisp index 7862ff0669358c78c0b1a78ec42a258974896d2a..86150c423f72806eaa23a1c948c806548da6d0cc 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.16 93/02/08 15:57:53 cer Exp $ +;; $fiHeader: event.lisp,v 1.17 1993/05/13 16:24:34 cer Exp $ (in-package :tk) @@ -85,6 +85,12 @@ (defun process-one-event (context mask reason) (cond ((plusp mask) + #+debug + (when (logtest mask *xt-im-xevent*) + (let ((event (x11:make-xevent))) + (unless (zerop (xt_app_peek_event context event)) + (when (eq (event-type event) :key-press) + (break))))) (xt_app_process_event context ;; Because of a feature in the OLIT toolkit we need to diff --git a/tk/ol-widgets.lisp b/tk/ol-widgets.lisp index bad4b69840bdd4a42799643c308979e217cea7a9..672ce71c247268861c5e94c25419582b0b1974d4 100644 --- a/tk/ol-widgets.lisp +++ b/tk/ol-widgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-widgets.lisp,v 1.2 92/06/23 08:19:15 cer Exp $ +;; $fiHeader: ol-widgets.lisp,v 1.3 92/07/27 19:29:14 cer Exp $ (in-package :xt) @@ -74,4 +74,20 @@ :name :appl-delete-item :type 'function :original-name - (string-to-char* "applDeleteItem"))) + (string-to-char* + "applDeleteItem"))) + +(tk::add-resource-to-class (find-class 'ol-list) + (make-instance 'resource + :name :view-height + :type 'dimension + :original-name + (string-to-char* + "viewHeight"))) + +(tk::add-resource-to-class (find-class 'ol-list) + (make-instance 'resource + :name :recompute-width + :type 'boolean + :original-name + (string-to-char* "recomputeWidth"))) diff --git a/tk/resources.lisp b/tk/resources.lisp index b2cc0b67cfbd6b279e06aaff5bc27f274cdf4e8c..0476784ca2eb14e6ca36bf243fb789c04d80b100 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,8 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.45 93/05/13 16:24:38 cer Exp $ +;; $fiHeader: resources.lisp,v 1.45 1993/05/13 16:24:38 cer Exp $ + (in-package :tk) @@ -105,156 +106,157 @@ ;; from OpenLook.h (defparameter *ol-defines* '( - (:ignore -1) - (:absent-pair 0) - (:all 1) - (:always 2) - (:atom-help 3) - (:both 4) - (:bottom 5) - (:buttonstack 6) - (:center 7) - (:class-help 8) - (:columns 9) - (:copy-mask-value 10) - (:copy-size 11) - (:copy-source-value 12) - (:current 13) - (:default-pair 14) - (:disk-source 15) - (:display-form 16) - (:down 17) - (:existing-source 18) - (:fixedcols 19) - (:fixedheight 20) - (:fixedrows 21) - (:fixedwidth 22) - (:flat-button 23) - (:flat-checkbox 24) - (:flat-container 25) - (:flat-exclusives 26) - (:flat-help 27) - (:flat-nonexclusives 28) - (:halfstack 29) - (:horizontal 30) - (:image 31) - (:in 32) - (:indirect-source 33) - (:label 34) - (:left 35) - (:mask-pair 36) - (:maximize 37) - (:millimeters 38) - (:minimize 39) - (:never 40) - (:next 41) - (:none 42) - (:nonebottom 43) - (:noneleft 44) - (:noneright 45) - (:nonetop 46) - (:notices 47) - (:no-virtual-mapping 48) - (:oblong 49) - (:out 50) - (:override-pair 51) - (:pixels 52) - (:points 53) - (:popup 54) - (:previous 55) - (:prog-defined-source 56) - (:rectbutton 57) - (:right 58) - (:rows 59) - (:source-form 60) - (:source-pair 61) - (:stayup 62) - (:string 63) - (:string-source 64) - (:text-append 65) - (:text-edit 66) - (:text-read 67) - (:top 68) - (:transparent-source 69) - (:vertical 70) - (:virtual-button 71) - (:virtual-key 72) - (:widget-help 73) - (:window-help 74) - (:wrap-any 75) - (:wrap-white-space 76) - (:continuous 77) - (:granularity 78) - (:release 79) - (:tickmark 80) - (:percent 81) - (:slidervalue 82) - (:wt-base 83) - (:wt-cmd 84) - (:wt-notice 85) - (:wt-help 86) - (:wt-other 87) - (:success 88) - (:duplicate-key 89) - (:duplicatekey 89) - (:bad-key 90) - (:menu-full 91) - (:menu-limited 92) - (:menu-cancel 93) - (:selectkey 94) - (:menukey 95) - (:menudefault 96) - (:menudefaultkey 97) - (:hsbmenu 98) - (:vsbmenu 99) - (:adjustkey 100) - (:nextapp 101) - (:nextwindow 102) - (:prevapp 103) - (:prevwindow 104) - (:windowmenu 105) - (:workspacemenu 106) - (:defaultaction 108) - (:drag 109) - (:drop 110) - (:togglepushpin 111) - (:pageleft 112) - (:pageright 113) - (:scrollbottom 114) - (:scrolltop 115) - (:multiright 116) - (:multileft 117) - (:multidown 118) - (:multiup 119) - (:immediate 120) - (:moveup 121) - (:movedown 122) - (:moveright 123) - (:moveleft 124) - (:click-to-type 125) - (:realestate 126) - (:underline 127) - (:highlight 128) - (:inactive 129) - (:display 130) - (:proc 131) - (:size-proc 132) - (:draw-proc 133) - (:pinned-menu 134) - (:press-drag-menu 135) - (:stayup-menu 136) - (:pointer 137) - (:inputfocus 138) - (:quit 142) - (:destroy 143) - (:dismiss 144) - (:pre 145) - (:post 146) - (:grow-off 147) - (:grow-horizontal 148) - (:grow-vertical 149) - (:grow-both 150) - )) + (:ignore -1) + (:ignore 65535) + (:absent-pair 0) + (:all 1) + (:always 2) + (:atom-help 3) + (:both 4) + (:bottom 5) + (:buttonstack 6) + (:center 7) + (:class-help 8) + (:columns 9) + (:copy-mask-value 10) + (:copy-size 11) + (:copy-source-value 12) + (:current 13) + (:default-pair 14) + (:disk-source 15) + (:display-form 16) + (:down 17) + (:existing-source 18) + (:fixedcols 19) + (:fixedheight 20) + (:fixedrows 21) + (:fixedwidth 22) + (:flat-button 23) + (:flat-checkbox 24) + (:flat-container 25) + (:flat-exclusives 26) + (:flat-help 27) + (:flat-nonexclusives 28) + (:halfstack 29) + (:horizontal 30) + (:image 31) + (:in 32) + (:indirect-source 33) + (:label 34) + (:left 35) + (:mask-pair 36) + (:maximize 37) + (:millimeters 38) + (:minimize 39) + (:never 40) + (:next 41) + (:none 42) + (:nonebottom 43) + (:noneleft 44) + (:noneright 45) + (:nonetop 46) + (:notices 47) + (:no-virtual-mapping 48) + (:oblong 49) + (:out 50) + (:override-pair 51) + (:pixels 52) + (:points 53) + (:popup 54) + (:previous 55) + (:prog-defined-source 56) + (:rectbutton 57) + (:right 58) + (:rows 59) + (:source-form 60) + (:source-pair 61) + (:stayup 62) + (:string 63) + (:string-source 64) + (:text-append 65) + (:text-edit 66) + (:text-read 67) + (:top 68) + (:transparent-source 69) + (:vertical 70) + (:virtual-button 71) + (:virtual-key 72) + (:widget-help 73) + (:window-help 74) + (:wrap-any 75) + (:wrap-white-space 76) + (:continuous 77) + (:granularity 78) + (:release 79) + (:tickmark 80) + (:percent 81) + (:slidervalue 82) + (:wt-base 83) + (:wt-cmd 84) + (:wt-notice 85) + (:wt-help 86) + (:wt-other 87) + (:success 88) + (:duplicate-key 89) + (:duplicatekey 89) + (:bad-key 90) + (:menu-full 91) + (:menu-limited 92) + (:menu-cancel 93) + (:selectkey 94) + (:menukey 95) + (:menudefault 96) + (:menudefaultkey 97) + (:hsbmenu 98) + (:vsbmenu 99) + (:adjustkey 100) + (:nextapp 101) + (:nextwindow 102) + (:prevapp 103) + (:prevwindow 104) + (:windowmenu 105) + (:workspacemenu 106) + (:defaultaction 108) + (:drag 109) + (:drop 110) + (:togglepushpin 111) + (:pageleft 112) + (:pageright 113) + (:scrollbottom 114) + (:scrolltop 115) + (:multiright 116) + (:multileft 117) + (:multidown 118) + (:multiup 119) + (:immediate 120) + (:moveup 121) + (:movedown 122) + (:moveright 123) + (:moveleft 124) + (:click-to-type 125) + (:realestate 126) + (:underline 127) + (:highlight 128) + (:inactive 129) + (:display 130) + (:proc 131) + (:size-proc 132) + (:draw-proc 133) + (:pinned-menu 134) + (:press-drag-menu 135) + (:stayup-menu 136) + (:pointer 137) + (:inputfocus 138) + (:quit 142) + (:destroy 143) + (:dismiss 144) + (:pre 145) + (:post 146) + (:grow-off 147) + (:grow-horizontal 148) + (:grow-vertical 149) + (:grow-both 150) + )) (defmethod convert-resource-in (parent (type (eql 'ol-define)) value) (declare (ignore parent)) @@ -594,9 +596,9 @@ ;;; Accelerator table stuff (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table)) - (value (eql nil))) + (value (eql nil))) (declare (ignore parent)) - 0) + (xt_parse_accelerator_table "")) @@ -701,3 +703,11 @@ (define-enumerated-resource ol-wrap-mode ((:wrap-off 74) (:wrap-any 75) (:wrap-white-space 76))) + + +(defmethod convert-resource-out (parent (type (eql 'xt::translation-table)) value) + (declare (ignore parent)) + (xt_parse_translation_table + (etypecase value + (string value) + (null "")))) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index c755e0a79c9fc61c17d5ff88bc1309d6cd65e0db..615d6cf9281ae885fa3cc4186ecf3f2b706694f6 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,7 +20,8 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.17 93/05/13 16:24:42 cer Exp $ +;; $fiHeader: xt-funs.lisp,v 1.17 1993/05/13 16:24:42 cer Exp $ + ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -277,6 +278,15 @@ :arg-checking nil :return-type :fixnum :entry-point (ff:convert-to-lang "XtAppPending")) + + +(defforeign 'xt_app_peek_event + :arguments '(foreign-address foreign-address) + :call-direct t + :arg-checking nil + :return-type :fixnum + :entry-point (ff:convert-to-lang "XtAppPeekEvent")) + (defforeign 'xt_app_process_event :arguments '(foreign-address fixnum) :call-direct t @@ -396,3 +406,18 @@ ; :arg-checking nil ; :entry-point (ff:convert-to-lang "XtGetMultiClickTime") ; :return-type :unsigned-integer) + +(ff:defforeign 'xt_parse_translation_table + :call-direct t + :arguments '(string) + :arg-checking nil + :entry-point (ff:convert-to-lang "XtParseTranslationTable") + :return-type :unsigned-integer) + +(ff:defforeign 'xt_parse_accelerator_table + :call-direct t + :arguments '(string) + :arg-checking nil + :entry-point (ff:convert-to-lang "XtParseAcceleratorTable") + :return-type :unsigned-integer) + diff --git a/utils/packages.lisp b/utils/packages.lisp index 9b943c578511e782344e4544901d9acdfda13ebc..14db14b08e8ea96faed11cf14421c862bc53e84a 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.53 93/04/27 14:36:16 cer Exp $ +;; $fiHeader: packages.lisp,v 1.54 1993/05/13 16:33:01 colin Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2032,6 +2032,7 @@ pixmap-height pixmap-width with-output-to-pixmap + with-medium-state-cached ;; Colors +background-ink+ @@ -2666,6 +2667,7 @@ disable-frame disown-frame display-command-menu + display-invalid-queries enable-frame execute-frame-command execute-command-in-frame @@ -3470,6 +3472,8 @@ mirror-region-updated mirror-visible-p modifier-keysym + move-focus-to-gadget + port-move-focus-to-gadget non-drawing-option-keywords note-layout-mixin-region-changed note-sheet-tree-grafted