Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5350:94bbd4792049

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Have #'sort*, #'merge use the same test approach as functions from cl-seq.el 2011-02-05 Aidan Kehoe <kehoea@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.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 05 Feb 2011 12:04:34 +0000
parents 8608eadee6ba
children 70b15ac66ee5 0af042a0c116
comparison
equal deleted inserted replaced
5349:239193591765 5350:94bbd4792049
61 Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute; 61 Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute;
62 Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable; 62 Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
63 Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch; 63 Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
64 64
65 Lisp_Object Qintersection, Qset_difference, Qnset_difference; 65 Lisp_Object Qintersection, Qset_difference, Qnset_difference;
66 Lisp_Object Qnunion, Qnintersection, Qsubsetp; 66 Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qcar_less_than_car;
67 67
68 Lisp_Object Qbase64_conversion_error; 68 Lisp_Object Qbase64_conversion_error;
69 69
70 Lisp_Object Vpath_separator; 70 Lisp_Object Vpath_separator;
71 71
208 Lisp_Bit_Vector); 208 Lisp_Bit_Vector);
209 209
210 /* Various test functions for #'member*, #'assoc* and the other functions 210 /* Various test functions for #'member*, #'assoc* and the other functions
211 that take both TEST and KEY arguments. */ 211 that take both TEST and KEY arguments. */
212 212
213 typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
214 Lisp_Object item, Lisp_Object elt);
215
216 static Boolint 213 static Boolint
217 check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), 214 check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
218 Lisp_Object item, Lisp_Object elt) 215 Lisp_Object item, Lisp_Object elt)
219 { 216 {
220 return EQ (item, elt); 217 return EQ (item, elt);
437 elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); 434 elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
438 UNGCPRO; 435 UNGCPRO;
439 436
440 return !NILP (elt1); 437 return !NILP (elt1);
441 } 438 }
442 439
440 static Boolint
441 check_lss_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
442 Lisp_Object elt1, Lisp_Object elt2)
443 {
444 return bytecode_arithcompare (elt1, elt2) < 0;
445 }
446
447 static Boolint
448 check_lss_key (Lisp_Object UNUSED (test), Lisp_Object key,
449 Lisp_Object elt1, Lisp_Object elt2)
450 {
451 Lisp_Object args[] = { key, elt1, elt2 };
452 struct gcpro gcpro1;
453
454 GCPRO1 (args[0]);
455 gcpro1.nvars = countof (args);
456 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
457 args[1] = key;
458 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
459 UNGCPRO;
460
461 return bytecode_arithcompare (args[0], args[1]) < 0;
462 }
463
464 Boolint
465 check_lss_key_car (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
466 Lisp_Object elt1, Lisp_Object elt2)
467 {
468 struct gcpro gcpro1, gcpro2;
469
470 GCPRO2 (elt1, elt2);
471 elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
472 elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
473 UNGCPRO;
474
475 return bytecode_arithcompare (elt1, elt2) < 0;
476 }
477
478 Boolint
479 check_string_lessp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
480 Lisp_Object elt1, Lisp_Object elt2)
481 {
482 return !NILP (Fstring_lessp (elt1, elt2));
483 }
484
485 static Boolint
486 check_string_lessp_key (Lisp_Object UNUSED (test), Lisp_Object key,
487 Lisp_Object elt1, Lisp_Object elt2)
488 {
489 Lisp_Object args[] = { key, elt1, elt2 };
490 struct gcpro gcpro1;
491
492 GCPRO1 (args[0]);
493 gcpro1.nvars = countof (args);
494 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
495 args[1] = key;
496 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
497 UNGCPRO;
498
499 return !NILP (Fstring_lessp (args[0], args[1]));
500 }
501
502 static Boolint
503 check_string_lessp_key_car (Lisp_Object UNUSED (test),
504 Lisp_Object UNUSED (key),
505 Lisp_Object elt1, Lisp_Object elt2)
506 {
507 struct gcpro gcpro1, gcpro2;
508
509 GCPRO2 (elt1, elt2);
510 elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
511 elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
512 UNGCPRO;
513
514 return !NILP (Fstring_lessp (elt1, elt2));
515 }
516
443 static check_test_func_t 517 static check_test_func_t
444 get_check_match_function_1 (Lisp_Object item, 518 get_check_match_function_1 (Lisp_Object item,
445 Lisp_Object *test_inout, Lisp_Object test_not, 519 Lisp_Object *test_inout, Lisp_Object test_not,
446 Lisp_Object if_, Lisp_Object if_not, 520 Lisp_Object if_, Lisp_Object if_not,
447 Lisp_Object key, Boolint *test_not_unboundp_out, 521 Lisp_Object key, Boolint *test_not_unboundp_out,
644 return get_check_match_function_1 (Qunbound, test_inout, test_not, 718 return get_check_match_function_1 (Qunbound, test_inout, test_not,
645 if_, if_not, key, 719 if_, if_not, key,
646 test_not_unboundp_out, test_func_out); 720 test_not_unboundp_out, test_func_out);
647 } 721 }
648 722
723 /* Given PREDICATE and KEY, return a C function pointer appropriate for use
724 in deciding whether one given elements of a sequence is less than
725 another. */
726
727 static check_test_func_t
728 get_merge_predicate (Lisp_Object predicate, Lisp_Object key)
729 {
730 predicate = indirect_function (predicate, 1);
731
732 if (NILP (key))
733 {
734 key = Qidentity;
735 }
736 else
737 {
738 key = indirect_function (key, 1);
739 if (EQ (key, XSYMBOL_FUNCTION (Qidentity)))
740 {
741 key = Qidentity;
742 }
743 }
744
745 if (EQ (key, Qidentity) && EQ (predicate,
746 XSYMBOL_FUNCTION (Qcar_less_than_car)))
747 {
748 key = XSYMBOL_FUNCTION (Qcar);
749 predicate = XSYMBOL_FUNCTION (Qlss);
750 }
751
752 if (EQ (predicate, XSYMBOL_FUNCTION (Qlss)))
753 {
754 if (EQ (key, Qidentity))
755 {
756 return check_lss_nokey;
757 }
758
759 if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
760 {
761 return check_lss_key_car;
762 }
763
764 return check_lss_key;
765 }
766
767 if (EQ (predicate, XSYMBOL_FUNCTION (Qstring_lessp)))
768 {
769 if (EQ (key, Qidentity))
770 {
771 return check_string_lessp_nokey;
772 }
773
774 if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
775 {
776 return check_string_lessp_key_car;
777 }
778
779 return check_string_lessp_key;
780 }
781
782 if (EQ (key, Qidentity))
783 {
784 return check_other_nokey;
785 }
786
787 return check_match_other_key;
788 }
649 789
650 DEFUN ("identity", Fidentity, 1, 1, 0, /* 790 DEFUN ("identity", Fidentity, 1, 1, 0, /*
651 Return the argument unchanged. 791 Return the argument unchanged.
652 */ 792 */
653 (arg)) 793 (arg))
4692 } 4832 }
4693 4833
4694 return result; 4834 return result;
4695 } 4835 }
4696 4836
4697 static Lisp_Object
4698 c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
4699 Lisp_Object pred, Lisp_Object key_func)
4700 {
4701 struct gcpro gcpro1;
4702 Lisp_Object args[3];
4703
4704 /* We could use call2() and call3() here, but we're called O(nlogn) times
4705 for a sequence of length n, it make some sense to inline them. */
4706 args[0] = key_func;
4707 args[1] = obj1;
4708 args[2] = Qnil;
4709
4710 GCPRO1 (args[0]);
4711 gcpro1.nvars = countof (args);
4712
4713 obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
4714
4715 args[1] = obj2;
4716 obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
4717
4718 args[0] = pred;
4719 args[1] = obj1;
4720 args[2] = obj2;
4721
4722 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
4723 }
4724
4725 static Lisp_Object
4726 c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
4727 Lisp_Object pred, Lisp_Object UNUSED (key_func))
4728 {
4729 struct gcpro gcpro1;
4730 Lisp_Object args[3];
4731
4732 /* This is (almost) the implementation of call2, it makes some sense to
4733 inline it here. */
4734 args[0] = pred;
4735 args[1] = obj1;
4736 args[2] = obj2;
4737
4738 GCPRO1 (args[0]);
4739 gcpro1.nvars = countof (args);
4740
4741 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
4742 }
4743
4744 Lisp_Object 4837 Lisp_Object
4745 list_merge (Lisp_Object org_l1, Lisp_Object org_l2, 4838 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
4746 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, 4839 check_test_func_t check_merge,
4747 Lisp_Object, Lisp_Object), 4840 Lisp_Object predicate, Lisp_Object key)
4748 Lisp_Object predicate, Lisp_Object key_func)
4749 { 4841 {
4750 Lisp_Object value; 4842 Lisp_Object value;
4751 Lisp_Object tail; 4843 Lisp_Object tail;
4752 Lisp_Object tem; 4844 Lisp_Object tem;
4753 Lisp_Object l1, l2; 4845 Lisp_Object l1, l2;
4760 tail = Qnil; 4852 tail = Qnil;
4761 value = Qnil; 4853 value = Qnil;
4762 tortoises[0] = org_l1; 4854 tortoises[0] = org_l1;
4763 tortoises[1] = org_l2; 4855 tortoises[1] = org_l2;
4764 4856
4765 if (NULL == c_predicate) 4857 /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are
4766 { 4858 updated, we copy the new values back into the org_ vars. */
4767 c_predicate = EQ (key_func, Qidentity) ?
4768 c_merge_predicate_nokey : c_merge_predicate_key;
4769 }
4770
4771 /* It is sufficient to protect org_l1 and org_l2.
4772 When l1 and l2 are updated, we copy the new values
4773 back into the org_ vars. */
4774 4859
4775 GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); 4860 GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
4776 gcpro5.nvars = 2; 4861 gcpro5.nvars = 2;
4777 4862
4778 while (1) 4863 while (1)
4792 return l1; 4877 return l1;
4793 Fsetcdr (tail, l1); 4878 Fsetcdr (tail, l1);
4794 return value; 4879 return value;
4795 } 4880 }
4796 4881
4797 if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func))) 4882 if (check_merge (predicate, key, Fcar (l2), Fcar (l1)) == 0)
4798 { 4883 {
4799 tem = l1; 4884 tem = l1;
4800 l1 = Fcdr (l1); 4885 l1 = Fcdr (l1);
4801 org_l1 = l1; 4886 org_l1 = l1;
4802 4887
4854 4939
4855 static void 4940 static void
4856 array_merge (Lisp_Object *dest, Elemcount dest_len, 4941 array_merge (Lisp_Object *dest, Elemcount dest_len,
4857 Lisp_Object *front, Elemcount front_len, 4942 Lisp_Object *front, Elemcount front_len,
4858 Lisp_Object *back, Elemcount back_len, 4943 Lisp_Object *back, Elemcount back_len,
4859 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, 4944 check_test_func_t check_merge,
4860 Lisp_Object, Lisp_Object), 4945 Lisp_Object predicate, Lisp_Object key)
4861 Lisp_Object predicate, Lisp_Object key_func)
4862 { 4946 {
4863 Elemcount ii, fronting, backing; 4947 Elemcount ii, fronting, backing;
4864 Lisp_Object *front_staging = front; 4948 Lisp_Object *front_staging = front;
4865 Lisp_Object *back_staging = back; 4949 Lisp_Object *back_staging = back;
4866 struct gcpro gcpro1, gcpro2; 4950 struct gcpro gcpro1, gcpro2;
4918 } 5002 }
4919 UNGCPRO; 5003 UNGCPRO;
4920 return; 5004 return;
4921 } 5005 }
4922 5006
4923 if (NILP (c_predicate (back_staging[backing], front_staging[fronting], 5007 if (check_merge (predicate, key, back_staging[backing],
4924 predicate, key_func))) 5008 front_staging[fronting]) == 0)
4925 { 5009 {
4926 dest[ii] = front_staging[fronting]; 5010 dest[ii] = front_staging[fronting];
4927 ++fronting; 5011 ++fronting;
4928 } 5012 }
4929 else 5013 else
4937 } 5021 }
4938 5022
4939 static Lisp_Object 5023 static Lisp_Object
4940 list_array_merge_into_list (Lisp_Object list, 5024 list_array_merge_into_list (Lisp_Object list,
4941 Lisp_Object *array, Elemcount array_len, 5025 Lisp_Object *array, Elemcount array_len,
4942 Lisp_Object (*c_predicate) (Lisp_Object, 5026 check_test_func_t check_merge,
4943 Lisp_Object, 5027 Lisp_Object predicate, Lisp_Object key,
4944 Lisp_Object,
4945 Lisp_Object),
4946 Lisp_Object predicate, Lisp_Object key_func,
4947 Boolint reverse_order) 5028 Boolint reverse_order)
4948 { 5029 {
4949 Lisp_Object tail = Qnil, value = Qnil, tortoise = list; 5030 Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
4950 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 5031 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4951 Elemcount array_index = 0; 5032 Elemcount array_index = 0;
4980 return value; 5061 return value;
4981 } 5062 }
4982 5063
4983 5064
4984 if (reverse_order ? 5065 if (reverse_order ?
4985 !NILP (c_predicate (Fcar (list), array [array_index], predicate, 5066 check_merge (predicate, key, Fcar (list), array [array_index])
4986 key_func)) : 5067 : !check_merge (predicate, key, array [array_index], Fcar (list)))
4987 NILP (c_predicate (array [array_index], Fcar (list), predicate,
4988 key_func)))
4989 { 5068 {
4990 if (NILP (tail)) 5069 if (NILP (tail))
4991 { 5070 {
4992 value = tail = list; 5071 value = tail = list;
4993 } 5072 }
5029 } 5108 }
5030 5109
5031 static void 5110 static void
5032 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len, 5111 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
5033 Lisp_Object list_one, Lisp_Object list_two, 5112 Lisp_Object list_one, Lisp_Object list_two,
5034 Lisp_Object (*c_predicate) (Lisp_Object, 5113 check_test_func_t check_merge,
5035 Lisp_Object, 5114 Lisp_Object predicate, Lisp_Object key)
5036 Lisp_Object,
5037 Lisp_Object),
5038 Lisp_Object predicate, Lisp_Object key_func)
5039 { 5115 {
5040 Elemcount output_index = 0; 5116 Elemcount output_index = 0;
5041 5117
5042 while (output_index < output_len) 5118 while (output_index < output_len)
5043 { 5119 {
5059 list_one = Fcdr (list_one), ++output_index; 5135 list_one = Fcdr (list_one), ++output_index;
5060 } 5136 }
5061 return; 5137 return;
5062 } 5138 }
5063 5139
5064 if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate, 5140 if (check_merge (predicate, key, Fcar (list_two), Fcar (list_one))
5065 key_func))) 5141 == 0)
5066 { 5142 {
5067 output [output_index] = XCAR (list_one); 5143 output [output_index] = XCAR (list_one);
5068 list_one = XCDR (list_one); 5144 list_one = XCDR (list_one);
5069 } 5145 }
5070 else 5146 else
5081 5157
5082 static void 5158 static void
5083 list_array_merge_into_array (Lisp_Object *output, Elemcount output_len, 5159 list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
5084 Lisp_Object list, 5160 Lisp_Object list,
5085 Lisp_Object *array, Elemcount array_len, 5161 Lisp_Object *array, Elemcount array_len,
5086 Lisp_Object (*c_predicate) (Lisp_Object, 5162 check_test_func_t check_merge,
5087 Lisp_Object, 5163 Lisp_Object predicate, Lisp_Object key,
5088 Lisp_Object,
5089 Lisp_Object),
5090 Lisp_Object predicate, Lisp_Object key_func,
5091 Boolint reverse_order) 5164 Boolint reverse_order)
5092 { 5165 {
5093 Elemcount output_index = 0, array_index = 0; 5166 Elemcount output_index = 0, array_index = 0;
5094 5167
5095 while (output_index < output_len) 5168 while (output_index < output_len)
5119 5192
5120 return; 5193 return;
5121 } 5194 }
5122 5195
5123 if (reverse_order ? 5196 if (reverse_order ?
5124 !NILP (c_predicate (Fcar (list), array [array_index], predicate, 5197 check_merge (predicate, key, Fcar (list), array [array_index]) :
5125 key_func)) : 5198 !check_merge (predicate, key, array [array_index], Fcar (list)))
5126 NILP (c_predicate (array [array_index], Fcar (list), predicate,
5127 key_func)))
5128 { 5199 {
5129 output [output_index] = XCAR (list); 5200 output [output_index] = XCAR (list);
5130 list = XCDR (list); 5201 list = XCDR (list);
5131 } 5202 }
5132 else 5203 else
5170 */ 5241 */
5171 (int nargs, Lisp_Object *args)) 5242 (int nargs, Lisp_Object *args))
5172 { 5243 {
5173 Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2], 5244 Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
5174 predicate = args[3], result = Qnil; 5245 predicate = args[3], result = Qnil;
5175 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object, 5246 check_test_func_t check_merge = NULL;
5176 Lisp_Object);
5177 5247
5178 PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL); 5248 PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL);
5179 5249
5180 CHECK_SEQUENCE (sequence_one); 5250 CHECK_SEQUENCE (sequence_one);
5181 CHECK_SEQUENCE (sequence_two); 5251 CHECK_SEQUENCE (sequence_two);
5182 5252
5183 CHECK_KEY_ARGUMENT (key); 5253 CHECK_KEY_ARGUMENT (key);
5184 5254
5185 c_predicate = EQ (key, Qidentity) ? 5255 check_merge = get_merge_predicate (predicate, key);
5186 c_merge_predicate_nokey : c_merge_predicate_key;
5187 5256
5188 if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two))) 5257 if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
5189 { 5258 {
5190 if (NILP (sequence_two)) 5259 if (NILP (sequence_two))
5191 { 5260 {
5197 protection, but that doesn't matter. */ 5266 protection, but that doesn't matter. */
5198 result = Fappend (2, args + 2); 5267 result = Fappend (2, args + 2);
5199 } 5268 }
5200 else if (CONSP (sequence_one) && CONSP (sequence_two)) 5269 else if (CONSP (sequence_one) && CONSP (sequence_two))
5201 { 5270 {
5202 result = list_merge (sequence_one, sequence_two, c_predicate, 5271 result = list_merge (sequence_one, sequence_two, check_merge,
5203 predicate, key); 5272 predicate, key);
5204 } 5273 }
5205 else 5274 else
5206 { 5275 {
5207 Lisp_Object *array_storage, swap; 5276 Lisp_Object *array_storage, swap;
5239 BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length); 5308 BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length);
5240 } 5309 }
5241 5310
5242 result = list_array_merge_into_list (sequence_one, 5311 result = list_array_merge_into_list (sequence_one,
5243 array_storage, array_length, 5312 array_storage, array_length,
5244 c_predicate, 5313 check_merge, predicate, key,
5245 predicate, key,
5246 reverse_order); 5314 reverse_order);
5247 } 5315 }
5248 } 5316 }
5249 else 5317 else
5250 { 5318 {
5304 5372
5305 if (LISTP (sequence_one) && LISTP (sequence_two)) 5373 if (LISTP (sequence_one) && LISTP (sequence_two))
5306 { 5374 {
5307 list_list_merge_into_array (output + 1, output_len - 1, 5375 list_list_merge_into_array (output + 1, output_len - 1,
5308 sequence_one, sequence_two, 5376 sequence_one, sequence_two,
5309 c_predicate, predicate, 5377 check_merge, predicate, key);
5310 key);
5311 } 5378 }
5312 else if (LISTP (sequence_one)) 5379 else if (LISTP (sequence_one))
5313 { 5380 {
5314 list_array_merge_into_array (output + 1, output_len - 1, 5381 list_array_merge_into_array (output + 1, output_len - 1,
5315 sequence_one, 5382 sequence_one,
5316 sequence_two_storage, 5383 sequence_two_storage,
5317 sequence_two_len, 5384 sequence_two_len,
5318 c_predicate, predicate, 5385 check_merge, predicate, key, 0);
5319 key, 0);
5320 } 5386 }
5321 else if (LISTP (sequence_two)) 5387 else if (LISTP (sequence_two))
5322 { 5388 {
5323 list_array_merge_into_array (output + 1, output_len - 1, 5389 list_array_merge_into_array (output + 1, output_len - 1,
5324 sequence_two, 5390 sequence_two,
5325 sequence_one_storage, 5391 sequence_one_storage,
5326 sequence_one_len, 5392 sequence_one_len,
5327 c_predicate, predicate, 5393 check_merge, predicate, key, 1);
5328 key, 1);
5329 } 5394 }
5330 else 5395 else
5331 { 5396 {
5332 array_merge (output + 1, output_len - 1, 5397 array_merge (output + 1, output_len - 1,
5333 sequence_one_storage, sequence_one_len, 5398 sequence_one_storage, sequence_one_len,
5334 sequence_two_storage, sequence_two_len, 5399 sequence_two_storage, sequence_two_len,
5335 c_predicate, predicate, 5400 check_merge, predicate,
5336 key); 5401 key);
5337 } 5402 }
5338 5403
5339 result = Ffuncall (output_len, output); 5404 result = Ffuncall (output_len, output);
5340 5405
5347 } 5412 }
5348 5413
5349 return result; 5414 return result;
5350 } 5415 }
5351 5416
5352 /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
5353 NOTE: This is backwards from the way qsort() works. */
5354 Lisp_Object 5417 Lisp_Object
5355 list_sort (Lisp_Object list, 5418 list_sort (Lisp_Object list, check_test_func_t check_merge,
5356 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, 5419 Lisp_Object predicate, Lisp_Object key)
5357 Lisp_Object, Lisp_Object),
5358 Lisp_Object predicate, Lisp_Object key_func)
5359 { 5420 {
5360 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 5421 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
5361 Lisp_Object back, tem; 5422 Lisp_Object back, tem;
5362 Lisp_Object front = list; 5423 Lisp_Object front = list;
5363 Lisp_Object len = Flength (list); 5424 Lisp_Object len = Flength (list);
5364 5425
5365 if (XINT (len) < 2) 5426 if (XINT (len) < 2)
5366 return list; 5427 return list;
5367 5428
5368 if (NULL == c_predicate)
5369 {
5370 c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey :
5371 c_merge_predicate_key;
5372 }
5373
5374 len = make_int (XINT (len) / 2 - 1); 5429 len = make_int (XINT (len) / 2 - 1);
5375 tem = Fnthcdr (len, list); 5430 tem = Fnthcdr (len, list);
5376 back = Fcdr (tem); 5431 back = Fcdr (tem);
5377 Fsetcdr (tem, Qnil); 5432 Fsetcdr (tem, Qnil);
5378 5433
5379 GCPRO4 (front, back, predicate, key_func); 5434 GCPRO4 (front, back, predicate, key);
5380 front = list_sort (front, c_predicate, predicate, key_func); 5435 front = list_sort (front, check_merge, predicate, key);
5381 back = list_sort (back, c_predicate, predicate, key_func); 5436 back = list_sort (back, check_merge, predicate, key);
5382 5437
5383 RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func)); 5438 RETURN_UNGCPRO (list_merge (front, back, check_merge, predicate, key));
5384 } 5439 }
5385 5440
5386 static void 5441 static void
5387 array_sort (Lisp_Object *array, Elemcount array_len, 5442 array_sort (Lisp_Object *array, Elemcount array_len,
5388 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, 5443 check_test_func_t check_merge,
5389 Lisp_Object, Lisp_Object), 5444 Lisp_Object predicate, Lisp_Object key)
5390 Lisp_Object predicate, Lisp_Object key_func)
5391 { 5445 {
5392 Elemcount split; 5446 Elemcount split;
5393 5447
5394 if (array_len < 2) 5448 if (array_len < 2)
5395 return; 5449 return;
5396 5450
5397 split = array_len / 2; 5451 split = array_len / 2;
5398 5452
5399 array_sort (array, split, c_predicate, predicate, key_func); 5453 array_sort (array, split, check_merge, predicate, key);
5400 array_sort (array + split, array_len - split, c_predicate, predicate, 5454 array_sort (array + split, array_len - split, check_merge, predicate,
5401 key_func); 5455 key);
5402 array_merge (array, array_len, array, split, array + split, 5456 array_merge (array, array_len, array, split, array + split,
5403 array_len - split, c_predicate, predicate, key_func); 5457 array_len - split, check_merge, predicate, key);
5404 } 5458 }
5405 5459
5406 DEFUN ("sort*", FsortX, 2, MANY, 0, /* 5460 DEFUN ("sort*", FsortX, 2, MANY, 0, /*
5407 Sort SEQUENCE, comparing elements using PREDICATE. 5461 Sort SEQUENCE, comparing elements using PREDICATE.
5408 Returns the sorted sequence. SEQUENCE is modified by side effect. 5462 Returns the sorted sequence. SEQUENCE is modified by side effect.
5421 */ 5475 */
5422 (int nargs, Lisp_Object *args)) 5476 (int nargs, Lisp_Object *args))
5423 { 5477 {
5424 Lisp_Object sequence = args[0], predicate = args[1]; 5478 Lisp_Object sequence = args[0], predicate = args[1];
5425 Lisp_Object *sequence_carray; 5479 Lisp_Object *sequence_carray;
5426 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object, 5480 check_test_func_t check_merge = NULL;
5427 Lisp_Object);
5428 Elemcount sequence_len, i; 5481 Elemcount sequence_len, i;
5429 5482
5430 PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL); 5483 PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL);
5431 5484
5432 CHECK_SEQUENCE (sequence); 5485 CHECK_SEQUENCE (sequence);
5433 5486
5434 CHECK_KEY_ARGUMENT (key); 5487 CHECK_KEY_ARGUMENT (key);
5435 5488
5436 c_predicate = EQ (key, Qidentity) ? 5489 check_merge = get_merge_predicate (predicate, key);
5437 c_merge_predicate_nokey : c_merge_predicate_key;
5438 5490
5439 if (LISTP (sequence)) 5491 if (LISTP (sequence))
5440 { 5492 {
5441 sequence = list_sort (sequence, c_predicate, predicate, key); 5493 sequence = list_sort (sequence, check_merge, predicate, key);
5442 } 5494 }
5443 else if (VECTORP (sequence)) 5495 else if (VECTORP (sequence))
5444 { 5496 {
5445 array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence), 5497 array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
5446 c_predicate, predicate, key); 5498 check_merge, predicate, key);
5447 } 5499 }
5448 else if (STRINGP (sequence)) 5500 else if (STRINGP (sequence))
5449 { 5501 {
5450 Ibyte *strdata = XSTRING_DATA (sequence); 5502 Ibyte *strdata = XSTRING_DATA (sequence);
5451 5503
5452 sequence_len = string_char_length (sequence); 5504 sequence_len = string_char_length (sequence);
5453 5505
5454 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len); 5506 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
5455 5507
5456 /* No GCPRO necessary, characters are immediate. */ 5508 /* No GCPRO necessary, characters are immediate. */
5457 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key); 5509 array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
5458 5510
5459 strdata = XSTRING_DATA (sequence); 5511 strdata = XSTRING_DATA (sequence);
5460 5512
5461 CHECK_LISP_WRITEABLE (sequence); 5513 CHECK_LISP_WRITEABLE (sequence);
5462 for (i = 0; i < sequence_len; ++i) 5514 for (i = 0; i < sequence_len; ++i)
5474 sequence_len = bit_vector_length (v); 5526 sequence_len = bit_vector_length (v);
5475 5527
5476 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len); 5528 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
5477 5529
5478 /* No GCPRO necessary, bits are immediate. */ 5530 /* No GCPRO necessary, bits are immediate. */
5479 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key); 5531 array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
5480 5532
5481 for (i = 0; i < sequence_len; ++i) 5533 for (i = 0; i < sequence_len; ++i)
5482 { 5534 {
5483 set_bit_vector_bit (v, i, XINT (sequence_carray [i])); 5535 set_bit_vector_bit (v, i, XINT (sequence_carray [i]));
5484 } 5536 }
11696 DEFSYMBOL (Qsubstitute); 11748 DEFSYMBOL (Qsubstitute);
11697 DEFSYMBOL (Qmismatch); 11749 DEFSYMBOL (Qmismatch);
11698 DEFSYMBOL (Qintersection); 11750 DEFSYMBOL (Qintersection);
11699 DEFSYMBOL (Qnintersection); 11751 DEFSYMBOL (Qnintersection);
11700 DEFSYMBOL (Qsubsetp); 11752 DEFSYMBOL (Qsubsetp);
11753 DEFSYMBOL (Qcar_less_than_car);
11701 DEFSYMBOL (Qset_difference); 11754 DEFSYMBOL (Qset_difference);
11702 DEFSYMBOL (Qnset_difference); 11755 DEFSYMBOL (Qnset_difference);
11703 DEFSYMBOL (Qnunion); 11756 DEFSYMBOL (Qnunion);
11704 11757
11705 DEFKEYWORD (Q_from_end); 11758 DEFKEYWORD (Q_from_end);