Index: configure.in =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/configure.in,v retrieving revision 1.111.2.97 diff -u -r1.111.2.97 configure.in --- configure.in 2000/04/03 06:28:54 1.111.2.97 +++ configure.in 2000/04/14 16:04:18 @@ -4649,7 +4649,7 @@ echo " Internationalization:" test "$with_mule" = yes && echo " Compiling in support for Mule (multi-lingual Emacs)." -test "$with_file_coding" = yes && echo " Compiling in support for ile coding." +test "$with_file_coding" = yes && echo " Compiling in support for file coding." test "$with_xim" != no && echo " Compiling in support for XIM (X11R5+ I18N input method)." test "$with_xim" = motif && echo " - Using Motif to provide XIM support." test "$with_xim" = xlib && echo " - Using raw Xlib to provide XIM support." Index: etc/Emacs.ad =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/etc/Emacs.ad,v retrieving revision 1.8 diff -u -r1.8 Emacs.ad --- etc/Emacs.ad 1998/03/10 04:11:50 1.8 +++ etc/Emacs.ad 2000/04/14 16:04:19 @@ -191,6 +191,10 @@ *menubar*Font: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-* *popup*Font: -*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-* +! Gui elements share this font +! +Emacs.gui-element.attributeFont: -*-helvetica-medium-r-*-*-*-120-*-*-*-*-iso8859-* + ! Font in the Motif dialog boxes. ! (Motif uses `fontList' while most other things use `font' - if you don't ! know why you probably don't want to.) @@ -259,6 +263,11 @@ ~Shift ~Meta ~Alt Return: ArmAndActivate()\n\ : Enter()\n\ : Leave()\n + +! Native Widget translations +! ======================= +Emacs*Text*translations: #override\n\ + : widget-focus-in()\n ! XIM input method style ! ======================= Index: lisp/dialog.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/dialog.el,v retrieving revision 1.2.2.1 diff -u -r1.2.2.1 dialog.el --- lisp/dialog.el 2000/03/13 07:27:40 1.2.2.1 +++ lisp/dialog.el 2000/04/14 16:04:23 @@ -154,4 +154,63 @@ (apply 'message-box fmt args) (apply 'message fmt args))) +(defun make-dialog-box (&optional spec props parent) + "Create a frame suitable for use as a general dialog box. +The frame is made a child of PARENT (defaults to the selected frame), +and has additional properties PROPS, as well as `dialog-frame-plist'. +SPEC is a string or glyph to be placed in the gutter. If INVISIBLE is +non-nil then the frame is initially unmapped. +Normally the created frame has no modelines, menubars, scrollbars, +minibuffer or toolbars and is entirely covered by its gutter." + (or parent (setq parent (selected-frame))) + (let* ((ftop (frame-property parent 'top)) + (fleft (frame-property parent 'left)) + (fwidth (frame-pixel-width parent)) + (fheight (frame-pixel-height parent)) + (fonth (font-height (face-font 'default))) + (fontw (font-width (face-font 'default))) + (props (append props dialog-frame-plist)) + (dfheight (plist-get props 'height)) + (dfwidth (plist-get props 'width)) + (unmapped (plist-get props 'initially-unmapped)) + (gutter-spec spec) + (name (or (plist-get props 'name) "XEmacs")) + (frame nil)) + (plist-remprop props 'initially-unmapped) + ;; allow the user to just provide a glyph + (when (glyphp spec) + (setq gutter-spec (copy-sequence "\n")) + (set-extent-begin-glyph (make-extent 0 1 gutter-spec) spec)) + ;; under FVWM at least, if I don't specify the initial position, + ;; it ends up always at (0, 0). xwininfo doesn't tell me + ;; that there are any program-specified position hints, so + ;; it must be an FVWM bug. So just be smashing and position + ;; in the center of the selected frame. + (setq frame (make-frame + (append props + `(popup ,parent initially-unmapped t + menubar-visible-p nil + has-modeline-p nil + default-toolbar-visible-p nil + top-gutter-visible-p t + top-gutter-height ,(* dfheight fonth) + top-gutter ,gutter-spec + minibuffer none + name ,name + modeline-shadow-thickness 0 + vertical-scrollbar-visible-p nil + horizontal-scrollbar-visible-p nil + unsplittable t + left ,(+ fleft (- (/ fwidth 2) + (/ (* dfwidth fontw) + 2))) + top ,(+ ftop (- (/ fheight 2) + (/ (* dfheight fonth) + 2))))))) + (set-face-foreground 'modeline [default foreground] frame) + (set-face-background 'modeline [default background] frame) + (unless unmapped (make-frame-visible frame)) + frame)) + + ;;; dialog.el ends here Index: lisp/dumped-lisp.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/dumped-lisp.el,v retrieving revision 1.30.2.13 diff -u -r1.30.2.13 dumped-lisp.el --- lisp/dumped-lisp.el 2000/03/10 08:07:10 1.30.2.13 +++ lisp/dumped-lisp.el 2000/04/14 16:04:24 @@ -156,6 +156,7 @@ ;; Moved to sunpro-load.el - the default only for Sun. ;;(pureload "mime-setup") ;;; mule-load.el ends here + (when-feature (and gutter window-system) "gutter") (when-feature window-system "gui") (when-feature window-system "mode-motion") (when-feature window-system "mouse") Index: lisp/gutter-items.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/Attic/gutter-items.el,v retrieving revision 1.1.2.43 diff -u -r1.1.2.43 gutter-items.el --- lisp/gutter-items.el 2000/04/05 19:07:22 1.1.2.43 +++ lisp/gutter-items.el 2000/04/14 16:04:29 @@ -24,153 +24,7 @@ ;; Boston, MA 02111-1307, USA. ;; Some of this is taken from the buffer-menu stuff in menubar-items.el -;; and the custom specs in toolbar.el. -(defgroup gutter nil - "Input from the gutters." - :group 'environment) - -;; Although these customizations appear bogus, they are neccessary in -;; order to be able to save options through the options menu. -(defcustom default-gutter-position - (default-gutter-position) - "The location of the default gutter. It can be 'top, 'bottom, 'left or -'right. This option should be customized through the options menu. -To set the gutter position explicitly use `set-default-gutter-position'" - :group 'gutter - :type '(choice (const :tag "top" top) - (const :tag "bottom" bottom) - (const :tag "left" left) - (const :tag "right" right)) - :set #'(lambda (var val) - (set-default-gutter-position val) - (setq default-gutter-position val))) - -;;; Gutter helper functions - -;; called by Fset_default_gutter_position() -(defvar default-gutter-position-changed-hook nil - "Function or functions to be called when the gutter position is changed. -The value of this variable may be buffer-local.") - -;; called by set-gutter-element-visible-p -(defvar gutter-element-visibility-changed-hook nil - "Function or functions to be called when the visibility of an -element in the gutter changes. The value of this variable may be -buffer-local. The gutter element symbol is passed as an argument to -the hook, as is the visibility flag.") - -(defun set-gutter-element (gutter-specifier prop val &optional locale tag-set) - "Set GUTTER-SPECIFIER gutter element PROP to VAL in optional LOCALE. -This is a convenience function for setting gutter elements. -VAL in general must be a string. If VAL is a glyph then a string will be -created to put the glyph into." - (let ((spec val)) - (when (glyphp val) - (setq spec (copy-sequence "\n")) - (set-extent-begin-glyph (make-extent 0 1 spec) val)) - (map-extents #'(lambda (extent arg) - (set-extent-property extent 'duplicable t)) spec) - (modify-specifier-instances gutter-specifier #'plist-put (list prop spec) - 'force nil locale tag-set))) - -(defun remove-gutter-element (gutter-specifier prop &optional locale tag-set) - "Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE. -This is a convenience function for removing gutter elements." - (modify-specifier-instances gutter-specifier #'plist-remprop (list prop) - 'force nil locale tag-set)) - -(defun set-gutter-element-visible-p (gutter-visible-specifier-p - prop &optional visible-p - locale tag-set) - "Change the visibility of gutter elements. -Set the visibility of element PROP to VISIBLE-P for -GUTTER-SPECIFIER-VISIBLE-P in optional LOCALE. -This is a convenience function for hiding and showing gutter elements." - (modify-specifier-instances - gutter-visible-specifier-p #'(lambda (spec prop visible-p) - (if (consp spec) - (if visible-p - (if (memq prop spec) spec - (cons prop spec)) - (delq prop spec)) - (if visible-p (list prop)))) - (list prop visible-p) - 'force nil locale tag-set) - (run-hook-with-args 'gutter-element-visibility-changed-hook prop visible-p)) - -(defun gutter-element-visible-p (gutter-visible-specifier-p - prop &optional domain) - "Determine whether a gutter element is visible. -Given GUTTER-VISIBLE-SPECIFIER-P and gutter element PROP, return -non-nil if it is visible in optional DOMAIN." - (let ((spec (specifier-instance gutter-visible-specifier-p domain))) - (or (and (listp spec) (memq 'buffers-tab spec)) - spec))) - -(defun make-gutter-only-dialog-frame (&optional spec props parent) - "Create a frame with only a gutter suitable for use as a dialog box. -The frame is made a child of PARENT (defaults to the selected frame), -and has additional properties PROPS, as well as `dialog-frame-plist'. -SPEC is a string or glyph to be placed in the gutter. If INVISIBLE is -non-nil then the frame is initially unmapped. -Normally the created frame has no modelines, menubars, scrollbars, -minibuffer or toolbars." - (or parent (setq parent (selected-frame))) - (let* ((ftop (frame-property parent 'top)) - (fleft (frame-property parent 'left)) - (fwidth (frame-pixel-width parent)) - (fheight (frame-pixel-height parent)) - (fonth (font-height (face-font 'default))) - (fontw (font-width (face-font 'default))) - (props (append props dialog-frame-plist)) - (dfheight (plist-get props 'height)) - (dfwidth (plist-get props 'width)) - (unmapped (plist-get props 'initially-unmapped)) - (gutter-spec spec) - (name (or (plist-get props 'name) "XEmacs")) - (frame nil)) - (plist-remprop props 'initially-unmapped) - ;; allow the user to just provide a glyph - (when (glyphp spec) - (setq gutter-spec (copy-sequence "\n")) - (set-extent-begin-glyph (make-extent 0 1 gutter-spec) spec)) - ;; under FVWM at least, if I don't specify the initial position, - ;; it ends up always at (0, 0). xwininfo doesn't tell me - ;; that there are any program-specified position hints, so - ;; it must be an FVWM bug. So just be smashing and position - ;; in the center of the selected frame. - (setq frame (make-frame - (append props - `(popup ,parent initially-unmapped t - menubar-visible-p nil - has-modeline-p nil - default-toolbar-visible-p nil - top-gutter-visible-p t - top-gutter-height ,(* dfheight fonth) - top-gutter ,gutter-spec - minibuffer none - name ,name - modeline-shadow-thickness 0 - vertical-scrollbar-visible-p nil - horizontal-scrollbar-visible-p nil - unsplittable t - left ,(+ fleft (- (/ fwidth 2) - (/ (* dfwidth fontw) - 2))) - top ,(+ ftop (- (/ fheight 2) - (/ (* dfheight fonth) - 2))))))) - (set-face-foreground 'modeline [default foreground] frame) - (set-face-background 'modeline [default background] frame) - (unless unmapped (make-frame-visible frame)) - frame)) - -(defun init-gutter () - "Initialize the gutter." - ;; do nothing as yet. - ) - ;;; The Buffers tab (defgroup buffers-tab nil @@ -826,61 +680,58 @@ (make-glyph [edit-field :width 15 :descriptor "" :active t :face default])) -(defun search-dialog-callback (dialog parent) - (let ((locale (frame-selected-window dialog))) +(defun search-dialog-callback (parent) + (save-selected-frame (select-frame parent) (funcall (if search-dialog-direction 'search-forward 'search-backward) (image-instance-property - (glyph-image-instance search-dialog-text locale) :text)) - (isearch-highlight (match-beginning 0) (match-end 0)) - (select-frame dialog))) + (glyph-image-instance search-dialog-text + (frame-selected-window + widget-callback-current-channel)) :text)) + (isearch-highlight (match-beginning 0) (match-end 0)))) (defun make-search-dialog () "Popup a search dialog box." (interactive) - (let* ((parent (selected-frame)) - (dialog (make-gutter-only-dialog-frame nil - '(height 10 width 40 initially-unmapped t))) - (gutter-spec (copy-sequence "\n")) - (gutter-glyph - (make-glyph - `[layout - :orientation horizontal :justify left - :height 10 :width 40 - :border [string :data "Search"] - :items - ([layout :orientation vertical :justify left - :items - ([string :data "Search for:"] - [button :descriptor "Match case" - :style toggle - :selected (not case-fold-search) - :callback (setq case-fold-search - (not case-fold-search))] - [button :descriptor "Forwards" - :style radio - :selected search-dialog-direction - :callback (setq search-dialog-direction t)] - [button :descriptor "Backwards" - :style radio - :selected (not search-dialog-direction) - :callback (setq search-dialog-direction nil)] - )] - [layout :orientation vertical :justify left - :items - (search-dialog-text - [button :width 10 :descriptor "Find Next" - :callback (search-dialog-callback ,dialog - ,parent)] - [button :width 10 :descriptor "Cancel" - :callback - (progn (isearch-dehighlight) - (make-frame-invisible ,dialog))])])]))) - (set-extent-begin-glyph (make-extent 0 1 gutter-spec) gutter-glyph) - (set-frame-properties dialog `(top-gutter ,gutter-spec)) - (set-buffer-dedicated-frame (get-buffer-create "Dialog") dialog) - (make-frame-visible dialog))) + (let* ((parent (selected-frame))) + (set-buffer-dedicated-frame + (get-buffer-create "Dialog") + (make-dialog-box + (make-glyph + `[layout + :orientation horizontal :justify left + :height 10 :width 40 + :border [string :data "Search"] + :items + ([layout :orientation vertical :justify left + :items + ([string :data "Search for:"] + [button :descriptor "Match case" + :style toggle + :selected (not case-fold-search) + :callback (setq case-fold-search + (not case-fold-search))] + [button :descriptor "Forwards" + :style radio + :selected search-dialog-direction + :callback (setq search-dialog-direction t)] + [button :descriptor "Backwards" + :style radio + :selected (not search-dialog-direction) + :callback (setq search-dialog-direction nil)] + )] + [layout :orientation vertical :justify left + :items + (search-dialog-text + [button :width 10 :descriptor "Find Next" + :callback (search-dialog-callback ,parent)] + [button :width 10 :descriptor "Cancel" + :callback + (progn (isearch-dehighlight) + (make-frame-invisible + widget-callback-current-channel))])])]) + '(height 10 width 40))))) (provide 'gutter-items) ;;; gutter-items.el ends here. Index: lwlib/lwlib-Xaw.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lwlib/lwlib-Xaw.c,v retrieving revision 1.9.2.12 diff -u -r1.9.2.12 lwlib-Xaw.c --- lwlib/lwlib-Xaw.c 2000/04/06 21:57:53 1.9.2.12 +++ lwlib/lwlib-Xaw.c 2000/04/14 16:04:32 @@ -134,6 +134,13 @@ xaw_update_scrollbar (instance, widget, val); } #endif +#ifdef LWLIB_WIDGETS_ATHENA +#ifndef NEED_MOTIF + else if (XtIsSubclass (widget, asciiTextWidgetClass)) + { + } +#endif +#endif #ifdef LWLIB_DIALOGS_ATHENA else if (XtIsSubclass (widget, dialogWidgetClass)) { @@ -220,11 +227,19 @@ #ifndef NEED_MOTIF else if (XtIsSubclass (widget, asciiTextWidgetClass)) { - Arg al [1]; + Arg al [2]; + String buf = 0; + XtSetArg (al [0], XtNstring, &buf); + XtGetValues (widget, al, 2); + if (val->value) - free (val->value); - XtSetArg (al [0], XtNstring, &val->value); - XtGetValues (widget, al, 1); + { + free (val->value); + val->value = 0; + } + /* I don't think this causes a leak. */ + if (buf) + val->value = strdup (buf); val->edited = True; } #endif @@ -821,6 +836,7 @@ } #ifndef NEED_MOTIF +#define TEXT_BUFFER_SIZE 128 static Widget xaw_create_text_field (widget_instance *instance) { @@ -834,17 +850,31 @@ XtSetArg (al [ac], XtNhighlightThickness, (Dimension)0); ac++; XtSetArg (al [ac], XtNtype, XawAsciiString); ac++; XtSetArg (al [ac], XtNeditType, XawtextEdit); ac++; + XtSetArg (al [ac], XtNuseStringInPlace, False); ac++; +#if 0 + XtSetArg (al [ac], XtNlength, TEXT_BUFFER_SIZE); ac++; +#endif + if (val->value) + { + XtSetArg (al [ac], XtNstring, val->value); ac++; + } /* add any args the user supplied for creation time */ lw_add_value_args_to_args (val, al, &ac); text = XtCreateManagedWidget (val->name, asciiTextWidgetClass, instance->parent, al, ac); + + /* add the callback */ + if (val->call_data) + XtAddCallback (text, XtNgetValue, xaw_generic_callback, (XtPointer)instance); + XtManageChild (text); return text; } #endif + #endif /* LWLIB_WIDGETS_ATHENA */ widget_creation_entry Index: src/event-Xt.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/event-Xt.c,v retrieving revision 1.41.2.23 diff -u -r1.41.2.23 event-Xt.c --- src/event-Xt.c 2000/03/16 11:21:48 1.41.2.23 +++ src/event-Xt.c 2000/04/14 16:04:47 @@ -1491,7 +1491,6 @@ #ifdef HAVE_XIM XIM_focus_event (f, in_p); #endif /* HAVE_XIM */ - /* On focus change, clear all memory of sticky modifiers to avoid non-intuitive behavior. */ clear_sticky_modifiers (XDEVICE (FRAME_DEVICE (f))); @@ -1847,8 +1846,8 @@ break; case CreateNotify: - printf ("window created\n"); break; + default: break; } @@ -3079,6 +3078,42 @@ /************************************************************************/ +/* handle focus changes for native widgets */ +/************************************************************************/ +static void +emacs_Xt_event_widget_focus_in (Widget w, + XEvent *event, + String *params, + Cardinal *num_params) +{ + struct frame* f = + x_any_widget_or_parent_to_frame (get_device_from_display (event->xany.display), w); + + XtSetKeyboardFocus (FRAME_X_SHELL_WIDGET (f), w); +} + +static void +emacs_Xt_event_widget_focus_out (Widget w, + XEvent *event, + String *params, + Cardinal *num_params) +{ +} + +static XtActionsRec widgetActionsList[] = +{ + {"widget-focus-in", emacs_Xt_event_widget_focus_in }, + {"widget-focus-out", emacs_Xt_event_widget_focus_out }, +}; + +static void +emacs_Xt_event_add_widget_actions (XtAppContext ctx) +{ + XtAppAddActions (ctx, widgetActionsList, 2); +} + + +/************************************************************************/ /* initialization */ /************************************************************************/ @@ -3214,6 +3249,8 @@ NULL, 0, XtCacheByDisplay, EmacsFreeXIMStyles); #endif /* XIM_XLIB */ + /* Add extra actions to native widgets to handle focus and friends. */ + emacs_Xt_event_add_widget_actions (Xt_app_con); /* insert the visual inheritance patch/hack described above */ orig_shell_init_proc = shellClassRec.core_class.initialize; Index: src/general.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/general.c,v retrieving revision 1.13.2.10 diff -u -r1.13.2.10 general.c --- src/general.c 2000/02/15 06:18:25 1.13.2.10 +++ src/general.c 2000/04/14 16:04:48 @@ -82,6 +82,7 @@ Lisp_Object Qfont; Lisp_Object Qframe; Lisp_Object Qfunction; +Lisp_Object Qfuncall; Lisp_Object Qgap_overhead; Lisp_Object Qgeneric; Lisp_Object Qgeometry; @@ -102,8 +103,10 @@ Lisp_Object Qkeyboard; Lisp_Object Qkeymap; Lisp_Object Qlandscape; +Lisp_Object Qlast_command; Lisp_Object Qleft; Lisp_Object Qleft_margin; +Lisp_Object Qlet; Lisp_Object Qlist; Lisp_Object Qmagic; Lisp_Object Qmalloc_overhead; @@ -160,6 +163,7 @@ Lisp_Object Qterminal; Lisp_Object Qtest; Lisp_Object Qtext; +Lisp_Object Qthis_command; Lisp_Object Qtimeout; Lisp_Object Qtimestamp; Lisp_Object Qtoolbar; @@ -234,6 +238,7 @@ defsymbol (&Qfont, "font"); defsymbol (&Qframe, "frame"); defsymbol (&Qfunction, "function"); + defsymbol (&Qfuncall, "funcall"); defsymbol (&Qgap_overhead, "gap-overhead"); defsymbol (&Qgeneric, "generic"); defsymbol (&Qgeometry, "geometry"); @@ -254,8 +259,10 @@ defsymbol (&Qkeyboard, "keyboard"); defsymbol (&Qkeymap, "keymap"); defsymbol (&Qlandscape, "landscape"); + defsymbol (&Qlast_command, "last-command"); defsymbol (&Qleft, "left"); defsymbol (&Qleft_margin, "left-margin"); + defsymbol (&Qlet, "let"); defsymbol (&Qlist, "list"); defsymbol (&Qmagic, "magic"); defsymbol (&Qmalloc_overhead, "malloc-overhead"); @@ -312,6 +319,7 @@ defsymbol (&Qterminal, "terminal"); defsymbol (&Qtest, "test"); defsymbol (&Qtext, "text"); + defsymbol (&Qthis_command, "this-command"); defsymbol (&Qtimeout, "timeout"); defsymbol (&Qtimestamp, "timestamp"); defsymbol (&Qtoolbar, "toolbar"); Index: src/glyphs-widget.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/Attic/glyphs-widget.c,v retrieving revision 1.1.2.37 diff -u -r1.1.2.37 glyphs-widget.c --- src/glyphs-widget.c 2000/04/05 19:07:26 1.1.2.37 +++ src/glyphs-widget.c 2000/04/14 16:04:52 @@ -59,6 +59,8 @@ Lisp_Object Q_descriptor, Q_height, Q_width, Q_properties, Q_items; Lisp_Object Q_image, Q_text, Q_orientation, Q_justify, Q_border; Lisp_Object Qetched_in, Qetched_out, Qbevel_in, Qbevel_out; +Lisp_Object Vwidget_callback_current_channel; +Lisp_Object Qwidget_callback_current_channel; #ifdef DEBUG_WIDGETS int debug_widget_instances; @@ -1179,6 +1181,7 @@ defsymbol (&Qetched_out, "etched-out"); defsymbol (&Qbevel_in, "bevel-in"); defsymbol (&Qbevel_out, "bevel-out"); + defsymbol (&Qwidget_callback_current_channel, "widget-callback-current-channel"); } #define VALID_GUI_KEYWORDS(type) do { \ @@ -1355,4 +1358,10 @@ vars_of_glyphs_widget (void) { reinit_vars_of_glyphs_widget (); + + DEFVAR_LISP ("widget-callback-current-channel", &Vwidget_callback_current_channel /* +The domain that is current when a widget callback is invoked. +This is invariably the frame that the widget is instantiated in. +*/); + Vwidget_callback_current_channel = Qnil; } Index: src/glyphs-x.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/glyphs-x.c,v retrieving revision 1.49.2.64 diff -u -r1.49.2.64 glyphs-x.c --- src/glyphs-x.c 2000/04/06 21:57:50 1.49.2.64 +++ src/glyphs-x.c 2000/04/14 16:05:00 @@ -2540,10 +2540,8 @@ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii); Lisp_Object glyph = find_keyword_in_vector (instantiator, Q_image); - widget_value* wv = xmalloc_widget_value (); + widget_value* wv = gui_items_to_widget_values (gui); - button_item_to_widget_value (gui, wv, 1, 1, 0); - if (!NILP (glyph)) { if (!IMAGE_INSTANCEP (glyph)) @@ -2617,9 +2615,7 @@ { Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii); - widget_value* wv = xmalloc_widget_value (); - - button_item_to_widget_value (gui, wv, 1, 1, 0); + widget_value* wv = gui_items_to_widget_values (gui); x_widget_instantiate (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain, "progress", wv); @@ -2652,10 +2648,8 @@ { Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii); - widget_value* wv = xmalloc_widget_value (); + widget_value* wv = gui_items_to_widget_values (gui); - button_item_to_widget_value (gui, wv, 1, 1, 0); - x_widget_instantiate (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain, "text-field", wv); } @@ -2731,9 +2725,7 @@ { Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); Lisp_Object gui = IMAGE_INSTANCE_WIDGET_ITEM (ii); - widget_value* wv = xmalloc_widget_value (); - - button_item_to_widget_value (gui, wv, 1, 1, 0); + widget_value* wv = gui_items_to_widget_values (gui); x_widget_instantiate (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain, "button", wv); Index: src/glyphs.h =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/glyphs.h,v retrieving revision 1.18.2.44 diff -u -r1.18.2.44 glyphs.h --- src/glyphs.h 2000/03/24 19:32:00 1.18.2.44 +++ src/glyphs.h 2000/04/14 16:05:04 @@ -884,9 +884,11 @@ extern Lisp_Object Q_width, Q_height, Q_pixel_width, Q_pixel_height, Q_text; extern Lisp_Object Q_items, Q_properties, Q_image, Qimage_conversion_error; extern Lisp_Object Q_orientation, Qupdate_widget_instances; +extern Lisp_Object Qwidget_callback_current_channel; extern Lisp_Object Vcontinuation_glyph, Vcontrol_arrow_glyph, Vhscroll_glyph; extern Lisp_Object Vinvisible_text_glyph, Voctal_escape_glyph, Vtruncation_glyph; extern Lisp_Object Vxemacs_logo; + unsigned short glyph_width (Lisp_Object glyph, Lisp_Object domain); unsigned short glyph_ascent (Lisp_Object glyph, Lisp_Object domain); Index: src/gui-msw.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/Attic/gui-msw.c,v retrieving revision 1.1.2.9 diff -u -r1.1.2.9 gui-msw.c --- src/gui-msw.c 2000/03/16 11:21:53 1.1.2.9 +++ src/gui-msw.c 2000/04/14 16:05:04 @@ -23,6 +23,7 @@ #include #include "lisp.h" #include "gui.h" +#include "glyphs.h" #include "redisplay.h" #include "frame.h" #include "elhash.h" @@ -53,12 +54,19 @@ /* Ok, this is our one. Enqueue it. */ get_gui_callback (data, &fn, &arg); XSETFRAME (frame, f); + /* Bind the current channel. */ + arg = list3 (Qlet, list1 (list2 (Qwidget_callback_current_channel, frame)), + arg); mswindows_enqueue_misc_user_event (frame, fn, arg); /* The result of this evaluation could cause other instances to change so - enqueue an update callback to check this. */ + enqueue an update callback to check this. We also have to make sure that + the function does not appear in the command history. + #### I'm sure someone can tell me how to optimize this. */ mswindows_enqueue_misc_user_event (frame, Qeval, - list2 (Qupdate_widget_instances, frame)); - + list3 (Qlet, + list2 (Qthis_command, + Qlast_command), + list2 (Qupdate_widget_instances, frame))); return Qt; } Index: src/gui-x.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/gui-x.c,v retrieving revision 1.14.2.22 diff -u -r1.14.2.22 gui-x.c --- src/gui-x.c 2000/04/06 21:57:51 1.14.2.22 +++ src/gui-x.c 2000/04/14 16:05:07 @@ -35,6 +35,7 @@ #include "device.h" #include "frame.h" #include "gui.h" +#include "glyphs.h" #include "redisplay.h" #include "opaque.h" @@ -248,6 +249,9 @@ { update_subwindows_p = 1; get_gui_callback (data, &fn, &arg); + /* Bind the current channel. */ + arg = list3 (Qlet, list1 (list2 (Qwidget_callback_current_channel, frame)), + arg); } /* This is the timestamp used for asserting focus so we need to get an @@ -260,10 +264,15 @@ #endif signal_special_Xt_user_event (frame, fn, arg); /* The result of this evaluation could cause other instances to change so - enqueue an update callback to check this. */ + enqueue an update callback to check this. We also have to make sure that + the function does not appear in the command history. + #### I'm sure someone can tell me how to optimize this. */ if (update_subwindows_p) signal_special_Xt_user_event (frame, Qeval, - list2 (Qupdate_widget_instances, frame)); + list3 (Qlet, + list2 (Qthis_command, + Qlast_command), + list2 (Qupdate_widget_instances, frame))); } #if 1 Index: src/gui.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/gui.c,v retrieving revision 1.10.2.26 diff -u -r1.10.2.26 gui.c --- src/gui.c 2000/03/28 18:23:13 1.10.2.26 +++ src/gui.c 2000/04/14 16:05:09 @@ -74,6 +74,8 @@ void get_gui_callback (Lisp_Object data, Lisp_Object *fn, Lisp_Object *arg) { + *fn = Qeval; + if (SYMBOLP (data) || (COMPILED_FUNCTIONP (data) && XCOMPILED_FUNCTION (data)->flags.interactivep) @@ -83,24 +85,21 @@ /* Treat 'quit specially and manufacture our own quit. */ if (EQ (data, Qquit)) { - *fn = Qeval; *arg = list3 (Qsignal, list2 (Qquote, Qquit), Qnil); Vquit_flag = Qt; } else { - *fn = Qcall_interactively; - *arg = data; + *arg = list3 (Qfuncall, list2 (Qquote, Qcall_interactively), + list2 (Qquote, data)); } } else if (CONSP (data)) { - *fn = Qeval; *arg = data; } else { - *fn = Qeval; *arg = list3 (Qsignal, list2 (Qquote, Qerror), list2 (Qquote, list2 (build_translated_string Index: src/gui.h =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/gui.h,v retrieving revision 1.6.2.14 diff -u -r1.6.2.14 gui.h --- src/gui.h 2000/03/24 19:32:01 1.6.2.14 +++ src/gui.h 2000/04/14 16:05:09 @@ -65,6 +65,7 @@ extern Lisp_Object Q_accelerator, Q_active, Q_config, Q_filter, Q_included; extern Lisp_Object Q_keys, Q_selected, Q_suffix, Qradio, Qtoggle; extern Lisp_Object Q_key_sequence, Q_label, Q_callback, Q_value; +extern Lisp_Object Qgui_callback_current_channel; void gui_item_add_keyval_pair (Lisp_Object, Lisp_Object key, Lisp_Object val, Index: src/lisp.h =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.38.2.55 diff -u -r1.38.2.55 lisp.h --- src/lisp.h 2000/04/10 09:53:23 1.38.2.55 +++ src/lisp.h 2000/04/14 16:05:19 @@ -2808,8 +2808,8 @@ extern Lisp_Object Qfile_name, Qfile_error; extern Lisp_Object Qfont, Qforce_g0_on_output, Qforce_g1_on_output; extern Lisp_Object Qforce_g2_on_output, Qforce_g3_on_output, Qforeground; -extern Lisp_Object Qformat, Qframe, Qframe_live_p, Qfunction, Qgap_overhead; -extern Lisp_Object Qgeneric, Qgeometry, Qglobal, Qheight; +extern Lisp_Object Qformat, Qframe, Qframe_live_p, Qfuncall, Qfunction; +extern Lisp_Object Qgap_overhead, Qgeneric, Qgeometry, Qglobal, Qheight; extern Lisp_Object Qhighlight, Qhorizontal, Qicon; extern Lisp_Object Qicon_glyph_p, Qid, Qidentity, Qimage, Qinfo, Qinherit; extern Lisp_Object Qinhibit_quit, Qinhibit_read_only; @@ -2818,7 +2818,8 @@ extern Lisp_Object Qinteger_or_marker_p, Qintegerp, Qinteractive, Qinternal; extern Lisp_Object Qinvalid_function, Qinvalid_read_syntax, Qio_error; extern Lisp_Object Qiso2022, Qkey, Qkey_assoc, Qkeyboard, Qkeymap; -extern Lisp_Object Qlambda, Qlayout, Qlandscape, Qleft, Qleft_margin, Qlf; +extern Lisp_Object Qlambda, Qlast_command, Qlayout, Qlandscape; +extern Lisp_Object Qleft, Qleft_margin, Qlet, Qlf; extern Lisp_Object Qlist, Qlistp, Qload, Qlock_shift, Qmacro, Qmagic; extern Lisp_Object Qmakunbound, Qmalformed_list, Qmalformed_property_list; extern Lisp_Object Qmalloc_overhead, Qmark, Qmarkers; @@ -2850,8 +2851,8 @@ extern Lisp_Object Qspecifier, Qstandard_input, Qstandard_output, Qstart_open; extern Lisp_Object Qstream, Qstring, Qstring_lessp, Qsubwindow; extern Lisp_Object Qsubwindow_image_instance_p; -extern Lisp_Object Qsymbol, Qsyntax, Qt, Qterminal, Qtest; -extern Lisp_Object Qtext, Qtext_image_instance_p, Qtimeout, Qtimestamp; +extern Lisp_Object Qsymbol, Qsyntax, Qt, Qterminal, Qtest, Qtext; +extern Lisp_Object Qtext_image_instance_p, Qthis_command, Qtimeout, Qtimestamp; extern Lisp_Object Qtoolbar, Qtop, Qtop_margin, Qtop_level; extern Lisp_Object Qtrue_list_p, Qtty, Qtype; extern Lisp_Object Qunbound, Qundecided, Qundefined, Qunderflow_error; Index: tests/glyph-test.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/tests/Attic/glyph-test.el,v retrieving revision 1.1.2.20 diff -u -r1.1.2.20 glyph-test.el --- tests/glyph-test.el 2000/03/24 19:32:03 1.1.2.20 +++ tests/glyph-test.el 2000/04/14 16:05:21 @@ -18,7 +18,8 @@ (make-extent (point) (point)) (setq radio-button1 (make-glyph - [button :descriptor ["ok1" (setq ok-select t) + [button :face widget + :descriptor ["ok1" (setq ok-select t) :style radio :selected ok-select]]))) ;; button in a group (set-extent-begin-glyph @@ -48,7 +49,7 @@ (setq push-button (make-glyph [button :width 10 :height 2 :face modeline-mousable - :descriptor "ok" :callback foo + :descriptor "ok" :callback make-search-dialog :selected t]))) ;; tree view (set-extent-begin-glyph Index: lisp/gutter.el =================================================================== RCS file: gutter.el diff -N gutter.el --- /dev/null Fri Apr 14 03:13:17 2000 +++ lisp/gutter.el Fri Apr 14 09:08:13 2000 @@ -0,0 +1,118 @@ +;;; gutter.el --- Gutter manipulation for XEmacs. + +;; Copyright (C) 1999 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000 Andy Piper. + +;; Maintainer: XEmacs Development Team +;; Keywords: frames, extensions, internal, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with Xmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; Some of this is taken from the buffer-menu stuff in menubar-items.el +;; and the custom specs in toolbar.el. + +(defgroup gutter nil + "Input from the gutters." + :group 'environment) + +;; Although these customizations appear bogus, they are neccessary in +;; order to be able to save options through the options menu. +(defcustom default-gutter-position + (default-gutter-position) + "The location of the default gutter. It can be 'top, 'bottom, 'left or +'right. This option should be customized through the options menu. +To set the gutter position explicitly use `set-default-gutter-position'" + :group 'gutter + :type '(choice (const :tag "top" top) + (const :tag "bottom" bottom) + (const :tag "left" left) + (const :tag "right" right)) + :set #'(lambda (var val) + (set-default-gutter-position val) + (setq default-gutter-position val))) + +;;; Gutter helper functions + +;; called by Fset_default_gutter_position() +(defvar default-gutter-position-changed-hook nil + "Function or functions to be called when the gutter position is changed. +The value of this variable may be buffer-local.") + +;; called by set-gutter-element-visible-p +(defvar gutter-element-visibility-changed-hook nil + "Function or functions to be called when the visibility of an +element in the gutter changes. The value of this variable may be +buffer-local. The gutter element symbol is passed as an argument to +the hook, as is the visibility flag.") + +(defun set-gutter-element (gutter-specifier prop val &optional locale tag-set) + "Set GUTTER-SPECIFIER gutter element PROP to VAL in optional LOCALE. +This is a convenience function for setting gutter elements. +VAL in general must be a string. If VAL is a glyph then a string will be +created to put the glyph into." + (let ((spec val)) + (when (glyphp val) + (setq spec (copy-sequence "\n")) + (set-extent-begin-glyph (make-extent 0 1 spec) val)) + (map-extents #'(lambda (extent arg) + (set-extent-property extent 'duplicable t)) spec) + (modify-specifier-instances gutter-specifier #'plist-put (list prop spec) + 'force nil locale tag-set))) + +(defun remove-gutter-element (gutter-specifier prop &optional locale tag-set) + "Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE. +This is a convenience function for removing gutter elements." + (modify-specifier-instances gutter-specifier #'plist-remprop (list prop) + 'force nil locale tag-set)) + +(defun set-gutter-element-visible-p (gutter-visible-specifier-p + prop &optional visible-p + locale tag-set) + "Change the visibility of gutter elements. +Set the visibility of element PROP to VISIBLE-P for +GUTTER-SPECIFIER-VISIBLE-P in optional LOCALE. +This is a convenience function for hiding and showing gutter elements." + (modify-specifier-instances + gutter-visible-specifier-p #'(lambda (spec prop visible-p) + (if (consp spec) + (if visible-p + (if (memq prop spec) spec + (cons prop spec)) + (delq prop spec)) + (if visible-p (list prop)))) + (list prop visible-p) + 'force nil locale tag-set) + (run-hook-with-args 'gutter-element-visibility-changed-hook prop visible-p)) + +(defun gutter-element-visible-p (gutter-visible-specifier-p + prop &optional domain) + "Determine whether a gutter element is visible. +Given GUTTER-VISIBLE-SPECIFIER-P and gutter element PROP, return +non-nil if it is visible in optional DOMAIN." + (let ((spec (specifier-instance gutter-visible-specifier-p domain))) + (or (and (listp spec) (memq 'buffers-tab spec)) + spec))) + +(defun init-gutter () + "Initialize the gutter." + ;; do nothing as yet. + ) + +;;; gutter.el ends here. + +