commit: Supply check_string_lessp_nokey explicitly to list_sort(), #'apropos-internal
13 years, 10 months
Aidan Kehoe
Aidan Kehoe
changeset: 5351:b5561bfd5061
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Feb 06 23:46:17 2011 +0000
files: src/ChangeLog src/symbols.c
description:
Supply check_string_lessp_nokey explicitly to list_sort(), #'apropos-internal
2011-02-06 Aidan Kehoe <kehoea(a)parhasard.net>
* symbols.c (Fapropos_internal):
Supply check_string_lessp_nokey explicitly as the CHECK_MERGE
argument to list_sort(), NULL no longer works. Thank you Mats
Lidell in IRC!
diff -r 94bbd4792049 -r b5561bfd5061 src/ChangeLog
--- a/src/ChangeLog Sat Feb 05 12:04:34 2011 +0000
+++ b/src/ChangeLog Sun Feb 06 23:46:17 2011 +0000
＠＠ -1,3 +1,10 ＠＠
+2011-02-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * symbols.c (Fapropos_internal):
+ Supply check_string_lessp_nokey explicitly as the CHECK_MERGE
+ argument to list_sort(), NULL no longer works. Thank you Mats
+ Lidell in IRC!
+
2011-02-05 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c:
diff -r 94bbd4792049 -r b5561bfd5061 src/symbols.c
--- a/src/symbols.c Sat Feb 05 12:04:34 2011 +0000
+++ b/src/symbols.c Sun Feb 06 23:46:17 2011 +0000
＠＠ -508,8 +508,8 ＠＠
closure.accumulation = Qnil;
GCPRO1 (closure.accumulation);
map_obarray (Vobarray, apropos_mapper, &closure);
- closure.accumulation = list_sort (closure.accumulation, NULL, Qstring_lessp,
- Qidentity);
+ closure.accumulation = list_sort (closure.accumulation,
+ check_string_lessp_nokey, Qnil, Qnil);
UNGCPRO;
return closure.accumulation;
}
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Have #'sort*, #'merge use the same test approach as functions from cl-seq.el
13 years, 10 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1296907474 0
# Node ID 94bbd4792049e3c45d11ba60e354718febd74a6e
# Parent 239193591765d863a41939ea57e6ad0bd9e98f65
Have #'sort*, #'merge use the same test approach as functions from cl-seq.el
2011-02-05 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c:
* fns.c (check_lss_key, check_lss_key_car): New.
* fns.c (check_string_lessp_key check_string_lessp_key_car): New.
* fns.c (get_merge_predicate): New.
* fns.c (list_merge):
* fns.c (array_merge):
* fns.c (list_array_merge_into_list):
* fns.c (list_list_merge_into_array):
* fns.c (list_array_merge_into_array):
* fns.c (Fmerge):
* fns.c (list_sort):
* fns.c (array_sort):
* fns.c (FsortX):
* fns.c (syms_of_fns):
* lisp.h:
Move #'sort, #'merge to using the same test approach as is used in
the functions that take TEST, TEST-NOT and KEY arguments. This
allows us to avoid the Ffuncall() overhead when the most common
PREDICATE arguments are supplied, in particular #'< and
#'string-lessp.
* fontcolor-msw.c (sort_font_list_function):
* fontcolor-msw.c (mswindows_enumerate_fonts):
* dired.c:
* dired.c (Fdirectory_files):
* fileio.c:
* fileio.c (build_annotations):
* fileio.c (syms_of_fileio):
* keymap.c:
* keymap.c (keymap_submaps):
* keymap.c (map_keymap_sort_predicate):
* keymap.c (describe_map_sort_predicate):
* keymap.c (describe_map):
Change the various C predicates passed to list_sort () and
list_merge () to fit the new calling convention, returning
non-zero if the first argument is less than the second, zero
otherwise.
diff -r 239193591765 -r 94bbd4792049 src/ChangeLog
--- a/src/ChangeLog Sun Jan 30 14:27:31 2011 +0100
+++ b/src/ChangeLog Sat Feb 05 12:04:34 2011 +0000
＠＠ -1,3 +1,43 ＠＠
+2011-02-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c:
+ * fns.c (check_lss_key, check_lss_key_car): New.
+ * fns.c (check_string_lessp_key check_string_lessp_key_car): New.
+ * fns.c (get_merge_predicate): New.
+ * fns.c (list_merge):
+ * fns.c (array_merge):
+ * fns.c (list_array_merge_into_list):
+ * fns.c (list_list_merge_into_array):
+ * fns.c (list_array_merge_into_array):
+ * fns.c (Fmerge):
+ * fns.c (list_sort):
+ * fns.c (array_sort):
+ * fns.c (FsortX):
+ * fns.c (syms_of_fns):
+ * lisp.h:
+ Move #'sort, #'merge to using the same test approach as is used in
+ the functions that take TEST, TEST-NOT and KEY arguments. This
+ allows us to avoid the Ffuncall() overhead when the most common
+ PREDICATE arguments are supplied, in particular #'< and
+ #'string-lessp.
+
+ * fontcolor-msw.c (sort_font_list_function):
+ * fontcolor-msw.c (mswindows_enumerate_fonts):
+ * dired.c:
+ * dired.c (Fdirectory_files):
+ * fileio.c:
+ * fileio.c (build_annotations):
+ * fileio.c (syms_of_fileio):
+ * keymap.c:
+ * keymap.c (keymap_submaps):
+ * keymap.c (map_keymap_sort_predicate):
+ * keymap.c (describe_map_sort_predicate):
+ * keymap.c (describe_map):
+ Change the various C predicates passed to list_sort () and
+ list_merge () to fit the new calling convention, returning
+ non-zero if the first argument is less than the second, zero
+ otherwise.
+
2011-01-30 Michael Sperber <mike(a)xemacs.org>
* redisplay.h:
diff -r 239193591765 -r 94bbd4792049 src/abbrev.c
--- a/src/abbrev.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/abbrev.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -524,7 +524,7 ＠＠
map_obarray (table, record_symbol, &symbols);
/* map_obarray (table, record_symbol, &closure); */
symbols = XCDR (symbols);
- symbols = list_sort (symbols, NULL, Qstring_lessp, Qidentity);
+ symbols = list_sort (symbols, check_string_lessp_nokey, Qnil, Qnil);
if (!NILP (readable))
{
diff -r 239193591765 -r 94bbd4792049 src/dired.c
--- a/src/dired.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/dired.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -181,7 +181,7 ＠＠
unbind_to (speccount); /* This will close the dir */
if (NILP (nosort))
- list = list_sort (Fnreverse (list), NULL, Qstring_lessp, Qidentity);
+ list = list_sort (Fnreverse (list), check_string_lessp_nokey, Qnil, Qnil);
RETURN_UNGCPRO (list);
}
diff -r 239193591765 -r 94bbd4792049 src/fileio.c
--- a/src/fileio.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fileio.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -132,8 +132,6 ＠＠
Lisp_Object Qauto_save_error;
Lisp_Object Qauto_saving;
-Lisp_Object Qcar_less_than_car;
-
Lisp_Object Qcompute_buffer_file_truename;
Lisp_Object QSin_expand_file_name;
＠＠ -3677,7 +3675,8 ＠＠
annotations = Qnil;
}
Flength (res); /* Check basic validity of return value */
- annotations = list_merge (annotations, res, NULL, Qlss, Qcar);
+ annotations = list_merge (annotations, res, check_lss_key_car, Qnil,
+ Qnil);
p = Fcdr (p);
}
＠＠ -3708,7 +3707,8 ＠＠
annotations = Qnil;
}
Flength (res);
- annotations = list_merge (annotations, res, NULL, Qlss, Qcar);
+ annotations = list_merge (annotations, res, check_lss_key_car, Qnil,
+ Qnil);
p = Fcdr (p);
}
＠＠ -4381,7 +4381,6 ＠＠
DEFSYMBOL (Qwrite_region);
DEFSYMBOL (Qverify_visited_file_modtime);
DEFSYMBOL (Qset_visited_file_modtime);
- DEFSYMBOL (Qcar_less_than_car); /* Vomitous! */
DEFSYMBOL (Qexcl);
DEFSYMBOL (Qauto_save_hook);
diff -r 239193591765 -r 94bbd4792049 src/fns.c
--- a/src/fns.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fns.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -63,7 +63,7 ＠＠
Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
Lisp_Object Qintersection, Qset_difference, Qnset_difference;
-Lisp_Object Qnunion, Qnintersection, Qsubsetp;
+Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qcar_less_than_car;
Lisp_Object Qbase64_conversion_error;
＠＠ -210,9 +210,6 ＠＠
/* Various test functions for #'member*, #'assoc* and the other functions
that take both TEST and KEY arguments. */
-typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
- Lisp_Object item, Lisp_Object elt);
-
static Boolint
check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
Lisp_Object item, Lisp_Object elt)
＠＠ -439,7 +436,84 ＠＠
return !NILP (elt1);
}
-
+
+static Boolint
+check_lss_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return bytecode_arithcompare (elt1, elt2) < 0;
+}
+
+static Boolint
+check_lss_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return bytecode_arithcompare (args[0], args[1]) < 0;
+}
+
+Boolint
+check_lss_key_car (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ struct gcpro gcpro1, gcpro2;
+
+ GCPRO2 (elt1, elt2);
+ elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
+ elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
+ UNGCPRO;
+
+ return bytecode_arithcompare (elt1, elt2) < 0;
+}
+
+Boolint
+check_string_lessp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return !NILP (Fstring_lessp (elt1, elt2));
+}
+
+static Boolint
+check_string_lessp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return !NILP (Fstring_lessp (args[0], args[1]));
+}
+
+static Boolint
+check_string_lessp_key_car (Lisp_Object UNUSED (test),
+ Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ struct gcpro gcpro1, gcpro2;
+
+ GCPRO2 (elt1, elt2);
+ elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
+ elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
+ UNGCPRO;
+
+ return !NILP (Fstring_lessp (elt1, elt2));
+}
+
static check_test_func_t
get_check_match_function_1 (Lisp_Object item,
Lisp_Object *test_inout, Lisp_Object test_not,
＠＠ -646,6 +720,72 ＠＠
test_not_unboundp_out, test_func_out);
}
+/* Given PREDICATE and KEY, return a C function pointer appropriate for use
+ in deciding whether one given elements of a sequence is less than
+ another. */
+
+static check_test_func_t
+get_merge_predicate (Lisp_Object predicate, Lisp_Object key)
+{
+ predicate = indirect_function (predicate, 1);
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+ else
+ {
+ key = indirect_function (key, 1);
+ if (EQ (key, XSYMBOL_FUNCTION (Qidentity)))
+ {
+ key = Qidentity;
+ }
+ }
+
+ if (EQ (key, Qidentity) && EQ (predicate,
+ XSYMBOL_FUNCTION (Qcar_less_than_car)))
+ {
+ key = XSYMBOL_FUNCTION (Qcar);
+ predicate = XSYMBOL_FUNCTION (Qlss);
+ }
+
+ if (EQ (predicate, XSYMBOL_FUNCTION (Qlss)))
+ {
+ if (EQ (key, Qidentity))
+ {
+ return check_lss_nokey;
+ }
+
+ if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
+ {
+ return check_lss_key_car;
+ }
+
+ return check_lss_key;
+ }
+
+ if (EQ (predicate, XSYMBOL_FUNCTION (Qstring_lessp)))
+ {
+ if (EQ (key, Qidentity))
+ {
+ return check_string_lessp_nokey;
+ }
+
+ if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
+ {
+ return check_string_lessp_key_car;
+ }
+
+ return check_string_lessp_key;
+ }
+
+ if (EQ (key, Qidentity))
+ {
+ return check_other_nokey;
+ }
+
+ return check_match_other_key;
+}
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
＠＠ -4694,58 +4834,10 ＠＠
return result;
}
-static Lisp_Object
-c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* We could use call2() and call3() here, but we're called O(nlogn) times
- for a sequence of length n, it make some sense to inline them. */
- args[0] = key_func;
- args[1] = obj1;
- args[2] = Qnil;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[1] = obj2;
- obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-static Lisp_Object
-c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object UNUSED (key_func))
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* This is (almost) the implementation of call2, it makes some sense to
- inline it here. */
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
Lisp_Object
list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Lisp_Object value;
Lisp_Object tail;
＠＠ -4762,15 +4854,8 ＠＠
tortoises[0] = org_l1;
tortoises[1] = org_l2;
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
- }
-
- /* It is sufficient to protect org_l1 and org_l2.
- When l1 and l2 are updated, we copy the new values
- back into the org_ vars. */
+ /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are
+ updated, we copy the new values back into the org_ vars. */
GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
gcpro5.nvars = 2;
＠＠ -4794,7 +4879,7 ＠＠
return value;
}
- if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
+ if (check_merge (predicate, key, Fcar (l2), Fcar (l1)) == 0)
{
tem = l1;
l1 = Fcdr (l1);
＠＠ -4856,9 +4941,8 ＠＠
array_merge (Lisp_Object *dest, Elemcount dest_len,
Lisp_Object *front, Elemcount front_len,
Lisp_Object *back, Elemcount back_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount ii, fronting, backing;
Lisp_Object *front_staging = front;
＠＠ -4920,8 +5004,8 ＠＠
return;
}
- if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
- predicate, key_func)))
+ if (check_merge (predicate, key, back_staging[backing],
+ front_staging[fronting]) == 0)
{
dest[ii] = front_staging[fronting];
++fronting;
＠＠ -4939,11 +5023,8 ＠＠
static Lisp_Object
list_array_merge_into_list (Lisp_Object list,
Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key,
Boolint reverse_order)
{
Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
＠＠ -4982,10 +5063,8 ＠＠
if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
+ check_merge (predicate, key, Fcar (list), array [array_index])
+ : !check_merge (predicate, key, array [array_index], Fcar (list)))
{
if (NILP (tail))
{
＠＠ -5031,11 +5110,8 ＠＠
static void
list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
Lisp_Object list_one, Lisp_Object list_two,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount output_index = 0;
＠＠ -5061,8 +5137,8 ＠＠
return;
}
- if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
- key_func)))
+ if (check_merge (predicate, key, Fcar (list_two), Fcar (list_one))
+ == 0)
{
output [output_index] = XCAR (list_one);
list_one = XCDR (list_one);
＠＠ -5083,11 +5159,8 ＠＠
list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
Lisp_Object list,
Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key,
Boolint reverse_order)
{
Elemcount output_index = 0, array_index = 0;
＠＠ -5121,10 +5194,8 ＠＠
}
if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
+ check_merge (predicate, key, Fcar (list), array [array_index]) :
+ !check_merge (predicate, key, array [array_index], Fcar (list)))
{
output [output_index] = XCAR (list);
list = XCDR (list);
＠＠ -5172,8 +5243,7 ＠＠
{
Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
predicate = args[3], result = Qnil;
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
+ check_test_func_t check_merge = NULL;
PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL);
＠＠ -5182,8 +5252,7 ＠＠
CHECK_KEY_ARGUMENT (key);
- c_predicate = EQ (key, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
+ check_merge = get_merge_predicate (predicate, key);
if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
{
＠＠ -5199,7 +5268,7 ＠＠
}
else if (CONSP (sequence_one) && CONSP (sequence_two))
{
- result = list_merge (sequence_one, sequence_two, c_predicate,
+ result = list_merge (sequence_one, sequence_two, check_merge,
predicate, key);
}
else
＠＠ -5241,8 +5310,7 ＠＠
result = list_array_merge_into_list (sequence_one,
array_storage, array_length,
- c_predicate,
- predicate, key,
+ check_merge, predicate, key,
reverse_order);
}
}
＠＠ -5306,8 +5374,7 ＠＠
{
list_list_merge_into_array (output + 1, output_len - 1,
sequence_one, sequence_two,
- c_predicate, predicate,
- key);
+ check_merge, predicate, key);
}
else if (LISTP (sequence_one))
{
＠＠ -5315,8 +5382,7 ＠＠
sequence_one,
sequence_two_storage,
sequence_two_len,
- c_predicate, predicate,
- key, 0);
+ check_merge, predicate, key, 0);
}
else if (LISTP (sequence_two))
{
＠＠ -5324,15 +5390,14 ＠＠
sequence_two,
sequence_one_storage,
sequence_one_len,
- c_predicate, predicate,
- key, 1);
+ check_merge, predicate, key, 1);
}
else
{
array_merge (output + 1, output_len - 1,
sequence_one_storage, sequence_one_len,
sequence_two_storage, sequence_two_len,
- c_predicate, predicate,
+ check_merge, predicate,
key);
}
＠＠ -5349,13 +5414,9 ＠＠
return result;
}
-/* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
- NOTE: This is backwards from the way qsort() works. */
-Lisp_Object
-list_sort (Lisp_Object list,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+Lisp_Object
+list_sort (Lisp_Object list, check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
Lisp_Object back, tem;
＠＠ -5365,29 +5426,22 ＠＠
if (XINT (len) < 2)
return list;
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey :
- c_merge_predicate_key;
- }
-
len = make_int (XINT (len) / 2 - 1);
tem = Fnthcdr (len, list);
back = Fcdr (tem);
Fsetcdr (tem, Qnil);
- GCPRO4 (front, back, predicate, key_func);
- front = list_sort (front, c_predicate, predicate, key_func);
- back = list_sort (back, c_predicate, predicate, key_func);
-
- RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func));
+ GCPRO4 (front, back, predicate, key);
+ front = list_sort (front, check_merge, predicate, key);
+ back = list_sort (back, check_merge, predicate, key);
+
+ RETURN_UNGCPRO (list_merge (front, back, check_merge, predicate, key));
}
static void
array_sort (Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount split;
＠＠ -5396,11 +5450,11 ＠＠
split = array_len / 2;
- array_sort (array, split, c_predicate, predicate, key_func);
- array_sort (array + split, array_len - split, c_predicate, predicate,
- key_func);
+ array_sort (array, split, check_merge, predicate, key);
+ array_sort (array + split, array_len - split, check_merge, predicate,
+ key);
array_merge (array, array_len, array, split, array + split,
- array_len - split, c_predicate, predicate, key_func);
+ array_len - split, check_merge, predicate, key);
}
DEFUN ("sort*", FsortX, 2, MANY, 0, /*
＠＠ -5423,8 +5477,7 ＠＠
{
Lisp_Object sequence = args[0], predicate = args[1];
Lisp_Object *sequence_carray;
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
+ check_test_func_t check_merge = NULL;
Elemcount sequence_len, i;
PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL);
＠＠ -5433,17 +5486,16 ＠＠
CHECK_KEY_ARGUMENT (key);
- c_predicate = EQ (key, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
+ check_merge = get_merge_predicate (predicate, key);
if (LISTP (sequence))
{
- sequence = list_sort (sequence, c_predicate, predicate, key);
+ sequence = list_sort (sequence, check_merge, predicate, key);
}
else if (VECTORP (sequence))
{
array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
- c_predicate, predicate, key);
+ check_merge, predicate, key);
}
else if (STRINGP (sequence))
{
＠＠ -5454,7 +5506,7 ＠＠
STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
/* No GCPRO necessary, characters are immediate. */
- array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
+ array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
strdata = XSTRING_DATA (sequence);
＠＠ -5476,7 +5528,7 ＠＠
BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
/* No GCPRO necessary, bits are immediate. */
- array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
+ array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
for (i = 0; i < sequence_len; ++i)
{
＠＠ -11698,6 +11750,7 ＠＠
DEFSYMBOL (Qintersection);
DEFSYMBOL (Qnintersection);
DEFSYMBOL (Qsubsetp);
+ DEFSYMBOL (Qcar_less_than_car);
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
DEFSYMBOL (Qnunion);
diff -r 239193591765 -r 94bbd4792049 src/fontcolor-msw.c
--- a/src/fontcolor-msw.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fontcolor-msw.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -1198,10 +1198,9 ＠＠
"family::::charset" for TrueType fonts, "family::size::charset"
otherwise. */
-static Lisp_Object
-sort_font_list_function (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object UNUSED (pred),
- Lisp_Object UNUSED (key_function))
+static Boolint
+sort_font_list_function (Lisp_Object UNUSED (pred), Lisp_Object UNUSED (key),
+ Lisp_Object obj1, Lisp_Object obj2)
{
Ibyte *font1, *font2;
Ibyte *c1, *c2;
＠＠ -1215,16 +1214,16 ＠＠
5. Courier New over other families.
*/
- /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
- NOTE: This is backwards from the way qsort() works. */
+ /* The sort function should return non-zero if OBJ1 < OBJ2, zero
+ otherwise. */
t1 = !NILP (XCDR (obj1));
t2 = !NILP (XCDR (obj2));
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
font1 = XSTRING_DATA (XCAR (obj1));
font2 = XSTRING_DATA (XCAR (obj2));
＠＠ -1236,9 +1235,9 ＠＠
t2 = !qxestrcasecmp_ascii (c2 + 1, "western");
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
c1 -= 2;
c2 -= 2;
＠＠ -1246,9 +1245,9 ＠＠
t2 = *c2 == ':';
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
if (!t1 && !t2)
{
＠＠ -1261,25 +1260,25 ＠＠
t2 = qxeatoi (c2 + 1) - 10;
if (abs (t1) < abs (t2))
- return Qt;
+ return 1;
else if (abs (t2) < abs (t1))
- return Qnil;
+ return 0;
else if (t1 < t2)
/* Prefer a smaller font over a larger one just as far away
because the smaller one won't upset the total line height if it's
just a few chars. */
- return Qt;
+ return 1;
}
t1 = !qxestrncasecmp_ascii (font1, "courier new:", 12);
t2 = !qxestrncasecmp_ascii (font2, "courier new:", 12);
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
- return Qnil;
+ return 0;
}
/*
diff -r 239193591765 -r 94bbd4792049 src/keymap.c
--- a/src/keymap.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/keymap.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -737,10 +737,9 ＠＠
return 0;
}
-static Lisp_Object map_keymap_sort_predicate (Lisp_Object obj1,
- Lisp_Object obj2,
- Lisp_Object pred,
- Lisp_Object key_func);
+static Boolint map_keymap_sort_predicate (Lisp_Object pred, Lisp_Object key,
+ Lisp_Object obj1, Lisp_Object obj2);
+
static Lisp_Object
keymap_submaps (Lisp_Object keymap)
＠＠ -764,7 +763,7 ＠＠
&keymap_submaps_closure);
/* keep it sorted so that the result of accessible-keymaps is ordered */
k->sub_maps_cache = list_sort (result, map_keymap_sort_predicate,
- Qnil, Qidentity);
+ Qnil, Qnil);
UNGCPRO;
}
return k->sub_maps_cache;
＠＠ -2896,10 +2895,9 ＠＠
/* used by map_keymap_sorted(), describe_map_sort_predicate(),
and keymap_submaps().
*/
-static Lisp_Object
-map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object UNUSED (pred),
- Lisp_Object UNUSED (key_func))
+static Boolint
+map_keymap_sort_predicate (Lisp_Object UNUSED (pred), Lisp_Object UNUSED (key),
+ Lisp_Object obj1, Lisp_Object obj2)
{
/* obj1 and obj2 are conses with keysyms in their cars. Cdrs are ignored.
*/
＠＠ -2912,12 +2910,12 ＠＠
obj2 = XCAR (obj2);
if (EQ (obj1, obj2))
- return Qnil;
+ return 0;
bit1 = MODIFIER_HASH_KEY_BITS (obj1);
bit2 = MODIFIER_HASH_KEY_BITS (obj2);
- /* If either is a symbol with a Qcharacter_of_keysym property, then sort it by
- that code instead of alphabetically.
+ /* If either is a symbol with a Qcharacter_of_keysym property, then sort
+ it by that code instead of alphabetically.
*/
if (! bit1 && SYMBOLP (obj1))
{
＠＠ -2942,7 +2940,7 ＠＠
/* all symbols (non-ASCIIs) come after characters (ASCIIs) */
if (XTYPE (obj1) != XTYPE (obj2))
- return SYMBOLP (obj2) ? Qt : Qnil;
+ return SYMBOLP (obj2);
if (! bit1 && CHARP (obj1)) /* they're both ASCII */
{
＠＠ -2950,24 +2948,24 ＠＠
int o2 = XCHAR (obj2);
if (o1 == o2 && /* If one started out as a symbol and the */
sym1_p != sym2_p) /* other didn't, the symbol comes last. */
- return sym2_p ? Qt : Qnil;
-
- return o1 < o2 ? Qt : Qnil; /* else just compare them */
+ return sym2_p;
+
+ return o1 < o2; /* else just compare them */
}
/* else they're both symbols. If they're both buckys, then order them. */
if (bit1 && bit2)
- return bit1 < bit2 ? Qt : Qnil;
+ return bit1 < bit2;
/* if only one is a bucky, then it comes later */
if (bit1 || bit2)
- return bit2 ? Qt : Qnil;
+ return bit2;
/* otherwise, string-sort them. */
{
Ibyte *s1 = XSTRING_DATA (XSYMBOL (obj1)->name);
Ibyte *s2 = XSTRING_DATA (XSYMBOL (obj2)->name);
- return 0 > qxestrcmp (s1, s2) ? Qt : Qnil;
+ return 0 > qxestrcmp (s1, s2);
}
}
＠＠ -4087,10 +4085,10 ＠＠
*(closure->list));
}
-
-static Lisp_Object
-describe_map_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
+static Boolint
+describe_map_sort_predicate (Lisp_Object pred, Lisp_Object key_func,
+ Lisp_Object obj1, Lisp_Object obj2)
+
{
/* obj1 and obj2 are conses of the form
( ( <keysym> . <modifiers> ) . <binding> )
＠＠ -4102,7 +4100,7 ＠＠
bit1 = XINT (XCDR (obj1));
bit2 = XINT (XCDR (obj2));
if (bit1 != bit2)
- return bit1 < bit2 ? Qt : Qnil;
+ return bit1 < bit2;
else
return map_keymap_sort_predicate (obj1, obj2, pred, key_func);
}
＠＠ -4212,7 +4210,7 ＠＠
if (!NILP (list))
{
- list = list_sort (list, describe_map_sort_predicate, Qnil, Qidentity);
+ list = list_sort (list, describe_map_sort_predicate, Qnil, Qnil);
buffer_insert_ascstring (buf, "\n");
while (!NILP (list))
{
diff -r 239193591765 -r 94bbd4792049 src/lisp.h
--- a/src/lisp.h Sun Jan 30 14:27:31 2011 +0100
+++ b/src/lisp.h Sat Feb 05 12:04:34 2011 +0000
＠＠ -5248,15 +5248,19 ＠＠
EXFUN (Fsubseq, 3);
EXFUN (Fvalid_plist_p, 1);
+extern Boolint check_lss_key_car (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object);
+extern Boolint check_string_lessp_nokey (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt);
+
Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object o1,
- Lisp_Object o2,
- Lisp_Object pred,
- Lisp_Object keyf),
+ check_test_func_t check_merge,
Lisp_Object predicate, Lisp_Object key_func);
Lisp_Object list_sort (Lisp_Object list,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
+ check_test_func_t check_merge,
Lisp_Object predicate, Lisp_Object key_func);
void bump_string_modiff (Lisp_Object);
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Have #'sort*, #'merge use the same test approach as functions from cl-seq.el
13 years, 10 months
Aidan Kehoe
Aidan Kehoe
changeset: 5350:94bbd4792049
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sat Feb 05 12:04:34 2011 +0000
files: src/ChangeLog src/abbrev.c src/dired.c src/fileio.c src/fns.c src/fontcolor-msw.c src/keymap.c src/lisp.h
description:
Have #'sort*, #'merge use the same test approach as functions from cl-seq.el
2011-02-05 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c:
* fns.c (check_lss_key, check_lss_key_car): New.
* fns.c (check_string_lessp_key check_string_lessp_key_car): New.
* fns.c (get_merge_predicate): New.
* fns.c (list_merge):
* fns.c (array_merge):
* fns.c (list_array_merge_into_list):
* fns.c (list_list_merge_into_array):
* fns.c (list_array_merge_into_array):
* fns.c (Fmerge):
* fns.c (list_sort):
* fns.c (array_sort):
* fns.c (FsortX):
* fns.c (syms_of_fns):
* lisp.h:
Move #'sort, #'merge to using the same test approach as is used in
the functions that take TEST, TEST-NOT and KEY arguments. This
allows us to avoid the Ffuncall() overhead when the most common
PREDICATE arguments are supplied, in particular #'< and
#'string-lessp.
* fontcolor-msw.c (sort_font_list_function):
* fontcolor-msw.c (mswindows_enumerate_fonts):
* dired.c:
* dired.c (Fdirectory_files):
* fileio.c:
* fileio.c (build_annotations):
* fileio.c (syms_of_fileio):
* keymap.c:
* keymap.c (keymap_submaps):
* keymap.c (map_keymap_sort_predicate):
* keymap.c (describe_map_sort_predicate):
* keymap.c (describe_map):
Change the various C predicates passed to list_sort () and
list_merge () to fit the new calling convention, returning
non-zero if the first argument is less than the second, zero
otherwise.
diff -r 239193591765 -r 94bbd4792049 src/ChangeLog
--- a/src/ChangeLog Sun Jan 30 14:27:31 2011 +0100
+++ b/src/ChangeLog Sat Feb 05 12:04:34 2011 +0000
＠＠ -1,3 +1,43 ＠＠
+2011-02-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c:
+ * fns.c (check_lss_key, check_lss_key_car): New.
+ * fns.c (check_string_lessp_key check_string_lessp_key_car): New.
+ * fns.c (get_merge_predicate): New.
+ * fns.c (list_merge):
+ * fns.c (array_merge):
+ * fns.c (list_array_merge_into_list):
+ * fns.c (list_list_merge_into_array):
+ * fns.c (list_array_merge_into_array):
+ * fns.c (Fmerge):
+ * fns.c (list_sort):
+ * fns.c (array_sort):
+ * fns.c (FsortX):
+ * fns.c (syms_of_fns):
+ * lisp.h:
+ Move #'sort, #'merge to using the same test approach as is used in
+ the functions that take TEST, TEST-NOT and KEY arguments. This
+ allows us to avoid the Ffuncall() overhead when the most common
+ PREDICATE arguments are supplied, in particular #'< and
+ #'string-lessp.
+
+ * fontcolor-msw.c (sort_font_list_function):
+ * fontcolor-msw.c (mswindows_enumerate_fonts):
+ * dired.c:
+ * dired.c (Fdirectory_files):
+ * fileio.c:
+ * fileio.c (build_annotations):
+ * fileio.c (syms_of_fileio):
+ * keymap.c:
+ * keymap.c (keymap_submaps):
+ * keymap.c (map_keymap_sort_predicate):
+ * keymap.c (describe_map_sort_predicate):
+ * keymap.c (describe_map):
+ Change the various C predicates passed to list_sort () and
+ list_merge () to fit the new calling convention, returning
+ non-zero if the first argument is less than the second, zero
+ otherwise.
+
2011-01-30 Michael Sperber <mike(a)xemacs.org>
* redisplay.h:
diff -r 239193591765 -r 94bbd4792049 src/abbrev.c
--- a/src/abbrev.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/abbrev.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -524,7 +524,7 ＠＠
map_obarray (table, record_symbol, &symbols);
/* map_obarray (table, record_symbol, &closure); */
symbols = XCDR (symbols);
- symbols = list_sort (symbols, NULL, Qstring_lessp, Qidentity);
+ symbols = list_sort (symbols, check_string_lessp_nokey, Qnil, Qnil);
if (!NILP (readable))
{
diff -r 239193591765 -r 94bbd4792049 src/dired.c
--- a/src/dired.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/dired.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -181,7 +181,7 ＠＠
unbind_to (speccount); /* This will close the dir */
if (NILP (nosort))
- list = list_sort (Fnreverse (list), NULL, Qstring_lessp, Qidentity);
+ list = list_sort (Fnreverse (list), check_string_lessp_nokey, Qnil, Qnil);
RETURN_UNGCPRO (list);
}
diff -r 239193591765 -r 94bbd4792049 src/fileio.c
--- a/src/fileio.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fileio.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -131,8 +131,6 ＠＠
Lisp_Object Qauto_save_hook;
Lisp_Object Qauto_save_error;
Lisp_Object Qauto_saving;
-
-Lisp_Object Qcar_less_than_car;
Lisp_Object Qcompute_buffer_file_truename;
＠＠ -3677,7 +3675,8 ＠＠
annotations = Qnil;
}
Flength (res); /* Check basic validity of return value */
- annotations = list_merge (annotations, res, NULL, Qlss, Qcar);
+ annotations = list_merge (annotations, res, check_lss_key_car, Qnil,
+ Qnil);
p = Fcdr (p);
}
＠＠ -3708,7 +3707,8 ＠＠
annotations = Qnil;
}
Flength (res);
- annotations = list_merge (annotations, res, NULL, Qlss, Qcar);
+ annotations = list_merge (annotations, res, check_lss_key_car, Qnil,
+ Qnil);
p = Fcdr (p);
}
＠＠ -4381,7 +4381,6 ＠＠
DEFSYMBOL (Qwrite_region);
DEFSYMBOL (Qverify_visited_file_modtime);
DEFSYMBOL (Qset_visited_file_modtime);
- DEFSYMBOL (Qcar_less_than_car); /* Vomitous! */
DEFSYMBOL (Qexcl);
DEFSYMBOL (Qauto_save_hook);
diff -r 239193591765 -r 94bbd4792049 src/fns.c
--- a/src/fns.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fns.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -63,7 +63,7 ＠＠
Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
Lisp_Object Qintersection, Qset_difference, Qnset_difference;
-Lisp_Object Qnunion, Qnintersection, Qsubsetp;
+Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qcar_less_than_car;
Lisp_Object Qbase64_conversion_error;
＠＠ -210,9 +210,6 ＠＠
/* Various test functions for #'member*, #'assoc* and the other functions
that take both TEST and KEY arguments. */
-typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
- Lisp_Object item, Lisp_Object elt);
-
static Boolint
check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
Lisp_Object item, Lisp_Object elt)
＠＠ -439,7 +436,84 ＠＠
return !NILP (elt1);
}
-
+
+static Boolint
+check_lss_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return bytecode_arithcompare (elt1, elt2) < 0;
+}
+
+static Boolint
+check_lss_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return bytecode_arithcompare (args[0], args[1]) < 0;
+}
+
+Boolint
+check_lss_key_car (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ struct gcpro gcpro1, gcpro2;
+
+ GCPRO2 (elt1, elt2);
+ elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
+ elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
+ UNGCPRO;
+
+ return bytecode_arithcompare (elt1, elt2) < 0;
+}
+
+Boolint
+check_string_lessp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ return !NILP (Fstring_lessp (elt1, elt2));
+}
+
+static Boolint
+check_string_lessp_key (Lisp_Object UNUSED (test), Lisp_Object key,
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ Lisp_Object args[] = { key, elt1, elt2 };
+ struct gcpro gcpro1;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = countof (args);
+ args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
+ args[1] = key;
+ args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
+ UNGCPRO;
+
+ return !NILP (Fstring_lessp (args[0], args[1]));
+}
+
+static Boolint
+check_string_lessp_key_car (Lisp_Object UNUSED (test),
+ Lisp_Object UNUSED (key),
+ Lisp_Object elt1, Lisp_Object elt2)
+{
+ struct gcpro gcpro1, gcpro2;
+
+ GCPRO2 (elt1, elt2);
+ elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
+ elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
+ UNGCPRO;
+
+ return !NILP (Fstring_lessp (elt1, elt2));
+}
+
static check_test_func_t
get_check_match_function_1 (Lisp_Object item,
Lisp_Object *test_inout, Lisp_Object test_not,
＠＠ -646,6 +720,72 ＠＠
test_not_unboundp_out, test_func_out);
}
+/* Given PREDICATE and KEY, return a C function pointer appropriate for use
+ in deciding whether one given elements of a sequence is less than
+ another. */
+
+static check_test_func_t
+get_merge_predicate (Lisp_Object predicate, Lisp_Object key)
+{
+ predicate = indirect_function (predicate, 1);
+
+ if (NILP (key))
+ {
+ key = Qidentity;
+ }
+ else
+ {
+ key = indirect_function (key, 1);
+ if (EQ (key, XSYMBOL_FUNCTION (Qidentity)))
+ {
+ key = Qidentity;
+ }
+ }
+
+ if (EQ (key, Qidentity) && EQ (predicate,
+ XSYMBOL_FUNCTION (Qcar_less_than_car)))
+ {
+ key = XSYMBOL_FUNCTION (Qcar);
+ predicate = XSYMBOL_FUNCTION (Qlss);
+ }
+
+ if (EQ (predicate, XSYMBOL_FUNCTION (Qlss)))
+ {
+ if (EQ (key, Qidentity))
+ {
+ return check_lss_nokey;
+ }
+
+ if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
+ {
+ return check_lss_key_car;
+ }
+
+ return check_lss_key;
+ }
+
+ if (EQ (predicate, XSYMBOL_FUNCTION (Qstring_lessp)))
+ {
+ if (EQ (key, Qidentity))
+ {
+ return check_string_lessp_nokey;
+ }
+
+ if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
+ {
+ return check_string_lessp_key_car;
+ }
+
+ return check_string_lessp_key;
+ }
+
+ if (EQ (key, Qidentity))
+ {
+ return check_other_nokey;
+ }
+
+ return check_match_other_key;
+}
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
＠＠ -4694,58 +4834,10 ＠＠
return result;
}
-static Lisp_Object
-c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* We could use call2() and call3() here, but we're called O(nlogn) times
- for a sequence of length n, it make some sense to inline them. */
- args[0] = key_func;
- args[1] = obj1;
- args[2] = Qnil;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[1] = obj2;
- obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
-
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
-static Lisp_Object
-c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object UNUSED (key_func))
-{
- struct gcpro gcpro1;
- Lisp_Object args[3];
-
- /* This is (almost) the implementation of call2, it makes some sense to
- inline it here. */
- args[0] = pred;
- args[1] = obj1;
- args[2] = obj2;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = countof (args);
-
- RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
-}
-
Lisp_Object
list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Lisp_Object value;
Lisp_Object tail;
＠＠ -4762,15 +4854,8 ＠＠
tortoises[0] = org_l1;
tortoises[1] = org_l2;
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
- }
-
- /* It is sufficient to protect org_l1 and org_l2.
- When l1 and l2 are updated, we copy the new values
- back into the org_ vars. */
+ /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are
+ updated, we copy the new values back into the org_ vars. */
GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
gcpro5.nvars = 2;
＠＠ -4794,7 +4879,7 ＠＠
return value;
}
- if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
+ if (check_merge (predicate, key, Fcar (l2), Fcar (l1)) == 0)
{
tem = l1;
l1 = Fcdr (l1);
＠＠ -4856,9 +4941,8 ＠＠
array_merge (Lisp_Object *dest, Elemcount dest_len,
Lisp_Object *front, Elemcount front_len,
Lisp_Object *back, Elemcount back_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount ii, fronting, backing;
Lisp_Object *front_staging = front;
＠＠ -4920,8 +5004,8 ＠＠
return;
}
- if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
- predicate, key_func)))
+ if (check_merge (predicate, key, back_staging[backing],
+ front_staging[fronting]) == 0)
{
dest[ii] = front_staging[fronting];
++fronting;
＠＠ -4939,11 +5023,8 ＠＠
static Lisp_Object
list_array_merge_into_list (Lisp_Object list,
Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key,
Boolint reverse_order)
{
Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
＠＠ -4982,10 +5063,8 ＠＠
if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
+ check_merge (predicate, key, Fcar (list), array [array_index])
+ : !check_merge (predicate, key, array [array_index], Fcar (list)))
{
if (NILP (tail))
{
＠＠ -5031,11 +5110,8 ＠＠
static void
list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
Lisp_Object list_one, Lisp_Object list_two,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount output_index = 0;
＠＠ -5061,8 +5137,8 ＠＠
return;
}
- if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
- key_func)))
+ if (check_merge (predicate, key, Fcar (list_two), Fcar (list_one))
+ == 0)
{
output [output_index] = XCAR (list_one);
list_one = XCDR (list_one);
＠＠ -5083,11 +5159,8 ＠＠
list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
Lisp_Object list,
Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object,
- Lisp_Object,
- Lisp_Object,
- Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func,
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key,
Boolint reverse_order)
{
Elemcount output_index = 0, array_index = 0;
＠＠ -5121,10 +5194,8 ＠＠
}
if (reverse_order ?
- !NILP (c_predicate (Fcar (list), array [array_index], predicate,
- key_func)) :
- NILP (c_predicate (array [array_index], Fcar (list), predicate,
- key_func)))
+ check_merge (predicate, key, Fcar (list), array [array_index]) :
+ !check_merge (predicate, key, array [array_index], Fcar (list)))
{
output [output_index] = XCAR (list);
list = XCDR (list);
＠＠ -5172,8 +5243,7 ＠＠
{
Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
predicate = args[3], result = Qnil;
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
+ check_test_func_t check_merge = NULL;
PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL);
＠＠ -5182,8 +5252,7 ＠＠
CHECK_KEY_ARGUMENT (key);
- c_predicate = EQ (key, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
+ check_merge = get_merge_predicate (predicate, key);
if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
{
＠＠ -5199,7 +5268,7 ＠＠
}
else if (CONSP (sequence_one) && CONSP (sequence_two))
{
- result = list_merge (sequence_one, sequence_two, c_predicate,
+ result = list_merge (sequence_one, sequence_two, check_merge,
predicate, key);
}
else
＠＠ -5241,8 +5310,7 ＠＠
result = list_array_merge_into_list (sequence_one,
array_storage, array_length,
- c_predicate,
- predicate, key,
+ check_merge, predicate, key,
reverse_order);
}
}
＠＠ -5306,8 +5374,7 ＠＠
{
list_list_merge_into_array (output + 1, output_len - 1,
sequence_one, sequence_two,
- c_predicate, predicate,
- key);
+ check_merge, predicate, key);
}
else if (LISTP (sequence_one))
{
＠＠ -5315,8 +5382,7 ＠＠
sequence_one,
sequence_two_storage,
sequence_two_len,
- c_predicate, predicate,
- key, 0);
+ check_merge, predicate, key, 0);
}
else if (LISTP (sequence_two))
{
＠＠ -5324,15 +5390,14 ＠＠
sequence_two,
sequence_one_storage,
sequence_one_len,
- c_predicate, predicate,
- key, 1);
+ check_merge, predicate, key, 1);
}
else
{
array_merge (output + 1, output_len - 1,
sequence_one_storage, sequence_one_len,
sequence_two_storage, sequence_two_len,
- c_predicate, predicate,
+ check_merge, predicate,
key);
}
＠＠ -5349,13 +5414,9 ＠＠
return result;
}
-/* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
- NOTE: This is backwards from the way qsort() works. */
-Lisp_Object
-list_sort (Lisp_Object list,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+Lisp_Object
+list_sort (Lisp_Object list, check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
Lisp_Object back, tem;
＠＠ -5365,29 +5426,22 ＠＠
if (XINT (len) < 2)
return list;
- if (NULL == c_predicate)
- {
- c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey :
- c_merge_predicate_key;
- }
-
len = make_int (XINT (len) / 2 - 1);
tem = Fnthcdr (len, list);
back = Fcdr (tem);
Fsetcdr (tem, Qnil);
- GCPRO4 (front, back, predicate, key_func);
- front = list_sort (front, c_predicate, predicate, key_func);
- back = list_sort (back, c_predicate, predicate, key_func);
-
- RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func));
+ GCPRO4 (front, back, predicate, key);
+ front = list_sort (front, check_merge, predicate, key);
+ back = list_sort (back, check_merge, predicate, key);
+
+ RETURN_UNGCPRO (list_merge (front, back, check_merge, predicate, key));
}
static void
array_sort (Lisp_Object *array, Elemcount array_len,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
- Lisp_Object predicate, Lisp_Object key_func)
+ check_test_func_t check_merge,
+ Lisp_Object predicate, Lisp_Object key)
{
Elemcount split;
＠＠ -5396,11 +5450,11 ＠＠
split = array_len / 2;
- array_sort (array, split, c_predicate, predicate, key_func);
- array_sort (array + split, array_len - split, c_predicate, predicate,
- key_func);
+ array_sort (array, split, check_merge, predicate, key);
+ array_sort (array + split, array_len - split, check_merge, predicate,
+ key);
array_merge (array, array_len, array, split, array + split,
- array_len - split, c_predicate, predicate, key_func);
+ array_len - split, check_merge, predicate, key);
}
DEFUN ("sort*", FsortX, 2, MANY, 0, /*
＠＠ -5423,8 +5477,7 ＠＠
{
Lisp_Object sequence = args[0], predicate = args[1];
Lisp_Object *sequence_carray;
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object);
+ check_test_func_t check_merge = NULL;
Elemcount sequence_len, i;
PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL);
＠＠ -5433,17 +5486,16 ＠＠
CHECK_KEY_ARGUMENT (key);
- c_predicate = EQ (key, Qidentity) ?
- c_merge_predicate_nokey : c_merge_predicate_key;
+ check_merge = get_merge_predicate (predicate, key);
if (LISTP (sequence))
{
- sequence = list_sort (sequence, c_predicate, predicate, key);
+ sequence = list_sort (sequence, check_merge, predicate, key);
}
else if (VECTORP (sequence))
{
array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
- c_predicate, predicate, key);
+ check_merge, predicate, key);
}
else if (STRINGP (sequence))
{
＠＠ -5454,7 +5506,7 ＠＠
STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
/* No GCPRO necessary, characters are immediate. */
- array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
+ array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
strdata = XSTRING_DATA (sequence);
＠＠ -5476,7 +5528,7 ＠＠
BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
/* No GCPRO necessary, bits are immediate. */
- array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
+ array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
for (i = 0; i < sequence_len; ++i)
{
＠＠ -11698,6 +11750,7 ＠＠
DEFSYMBOL (Qintersection);
DEFSYMBOL (Qnintersection);
DEFSYMBOL (Qsubsetp);
+ DEFSYMBOL (Qcar_less_than_car);
DEFSYMBOL (Qset_difference);
DEFSYMBOL (Qnset_difference);
DEFSYMBOL (Qnunion);
diff -r 239193591765 -r 94bbd4792049 src/fontcolor-msw.c
--- a/src/fontcolor-msw.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/fontcolor-msw.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -1198,10 +1198,9 ＠＠
"family::::charset" for TrueType fonts, "family::size::charset"
otherwise. */
-static Lisp_Object
-sort_font_list_function (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object UNUSED (pred),
- Lisp_Object UNUSED (key_function))
+static Boolint
+sort_font_list_function (Lisp_Object UNUSED (pred), Lisp_Object UNUSED (key),
+ Lisp_Object obj1, Lisp_Object obj2)
{
Ibyte *font1, *font2;
Ibyte *c1, *c2;
＠＠ -1215,16 +1214,16 ＠＠
5. Courier New over other families.
*/
- /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
- NOTE: This is backwards from the way qsort() works. */
+ /* The sort function should return non-zero if OBJ1 < OBJ2, zero
+ otherwise. */
t1 = !NILP (XCDR (obj1));
t2 = !NILP (XCDR (obj2));
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
font1 = XSTRING_DATA (XCAR (obj1));
font2 = XSTRING_DATA (XCAR (obj2));
＠＠ -1236,9 +1235,9 ＠＠
t2 = !qxestrcasecmp_ascii (c2 + 1, "western");
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
c1 -= 2;
c2 -= 2;
＠＠ -1246,9 +1245,9 ＠＠
t2 = *c2 == ':';
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
if (!t1 && !t2)
{
＠＠ -1261,25 +1260,25 ＠＠
t2 = qxeatoi (c2 + 1) - 10;
if (abs (t1) < abs (t2))
- return Qt;
+ return 1;
else if (abs (t2) < abs (t1))
- return Qnil;
+ return 0;
else if (t1 < t2)
/* Prefer a smaller font over a larger one just as far away
because the smaller one won't upset the total line height if it's
just a few chars. */
- return Qt;
+ return 1;
}
t1 = !qxestrncasecmp_ascii (font1, "courier new:", 12);
t2 = !qxestrncasecmp_ascii (font2, "courier new:", 12);
if (t1 && !t2)
- return Qt;
+ return 1;
if (t2 && !t1)
- return Qnil;
+ return 0;
- return Qnil;
+ return 0;
}
/*
diff -r 239193591765 -r 94bbd4792049 src/keymap.c
--- a/src/keymap.c Sun Jan 30 14:27:31 2011 +0100
+++ b/src/keymap.c Sat Feb 05 12:04:34 2011 +0000
＠＠ -737,10 +737,9 ＠＠
return 0;
}
-static Lisp_Object map_keymap_sort_predicate (Lisp_Object obj1,
- Lisp_Object obj2,
- Lisp_Object pred,
- Lisp_Object key_func);
+static Boolint map_keymap_sort_predicate (Lisp_Object pred, Lisp_Object key,
+ Lisp_Object obj1, Lisp_Object obj2);
+
static Lisp_Object
keymap_submaps (Lisp_Object keymap)
＠＠ -764,7 +763,7 ＠＠
&keymap_submaps_closure);
/* keep it sorted so that the result of accessible-keymaps is ordered */
k->sub_maps_cache = list_sort (result, map_keymap_sort_predicate,
- Qnil, Qidentity);
+ Qnil, Qnil);
UNGCPRO;
}
return k->sub_maps_cache;
＠＠ -2896,10 +2895,9 ＠＠
/* used by map_keymap_sorted(), describe_map_sort_predicate(),
and keymap_submaps().
*/
-static Lisp_Object
-map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object UNUSED (pred),
- Lisp_Object UNUSED (key_func))
+static Boolint
+map_keymap_sort_predicate (Lisp_Object UNUSED (pred), Lisp_Object UNUSED (key),
+ Lisp_Object obj1, Lisp_Object obj2)
{
/* obj1 and obj2 are conses with keysyms in their cars. Cdrs are ignored.
*/
＠＠ -2912,12 +2910,12 ＠＠
obj2 = XCAR (obj2);
if (EQ (obj1, obj2))
- return Qnil;
+ return 0;
bit1 = MODIFIER_HASH_KEY_BITS (obj1);
bit2 = MODIFIER_HASH_KEY_BITS (obj2);
- /* If either is a symbol with a Qcharacter_of_keysym property, then sort it by
- that code instead of alphabetically.
+ /* If either is a symbol with a Qcharacter_of_keysym property, then sort
+ it by that code instead of alphabetically.
*/
if (! bit1 && SYMBOLP (obj1))
{
＠＠ -2942,7 +2940,7 ＠＠
/* all symbols (non-ASCIIs) come after characters (ASCIIs) */
if (XTYPE (obj1) != XTYPE (obj2))
- return SYMBOLP (obj2) ? Qt : Qnil;
+ return SYMBOLP (obj2);
if (! bit1 && CHARP (obj1)) /* they're both ASCII */
{
＠＠ -2950,24 +2948,24 ＠＠
int o2 = XCHAR (obj2);
if (o1 == o2 && /* If one started out as a symbol and the */
sym1_p != sym2_p) /* other didn't, the symbol comes last. */
- return sym2_p ? Qt : Qnil;
-
- return o1 < o2 ? Qt : Qnil; /* else just compare them */
+ return sym2_p;
+
+ return o1 < o2; /* else just compare them */
}
/* else they're both symbols. If they're both buckys, then order them. */
if (bit1 && bit2)
- return bit1 < bit2 ? Qt : Qnil;
+ return bit1 < bit2;
/* if only one is a bucky, then it comes later */
if (bit1 || bit2)
- return bit2 ? Qt : Qnil;
+ return bit2;
/* otherwise, string-sort them. */
{
Ibyte *s1 = XSTRING_DATA (XSYMBOL (obj1)->name);
Ibyte *s2 = XSTRING_DATA (XSYMBOL (obj2)->name);
- return 0 > qxestrcmp (s1, s2) ? Qt : Qnil;
+ return 0 > qxestrcmp (s1, s2);
}
}
＠＠ -4087,10 +4085,10 ＠＠
*(closure->list));
}
-
-static Lisp_Object
-describe_map_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
- Lisp_Object pred, Lisp_Object key_func)
+static Boolint
+describe_map_sort_predicate (Lisp_Object pred, Lisp_Object key_func,
+ Lisp_Object obj1, Lisp_Object obj2)
+
{
/* obj1 and obj2 are conses of the form
( ( <keysym> . <modifiers> ) . <binding> )
＠＠ -4102,7 +4100,7 ＠＠
bit1 = XINT (XCDR (obj1));
bit2 = XINT (XCDR (obj2));
if (bit1 != bit2)
- return bit1 < bit2 ? Qt : Qnil;
+ return bit1 < bit2;
else
return map_keymap_sort_predicate (obj1, obj2, pred, key_func);
}
＠＠ -4212,7 +4210,7 ＠＠
if (!NILP (list))
{
- list = list_sort (list, describe_map_sort_predicate, Qnil, Qidentity);
+ list = list_sort (list, describe_map_sort_predicate, Qnil, Qnil);
buffer_insert_ascstring (buf, "\n");
while (!NILP (list))
{
diff -r 239193591765 -r 94bbd4792049 src/lisp.h
--- a/src/lisp.h Sun Jan 30 14:27:31 2011 +0100
+++ b/src/lisp.h Sat Feb 05 12:04:34 2011 +0000
＠＠ -5248,15 +5248,19 ＠＠
EXFUN (Fsubseq, 3);
EXFUN (Fvalid_plist_p, 1);
+extern Boolint check_lss_key_car (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object);
+extern Boolint check_string_lessp_nokey (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object);
+
+typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
+ Lisp_Object item, Lisp_Object elt);
+
Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
- Lisp_Object (*c_predicate) (Lisp_Object o1,
- Lisp_Object o2,
- Lisp_Object pred,
- Lisp_Object keyf),
+ check_test_func_t check_merge,
Lisp_Object predicate, Lisp_Object key_func);
Lisp_Object list_sort (Lisp_Object list,
- Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object),
+ check_test_func_t check_merge,
Lisp_Object predicate, Lisp_Object key_func);
void bump_string_modiff (Lisp_Object);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Fix issue #622
13 years, 10 months
Michael Sperber
Michael Sperber
This was a thorn in my side for years.
Will commit on Tuesday if nobody objects.
2011-01-30 Mike Sperber <mike(a)xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
--
Cheers =8-} Mike
Friede, Völkerverständigung und überhaupt blabla
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
＠＠ -1477,51 +1477,55 ＠＠
(save-match-data
(maphash
#'(lambda (buffer dummy)
- ;; remove first, to avoid infinite reprocessing if error
- (remhash buffer font-lock-pending-buffer-table)
- (when (buffer-live-p buffer)
- (clear-range-table font-lock-range-table)
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- ;; if we don't widen, then the C code in
- ;; syntactically-sectionize will fail to realize that
- ;; we're inside a comment. #### We don't actually use
- ;; syntactically-sectionize any more. Do we still
- ;; need the widen?
- (widen)
- (map-extents
- #'(lambda (ex dummy-maparg)
- ;; first expand the ranges to full lines,
- ;; because that is what will be fontified;
- ;; then use a range table to merge the
- ;; ranges. (we could also do this simply using
- ;; text properties. the range table code was
- ;; here from a previous version of this code
- ;; and works just as well.)
- (let* ((beg (extent-start-position ex))
- (end (extent-end-position ex))
- (beg (progn (goto-char beg)
- (beginning-of-line)
- (point)))
- (end (progn (goto-char end)
- (forward-line 1)
- (point))))
- (put-range-table beg end t
- font-lock-range-table)))
- nil nil nil nil nil 'font-lock-pending t)
- ;; clear all pending extents first in case of error below.
- (put-text-property (point-min) (point-max)
- 'font-lock-pending nil)
- (map-range-table
- #'(lambda (beg end val)
+ (catch 'exit
+ ;; font-lock-mode may be temporarily unset during `revert-buffer'
+ (if (not font-lock-mode)
+ (throw 'exit nil))
+ ;; remove first, to avoid infinite reprocessing if error
+ (remhash buffer font-lock-pending-buffer-table)
+ (when (buffer-live-p buffer)
+ (clear-range-table font-lock-range-table)
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ ;; if we don't widen, then the C code in
+ ;; syntactically-sectionize will fail to realize that
+ ;; we're inside a comment. #### We don't actually use
+ ;; syntactically-sectionize any more. Do we still
+ ;; need the widen?
+ (widen)
+ (map-extents
+ #'(lambda (ex dummy-maparg)
+ ;; first expand the ranges to full lines,
+ ;; because that is what will be fontified;
+ ;; then use a range table to merge the
+ ;; ranges. (we could also do this simply using
+ ;; text properties. the range table code was
+ ;; here from a previous version of this code
+ ;; and works just as well.)
+ (let* ((beg (extent-start-position ex))
+ (end (extent-end-position ex))
+ (beg (progn (goto-char beg)
+ (beginning-of-line)
+ (point)))
+ (end (progn (goto-char end)
+ (forward-line 1)
+ (point))))
+ (put-range-table beg end t
+ font-lock-range-table)))
+ nil nil nil nil nil 'font-lock-pending t)
+ ;; clear all pending extents first in case of error below.
+ (put-text-property (point-min) (point-max)
+ 'font-lock-pending nil)
+ (map-range-table
+ #'(lambda (beg end val)
;; This creates some unnecessary progress gauges.
;; (if (and (= beg (point-min))
;; (= end (point-max)))
;; (font-lock-fontify-buffer)
;; (font-lock-fontify-region beg end)))
- (font-lock-fontify-region beg end))
- font-lock-range-table))))))
+ (font-lock-fontify-region beg end))
+ font-lock-range-table)))))))
font-lock-pending-buffer-table)))
;; Syntactic fontification functions.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
Don't commit suicide when an X device dies.
13 years, 10 months
Michael Sperber
Michael Sperber
At least when running a debug build, XEmacs would die if an X device
died. Fix.
I've been running this for a couple of months yet with no problems.
Will commit on Tuesday if nobody objects.
2011-01-30 Michael Sperber <mike(a)xemacs.org>
* redisplay.h:
* redisplay.c:
(redisplay_cancel_ritual_suicide):
* eval.c (throw_or_bomb_out_unsafe):
* device-x.c (x_IO_error_handler): Don't commit suicide when an X
device dies.
--
Cheers =8-} Mike
Friede, Völkerverständigung und überhaupt blabla
diff --git a/src/device-x.c b/src/device-x.c
--- a/src/device-x.c
+++ b/src/device-x.c
＠＠ -1255,7 +1255,8 ＠＠
DEVICE_X_BEING_DELETED (d) = 1;
}
- throw_or_bomb_out (Qtop_level, Qnil, 0, Qnil, Qnil);
+ redisplay_cancel_ritual_suicide();
+ throw_or_bomb_out_unsafe (Qtop_level, Qnil, 0, Qnil, Qnil);
RETURN_NOT_REACHED (0);
}
diff --git a/src/eval.c b/src/eval.c
--- a/src/eval.c
+++ b/src/eval.c
＠＠ -1802,22 +1802,13 ＠＠
LONGJMP (c->jmp, 1);
}
-DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object, Lisp_Object, int,
Lisp_Object, Lisp_Object));
DOESNT_RETURN
-throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
- Lisp_Object sig, Lisp_Object data)
-{
-#ifdef DEFEND_AGAINST_THROW_RECURSION
- /* die if we recurse more than is reasonable */
- assert (++throw_level <= 20);
-#endif
-
-#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
- check_proper_critical_section_nonlocal_exit_protection ();
-#endif
-
+throw_or_bomb_out_unsafe (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
+ Lisp_Object sig, Lisp_Object data)
+{
/* If bomb_out_p is t, this is being called from Fsignal as a
"last resort" when there is no handler for this error and
the debugger couldn't be invoked, so we are throwing to
＠＠ -1857,6 +1848,24 ＠＠
call1 (Qreally_early_error_handler, Fcons (sig, data));
}
}
+
+DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
+
+DOESNT_RETURN
+throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
+ Lisp_Object sig, Lisp_Object data)
+{
+#ifdef DEFEND_AGAINST_THROW_RECURSION
+ /* die if we recurse more than is reasonable */
+ assert (++throw_level <= 20);
+#endif
+
+#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
+ check_proper_critical_section_nonlocal_exit_protection ();
+#endif
+ throw_or_bomb_out_unsafe (tag, val, bomb_out_p, sig, data);
+}
/* See above, where CATCHLIST is defined, for a description of how
Fthrow() works.
diff --git a/src/lisp.h b/src/lisp.h
--- a/src/lisp.h
+++ b/src/lisp.h
＠＠ -4722,6 +4722,10 ＠＠
Lisp_Object, int,
Lisp_Object, Lisp_Object));
+MODULE_API DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object,
+ Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
+
MODULE_API DECLARE_DOESNT_RETURN (signal_error_1 (Lisp_Object, Lisp_Object));
void maybe_signal_error_1 (Lisp_Object, Lisp_Object, Lisp_Object,
Error_Behavior);
diff --git a/src/redisplay.c b/src/redisplay.c
--- a/src/redisplay.c
+++ b/src/redisplay.c
＠＠ -6688,12 +6688,25 ＠＠
unbind_to (depth);
}
+static int the_ritual_suicide_has_been_cancelled = 0;
+
+void
+redisplay_cancel_ritual_suicide(void)
+{
+ the_ritual_suicide_has_been_cancelled = 1;
+}
+
#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
static Lisp_Object
commit_ritual_suicide (Lisp_Object UNUSED (ceci_nest_pas_une_pipe))
{
- assert (!in_display);
+ if (!the_ritual_suicide_has_been_cancelled)
+ {
+ assert (!in_display);
+ }
+ else
+ the_ritual_suicide_has_been_cancelled = 0;
return Qnil;
}
diff --git a/src/redisplay.h b/src/redisplay.h
--- a/src/redisplay.h
+++ b/src/redisplay.h
＠＠ -848,4 +848,6 ＠＠
int enter_redisplay_critical_section_if (Boolint from_outside);
void exit_redisplay_critical_section_if (Boolint from_outside, int depth);
+void redisplay_cancel_ritual_suicide(void);
+
#endif /* INCLUDED_redisplay_h_ */
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
commit: Unbreak font-lock during `revert-buffer.
13 years, 10 months
Michael Sperber
Michael Sperber
changeset: 5349:239193591765
tag: tip
user: Mike Sperber <sperber(a)deinprogramm.de>
date: Sun Jan 30 14:27:31 2011 +0100
files: lisp/ChangeLog lisp/font-lock.el
description:
Unbreak font-lock during `revert-buffer.
2011-01-30 Mike Sperber <mike(a)xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
This fixes Issue622.
diff -r 39304a35b6b3 -r 239193591765 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Jan 30 12:20:19 2011 +0100
+++ b/lisp/ChangeLog Sun Jan 30 14:27:31 2011 +0100
＠＠ -1,3 +1,9 ＠＠
+2011-01-30 Mike Sperber <mike(a)xemacs.org>
+
+ * font-lock.el (font-lock-fontify-pending-extents): Don't fail if
+ `font-lock-mode' is unset, which can happen in the middle of
+ `revert-buffer'.
+
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (delete):
diff -r 39304a35b6b3 -r 239193591765 lisp/font-lock.el
--- a/lisp/font-lock.el Sun Jan 30 12:20:19 2011 +0100
+++ b/lisp/font-lock.el Sun Jan 30 14:27:31 2011 +0100
＠＠ -1477,51 +1477,55 ＠＠
(save-match-data
(maphash
#'(lambda (buffer dummy)
- ;; remove first, to avoid infinite reprocessing if error
- (remhash buffer font-lock-pending-buffer-table)
- (when (buffer-live-p buffer)
- (clear-range-table font-lock-range-table)
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- ;; if we don't widen, then the C code in
- ;; syntactically-sectionize will fail to realize that
- ;; we're inside a comment. #### We don't actually use
- ;; syntactically-sectionize any more. Do we still
- ;; need the widen?
- (widen)
- (map-extents
- #'(lambda (ex dummy-maparg)
- ;; first expand the ranges to full lines,
- ;; because that is what will be fontified;
- ;; then use a range table to merge the
- ;; ranges. (we could also do this simply using
- ;; text properties. the range table code was
- ;; here from a previous version of this code
- ;; and works just as well.)
- (let* ((beg (extent-start-position ex))
- (end (extent-end-position ex))
- (beg (progn (goto-char beg)
- (beginning-of-line)
- (point)))
- (end (progn (goto-char end)
- (forward-line 1)
- (point))))
- (put-range-table beg end t
- font-lock-range-table)))
- nil nil nil nil nil 'font-lock-pending t)
- ;; clear all pending extents first in case of error below.
- (put-text-property (point-min) (point-max)
- 'font-lock-pending nil)
- (map-range-table
- #'(lambda (beg end val)
+ (catch 'exit
+ ;; font-lock-mode may be temporarily unset during `revert-buffer'
+ (if (not font-lock-mode)
+ (throw 'exit nil))
+ ;; remove first, to avoid infinite reprocessing if error
+ (remhash buffer font-lock-pending-buffer-table)
+ (when (buffer-live-p buffer)
+ (clear-range-table font-lock-range-table)
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ ;; if we don't widen, then the C code in
+ ;; syntactically-sectionize will fail to realize that
+ ;; we're inside a comment. #### We don't actually use
+ ;; syntactically-sectionize any more. Do we still
+ ;; need the widen?
+ (widen)
+ (map-extents
+ #'(lambda (ex dummy-maparg)
+ ;; first expand the ranges to full lines,
+ ;; because that is what will be fontified;
+ ;; then use a range table to merge the
+ ;; ranges. (we could also do this simply using
+ ;; text properties. the range table code was
+ ;; here from a previous version of this code
+ ;; and works just as well.)
+ (let* ((beg (extent-start-position ex))
+ (end (extent-end-position ex))
+ (beg (progn (goto-char beg)
+ (beginning-of-line)
+ (point)))
+ (end (progn (goto-char end)
+ (forward-line 1)
+ (point))))
+ (put-range-table beg end t
+ font-lock-range-table)))
+ nil nil nil nil nil 'font-lock-pending t)
+ ;; clear all pending extents first in case of error below.
+ (put-text-property (point-min) (point-max)
+ 'font-lock-pending nil)
+ (map-range-table
+ #'(lambda (beg end val)
;; This creates some unnecessary progress gauges.
;; (if (and (= beg (point-min))
;; (= end (point-max)))
;; (font-lock-fontify-buffer)
;; (font-lock-fontify-region beg end)))
- (font-lock-fontify-region beg end))
- font-lock-range-table))))))
+ (font-lock-fontify-region beg end))
+ font-lock-range-table)))))))
font-lock-pending-buffer-table)))
;; Syntactic fontification functions.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Don't commit suicide when an X device dies.
13 years, 10 months
Michael Sperber
Michael Sperber
changeset: 5348:39304a35b6b3
tag: tip
user: Mike Sperber <sperber(a)deinprogramm.de>
date: Sun Jan 30 12:20:19 2011 +0100
files: src/ChangeLog src/device-x.c src/eval.c src/lisp.h src/redisplay.c src/redisplay.h
description:
Don't commit suicide when an X device dies.
2011-01-30 Michael Sperber <mike(a)xemacs.org>
* redisplay.h:
* redisplay.c:
(redisplay_cancel_ritual_suicide):
* eval.c (throw_or_bomb_out_unsafe):
* device-x.c (x_IO_error_handler): Don't commit suicide when an X
device dies.
diff -r fd441b85d760 -r 39304a35b6b3 src/ChangeLog
--- a/src/ChangeLog Sun Jan 23 13:56:37 2011 +0000
+++ b/src/ChangeLog Sun Jan 30 12:20:19 2011 +0100
＠＠ -1,3 +1,12 ＠＠
+2011-01-30 Michael Sperber <mike(a)xemacs.org>
+
+ * redisplay.h:
+ * redisplay.c:
+ (redisplay_cancel_ritual_suicide):
+ * eval.c (throw_or_bomb_out_unsafe):
+ * device-x.c (x_IO_error_handler): Don't commit suicide when an X
+ device dies.
+
2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net>
* file-coding.c (complex_vars_of_file_coding):
diff -r fd441b85d760 -r 39304a35b6b3 src/device-x.c
--- a/src/device-x.c Sun Jan 23 13:56:37 2011 +0000
+++ b/src/device-x.c Sun Jan 30 12:20:19 2011 +0100
＠＠ -1255,7 +1255,8 ＠＠
DEVICE_X_BEING_DELETED (d) = 1;
}
- throw_or_bomb_out (Qtop_level, Qnil, 0, Qnil, Qnil);
+ redisplay_cancel_ritual_suicide();
+ throw_or_bomb_out_unsafe (Qtop_level, Qnil, 0, Qnil, Qnil);
RETURN_NOT_REACHED (0);
}
diff -r fd441b85d760 -r 39304a35b6b3 src/eval.c
--- a/src/eval.c Sun Jan 23 13:56:37 2011 +0000
+++ b/src/eval.c Sun Jan 30 12:20:19 2011 +0100
＠＠ -1802,22 +1802,13 ＠＠
LONGJMP (c->jmp, 1);
}
-DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object, Lisp_Object, int,
Lisp_Object, Lisp_Object));
DOESNT_RETURN
-throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
- Lisp_Object sig, Lisp_Object data)
-{
-#ifdef DEFEND_AGAINST_THROW_RECURSION
- /* die if we recurse more than is reasonable */
- assert (++throw_level <= 20);
-#endif
-
-#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
- check_proper_critical_section_nonlocal_exit_protection ();
-#endif
-
+throw_or_bomb_out_unsafe (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
+ Lisp_Object sig, Lisp_Object data)
+{
/* If bomb_out_p is t, this is being called from Fsignal as a
"last resort" when there is no handler for this error and
the debugger couldn't be invoked, so we are throwing to
＠＠ -1856,6 +1847,24 ＠＠
else
call1 (Qreally_early_error_handler, Fcons (sig, data));
}
+}
+
+DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
+
+DOESNT_RETURN
+throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
+ Lisp_Object sig, Lisp_Object data)
+{
+#ifdef DEFEND_AGAINST_THROW_RECURSION
+ /* die if we recurse more than is reasonable */
+ assert (++throw_level <= 20);
+#endif
+
+#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
+ check_proper_critical_section_nonlocal_exit_protection ();
+#endif
+ throw_or_bomb_out_unsafe (tag, val, bomb_out_p, sig, data);
}
/* See above, where CATCHLIST is defined, for a description of how
diff -r fd441b85d760 -r 39304a35b6b3 src/lisp.h
--- a/src/lisp.h Sun Jan 23 13:56:37 2011 +0000
+++ b/src/lisp.h Sun Jan 30 12:20:19 2011 +0100
＠＠ -4722,6 +4722,10 ＠＠
Lisp_Object, int,
Lisp_Object, Lisp_Object));
+MODULE_API DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object,
+ Lisp_Object, int,
+ Lisp_Object, Lisp_Object));
+
MODULE_API DECLARE_DOESNT_RETURN (signal_error_1 (Lisp_Object, Lisp_Object));
void maybe_signal_error_1 (Lisp_Object, Lisp_Object, Lisp_Object,
Error_Behavior);
diff -r fd441b85d760 -r 39304a35b6b3 src/redisplay.c
--- a/src/redisplay.c Sun Jan 23 13:56:37 2011 +0000
+++ b/src/redisplay.c Sun Jan 30 12:20:19 2011 +0100
＠＠ -6688,12 +6688,25 ＠＠
unbind_to (depth);
}
+static int the_ritual_suicide_has_been_cancelled = 0;
+
+void
+redisplay_cancel_ritual_suicide(void)
+{
+ the_ritual_suicide_has_been_cancelled = 1;
+}
+
#ifdef ERROR_CHECK_TRAPPING_PROBLEMS
static Lisp_Object
commit_ritual_suicide (Lisp_Object UNUSED (ceci_nest_pas_une_pipe))
{
- assert (!in_display);
+ if (!the_ritual_suicide_has_been_cancelled)
+ {
+ assert (!in_display);
+ }
+ else
+ the_ritual_suicide_has_been_cancelled = 0;
return Qnil;
}
diff -r fd441b85d760 -r 39304a35b6b3 src/redisplay.h
--- a/src/redisplay.h Sun Jan 23 13:56:37 2011 +0000
+++ b/src/redisplay.h Sun Jan 30 12:20:19 2011 +0100
＠＠ -848,4 +848,6 ＠＠
int enter_redisplay_critical_section_if (Boolint from_outside);
void exit_redisplay_critical_section_if (Boolint from_outside, int depth);
+void redisplay_cancel_ritual_suicide(void);
+
#endif /* INCLUDED_redisplay_h_ */
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments