Mercurial > hg > xemacs-beta
view src/gtk-glue.c @ 5882:bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
lisp/ChangeLog addition:
2015-04-01 Aidan Kehoe <kehoea@parhasard.net>
When calling #'string-match with a REGEXP without regular
expression special characters, call #'search, #'mismatch, #'find,
etc. instead, making our code less likely to side-effect other
functions' match data and a little faster.
* apropos.el (apropos-command):
* apropos.el (apropos):
Call (position ?\n ...) rather than (string-match "\n" ...) here.
* buff-menu.el:
* buff-menu.el (buffers-menu-omit-invisible-buffers):
Don't fire up the regexp engine just to check if a string starts
with a space.
* buff-menu.el (select-buffers-tab-buffers-by-mode):
Don't fire up the regexp engine just to compare mode basenames.
* buff-menu.el (format-buffers-tab-line):
* buff-menu.el (build-buffers-tab-internal): Moved to being a
label within the following.
* buff-menu.el (buffers-tab-items): Use the label.
* bytecomp.el (byte-compile-log-1):
Don't fire up the regexp engine just to look for a newline.
* cus-edit.el (get):
Ditto.
* cus-edit.el (custom-variable-value-create):
Ditto, but for a colon.
* descr-text.el (describe-text-sexp):
Ditto.
* descr-text.el (describe-char-unicode-data):
Use #'split-string-by-char given that we're just looking for a
semicolon.
* descr-text.el (describe-char):
Don't fire up the regexp engine just to look for a newline.
* disass.el (disassemble-internal):
Ditto.
* files.el (file-name-sans-extension):
Implement this using #'position.
* files.el (file-name-extension):
Correct this function's docstring, implement it in terms of
#'position.
* files.el (insert-directory):
Don't fire up the regexp engine to split a string by space; don't
reverse the list of switches, this is actually a longstand bug as
far as I can see.
* gnuserv.el (gnuserv-process-filter):
Use #'position here, instead of consing inside #'split-string
needlessly.
* gtk-file-dialog.el (gtk-file-dialog-update-dropdown):
Use #'split-string-by-char here, don't fire up #'split-string for
directory-sep-char.
* gtk-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* hyper-apropos.el (hyper-apropos-grok-functions):
* hyper-apropos.el (hyper-apropos-grok-variables):
Look for a newline using #'position rather than #'string-match in
these functions.
* info.el (Info-insert-dir):
* info.el (Info-insert-file-contents):
* info.el (Info-follow-reference):
* info.el (Info-extract-menu-node-name):
* info.el (Info-menu):
Look for fixed strings using #'position or #'search as appropriate
in this file.
* ldap.el (ldap-decode-string):
* ldap.el (ldap-encode-string):
#'encode-coding-string, #'decode-coding-string are always
available, don't check if they're fboundp.
* ldap.el (ldap-decode-address):
* ldap.el (ldap-encode-address):
Use #'split-string-by-char in these functions.
* lisp-mnt.el (lm-creation-date):
* lisp-mnt.el (lm-last-modified-date):
Don't fire up the regexp engine just to look for spaces in this file.
* menubar-items.el (default-menubar):
Use (not (mismatch ...)) rather than #'string-match here, for
simple regexp.
Use (search "beta" ...) rather than (string-match "beta" ...)
* menubar-items.el (sort-buffers-menu-alphabetically):
* menubar-items.el (sort-buffers-menu-by-mode-then-alphabetically):
* menubar-items.el (group-buffers-menu-by-mode-then-alphabetically):
Don't fire up the regexp engine to check if a string starts with
a space or an asterisk.
Use the more fine-grained results of #'compare-strings; compare
case-insensitively for the buffer menu.
* menubar-items.el (list-all-buffers):
* menubar-items.el (tutorials-menu-filter):
Use #'equal rather than #'string-equal, which, in this context,
has the drawback of not having a bytecode, and no redeeming
features.
* minibuf.el:
* minibuf.el (un-substitute-in-file-name):
Use #'count, rather than counting the occurences of $ using the
regexp engine.
* minibuf.el (read-file-name-internal-1):
Don't fire up the regexp engine to search for ?=.
* mouse.el (mouse-eval-sexp):
Check for newline with #'find.
* msw-font-menu.el (mswindows-reset-device-font-menus):
Split a string by newline with #'split-string-by-char.
* mule/japanese.el:
* mule/japanese.el ("Japanese"):
Use #'search rather than #'string-match; canoncase before
comparing; fix a bug I had introduced where I had been making case
insensitive comparisons where the case mattered.
* mule/korea-util.el (default-korean-keyboard):
Look for ?3 using #'find, not #'string-march.
* mule/korea-util.el (quail-hangul-switch-hanja):
Search for a fixed string using #'search.
* mule/mule-cmds.el (set-locale-for-language-environment):
#'position, #'substitute rather than #'string-match,
#'replace-in-string.
* newcomment.el (comment-make-extra-lines):
Use #'search rather than #'string-match for a simple string.
* package-get.el (package-get-remote-filename):
Use #'position when looking for ?@
* process.el (setenv):
* process.el (read-envvar-name):
Use #'position when looking for ?=.
* replace.el (map-query-replace-regexp):
Use #'split-string-by-char instead of using an inline
implementation of it.
* select.el (select-convert-from-cf-text):
* select.el (select-convert-from-cf-unicodetext):
Use #'position rather than #'string-match in these functions.
* setup-paths.el (paths-emacs-data-root-p):
Use #'search when looking for simple string.
* sound.el (load-sound-file):
Use #'split-string-by-char rather than an inline reimplementation
of same.
* startup.el (splash-screen-window-body):
* startup.el (splash-screen-tty-body):
Search for simple strings using #'search.
* version.el (emacs-version):
Ditto.
* x-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* x-font-menu.el (x-reset-device-font-menus-core):
Use #'split-string-by-char here.
* x-init.el (x-initialize-keyboard):
Search for a simple string using #'search.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Wed, 01 Apr 2015 14:28:20 +0100 |
parents | 56144c8593a8 |
children |
line wrap: on
line source
/* gtk-glue.c --- GTK interfaces with XEmacs Copyright (C) 2000, 2001 William M. Perry 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 3 of the License, 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 XEmacs. If not, see <http://www.gnu.org/licenses/>. */ GtkType GTK_TYPE_ARRAY = 0; GtkType GTK_TYPE_STRING_ARRAY = 0; GtkType GTK_TYPE_FLOAT_ARRAY = 0; GtkType GTK_TYPE_INT_ARRAY = 0; GtkType GTK_TYPE_LISTOF = 0; GtkType GTK_TYPE_STRING_LIST = 0; GtkType GTK_TYPE_OBJECT_LIST = 0; GtkType GTK_TYPE_GDK_GC = 0; #include "console-gtk.h" #include "fontcolor-gtk-impl.h" static GtkType xemacs_type_register (gchar *name, GtkType parent) { GtkType type_id; GtkTypeInfo info; info.type_name = name; info.object_size = 0; info.class_size = 0; info.class_init_func = NULL; info.object_init_func = NULL; info.reserved_1 = NULL; info.reserved_2 = NULL; type_id = gtk_type_unique (parent, &info); return (type_id); } static void xemacs_init_gtk_classes (void) { if (!GTK_TYPE_ARRAY) { GTK_TYPE_ARRAY = xemacs_type_register ("GtkArrayOf", 0); GTK_TYPE_STRING_ARRAY = xemacs_type_register ("GtkArrayOfString", GTK_TYPE_ARRAY); GTK_TYPE_FLOAT_ARRAY = xemacs_type_register ("GtkArrayOfFloat", GTK_TYPE_ARRAY); GTK_TYPE_INT_ARRAY = xemacs_type_register ("GtkArrayOfInteger", GTK_TYPE_ARRAY); GTK_TYPE_LISTOF = xemacs_type_register ("GtkListOf", 0); GTK_TYPE_STRING_LIST = xemacs_type_register ("GtkListOfString", GTK_TYPE_LISTOF); GTK_TYPE_OBJECT_LIST = xemacs_type_register ("GtkListOfObject", GTK_TYPE_LISTOF); GTK_TYPE_GDK_GC = xemacs_type_register ("GdkGC", GTK_TYPE_BOXED); } } static void xemacs_list_to_gtklist (Lisp_Object obj, GtkArg *arg) { CHECK_LIST (obj); if (arg->type == GTK_TYPE_STRING_LIST) { Lisp_Object temp = obj; GList *strings = NULL; while (!NILP (temp)) { CHECK_STRING (XCAR (temp)); temp = XCDR (temp); } temp = obj; while (!NILP (temp)) { strings = g_list_append (strings, XSTRING_DATA (XCAR (temp))); temp = XCDR (temp); } GTK_VALUE_POINTER (*arg) = strings; } else if (arg->type == GTK_TYPE_OBJECT_LIST) { Lisp_Object temp = obj; GList *objects = NULL; while (!NILP (temp)) { CHECK_GTK_OBJECT (XCAR (temp)); temp = XCDR (temp); } temp = obj; while (!NILP (temp)) { objects = g_list_append (objects, XGTK_OBJECT (XCAR (temp))->object); temp = XCDR (temp); } GTK_VALUE_POINTER (*arg) = objects; } else { ABORT (); } } static void __make_gtk_object_mapper (gpointer data, gpointer user_data) { Lisp_Object *rv = (Lisp_Object *) user_data; *rv = Fcons (build_gtk_object (GTK_OBJECT (data)), *rv); } static void __make_string_mapper (gpointer data, gpointer user_data) { Lisp_Object *rv = (Lisp_Object *) user_data; *rv = Fcons (build_cistring ((char *)data), *rv); } static Lisp_Object xemacs_gtklist_to_list (GtkArg *arg) { Lisp_Object rval = Qnil; if (GTK_VALUE_POINTER (*arg)) { if (arg->type == GTK_TYPE_STRING_LIST) { g_list_foreach ((GList*) GTK_VALUE_POINTER (*arg), __make_string_mapper, &rval); } else if (arg->type == GTK_TYPE_OBJECT_LIST) { g_list_foreach ((GList*) GTK_VALUE_POINTER (*arg), __make_gtk_object_mapper, &rval); } else { ABORT (); } } return (rval); } static void xemacs_list_to_array (Lisp_Object obj, GtkArg *arg) { CHECK_LIST (obj); #define FROB(ret_type,check_fn,extract_fn) \ do { \ Lisp_Object temp = obj; \ int length = 0; \ ret_type *array = NULL; \ \ while (!NILP (temp)) \ { \ check_fn (XCAR (temp)); \ length++; \ temp = XCDR (temp); \ } \ \ array = xnew_array_and_zero (ret_type, length + 2); \ temp = obj; \ length = 0; \ \ while (!NILP (temp)) \ { \ array[length++] = extract_fn (XCAR (temp)); \ temp = XCDR (temp); \ } \ \ GTK_VALUE_POINTER (*arg) = array; \ } while (0); if (arg->type == GTK_TYPE_STRING_ARRAY) { FROB (gchar *, CHECK_STRING, (gchar*) XSTRING_DATA); } else if (arg->type == GTK_TYPE_FLOAT_ARRAY) { FROB (gfloat, CHECK_FLOAT, extract_float); } else if (arg->type == GTK_TYPE_INT_ARRAY) { FROB (gint, CHECK_FIXNUM, XFIXNUM); } else { ABORT (); } #undef FROB } static GdkGC * face_to_gc (Lisp_Object face) { Lisp_Object frame = Fselected_frame (Qnil); return (gtk_get_gc (XFRAME (frame), Fspecifier_instance (Fget (face, Qfont, Qnil), frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qforeground, Qnil), frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qbackground, Qnil), frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qbackground_pixmap, Qnil), frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qbackground_placement, Qnil), frame, Qnil, Qnil), Qnil)); } static GtkStyle * face_to_style (Lisp_Object face) { Lisp_Object device = Fselected_device (Qnil); GtkStyle *style = gtk_style_new (); int i; Lisp_Object font = Fspecifier_instance (Fget (face, Qfont, Qnil), device, Qnil, Qnil); Lisp_Object fg = Fspecifier_instance (Fget (face, Qforeground, Qnil), device, Qnil, Qnil); Lisp_Object bg = Fspecifier_instance (Fget (face, Qbackground, Qnil), device, Qnil, Qnil); Lisp_Object pm = Fspecifier_instance (Fget (face, Qbackground_pixmap, Qnil), device, Qnil, Qnil); for (i = 0; i < 5; i++) style->fg[i] = *COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (fg)); for (i = 0; i < 5; i++) style->bg[i] = *COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (bg)); if (IMAGE_INSTANCEP (pm)) { for (i = 0; i < 5; i++) style->bg_pixmap[i] = XIMAGE_INSTANCE_GTK_PIXMAP (pm); } style->font = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (font)); return (style); } static Lisp_Object gdk_event_to_emacs_event (GdkEvent *ev) { Lisp_Object event = Qnil; if (ev) { Lisp_Event *emacs_event; event = Fmake_event (Qnil, Qnil); emacs_event = XEVENT (event); if (!gtk_event_to_emacs_event (NULL, ev, emacs_event)) { /* We need to handle a few more cases than the normal event ** loop does. Mainly the double/triple click events. */ if ((ev->type == GDK_2BUTTON_PRESS) || (ev->type == GDK_3BUTTON_PRESS)) { set_event_type (emacs_event, misc_user_event); SET_EVENT_MISC_USER_BUTTON (emacs_event, ev->button.button); SET_EVENT_MISC_USER_MODIFIERS (emacs_event, 0); SET_EVENT_MISC_USER_X (emacs_event, (int) ev->button.x); SET_EVENT_MISC_USER_Y (emacs_event, (int) ev->button.y); if (ev->type == GDK_2BUTTON_PRESS) SET_EVENT_MISC_USER_FUNCTION (emacs_event, intern ("double-click")); else SET_EVENT_MISC_USER_FUNCTION (emacs_event, intern ("triple-click")); } else { Fdeallocate_event (event); event = Qnil; } } } return (event); }