Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5182:2e528066e2fc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move #'sort*, #'fill, #'merge to C from cl-seq.el. lisp/ChangeLog addition: 2010-04-01 Aidan Kehoe <kehoea@parhasard.net> * cl-seq.el (fill, sort*, merge): Move these functions to fns.c. (stable-sort): Make this docstring reflect the argument names used in the #'sort* docstring. * cl-macs.el (stable-sort): Make #'stable-sort exactly equivalent to #'sort* in compiled code. * bytecomp.el (byte-compile-maybe-add-*): New macro, for functions like #'sort and #'mapcar that, to be strictly compatible, should only take two args, but in our implementation can take more, because they're aliases of #'sort* and #'mapcar*. (byte-compile-mapcar, byte-compile-sort, byte-compile-fillarray): Use this new macro. (map-into): Add a byte-compile method for #'map-into in passing. * apropos.el (apropos-print): Use #'sort* with a :key argument, now it's in C. * compat.el (extent-at): Ditto. * register.el (list-registers): Ditto. * package-ui.el (pui-list-packages): Ditto. * help.el (sorted-key-descriptions): Ditto. src/ChangeLog addition: 2010-03-31 Aidan Kehoe <kehoea@parhasard.net> * fns.c (STRING_DATA_TO_OBJECT_ARRAY) (BIT_VECTOR_TO_OBJECT_ARRAY, c_merge_predicate_key) (c_merge_predicate_nokey, list_merge, array_merge) (list_array_merge_into_list, list_list_merge_into_array) (list_array_merge_into_array, CHECK_KEY_ARGUMENT, Fmerge) (list_sort, array_sort, FsortX): Move #'sort*, #'fill, #'merge from cl-seq.el to C, extending the implementations of Fsort, Ffillarray, and merge() to do so. * keymap.c (keymap_submaps, map_keymap_sort_predicate) (describe_map_sort_predicate): Change the calling semantics of the C sort predicates to return a non-nil Lisp object if the first argument is less than the second, rather than C integers. * fontcolor-msw.c (sort_font_list_function): * fileio.c (build_annotations): * dired.c (Fdirectory_files): * abbrev.c (Finsert_abbrev_table_description): Call list_sort instead of Fsort, list_merge instead of merge() in these functions. man/ChangeLog addition: 2010-04-01 Aidan Kehoe <kehoea@parhasard.net> * lispref/lists.texi (Rearrangement): Update the documentation of #'sort here, now that it accepts any type of sequence and the KEY keyword argument. (Though this is probably now the wrong place for this function, given that.)
author Aidan Kehoe <kehoea@parhasard.net>
date Thu, 01 Apr 2010 20:22:50 +0100
parents 7be849cb8828
children 039d9a7f2e6d
comparison
equal deleted inserted replaced
5181:a00bfbd64e0a 5182:2e528066e2fc
52 #include "opaque.h" 52 #include "opaque.h"
53 53
54 /* NOTE: This symbol is also used in lread.c */ 54 /* NOTE: This symbol is also used in lread.c */
55 #define FEATUREP_SYNTAX 55 #define FEATUREP_SYNTAX
56 56
57 Lisp_Object Qstring_lessp; 57 Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill;
58 Lisp_Object Qidentity; 58 Lisp_Object Qidentity;
59 Lisp_Object Qvector, Qarray, Qbit_vector; 59 Lisp_Object Qvector, Qarray, Qbit_vector, QsortX;
60 60
61 Lisp_Object Qbase64_conversion_error; 61 Lisp_Object Qbase64_conversion_error;
62 62
63 Lisp_Object Vpath_separator; 63 Lisp_Object Vpath_separator;
64 64
1934 reversed_list = Fcons (elt, reversed_list); 1934 reversed_list = Fcons (elt, reversed_list);
1935 } 1935 }
1936 return reversed_list; 1936 return reversed_list;
1937 } 1937 }
1938 1938
1939 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, 1939 static Lisp_Object
1940 Lisp_Object lisp_arg, 1940 c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
1941 int (*pred_fn) (Lisp_Object, Lisp_Object, 1941 Lisp_Object pred, Lisp_Object key_func)
1942 Lisp_Object lisp_arg)); 1942 {
1943 1943 struct gcpro gcpro1;
1944 /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. 1944 Lisp_Object args[3];
1945 NOTE: This is backwards from the way qsort() works. */ 1945
1946 /* We could use call2() and call3() here, but we're called O(nlogn) times
1947 for a sequence of length n, it make some sense to inline them. */
1948 args[0] = key_func;
1949 args[1] = obj1;
1950 args[2] = Qnil;
1951
1952 GCPRO1 (args[0]);
1953 gcpro1.nvars = countof (args);
1954
1955 obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
1956
1957 args[1] = obj2;
1958 obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
1959
1960 args[0] = pred;
1961 args[1] = obj1;
1962 args[2] = obj2;
1963
1964 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
1965 }
1966
1967 static Lisp_Object
1968 c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
1969 Lisp_Object pred, Lisp_Object UNUSED (key_func))
1970 {
1971 struct gcpro gcpro1;
1972 Lisp_Object args[3];
1973
1974 /* This is (almost) the implementation of call2, it makes some sense to
1975 inline it here. */
1976 args[0] = pred;
1977 args[1] = obj1;
1978 args[2] = obj2;
1979
1980 GCPRO1 (args[0]);
1981 gcpro1.nvars = countof (args);
1982
1983 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
1984 }
1946 1985
1947 Lisp_Object 1986 Lisp_Object
1948 list_sort (Lisp_Object list,
1949 Lisp_Object lisp_arg,
1950 int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2,
1951 Lisp_Object lisp_arg))
1952 {
1953 struct gcpro gcpro1, gcpro2, gcpro3;
1954 Lisp_Object back, tem;
1955 Lisp_Object front = list;
1956 Lisp_Object len = Flength (list);
1957
1958 if (XINT (len) < 2)
1959 return list;
1960
1961 len = make_int (XINT (len) / 2 - 1);
1962 tem = Fnthcdr (len, list);
1963 back = Fcdr (tem);
1964 Fsetcdr (tem, Qnil);
1965
1966 GCPRO3 (front, back, lisp_arg);
1967 front = list_sort (front, lisp_arg, pred_fn);
1968 back = list_sort (back, lisp_arg, pred_fn);
1969 UNGCPRO;
1970 return list_merge (front, back, lisp_arg, pred_fn);
1971 }
1972
1973
1974 static int
1975 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1976 Lisp_Object pred)
1977 {
1978 Lisp_Object tmp;
1979
1980 /* prevents the GC from happening in call2 */
1981 /* Emacs' GC doesn't actually relocate pointers, so this probably
1982 isn't strictly necessary */
1983 int speccount = begin_gc_forbidden ();
1984 tmp = call2 (pred, obj1, obj2);
1985 unbind_to (speccount);
1986
1987 if (NILP (tmp))
1988 return -1;
1989 else
1990 return 1;
1991 }
1992
1993 DEFUN ("sort", Fsort, 2, 2, 0, /*
1994 Sort LIST, stably, comparing elements using PREDICATE.
1995 Returns the sorted list. LIST is modified by side effects.
1996 PREDICATE is called with two elements of LIST, and should return T
1997 if the first element is "less" than the second.
1998 */
1999 (list, predicate))
2000 {
2001 return list_sort (list, predicate, merge_pred_function);
2002 }
2003
2004 Lisp_Object
2005 merge (Lisp_Object org_l1, Lisp_Object org_l2,
2006 Lisp_Object pred)
2007 {
2008 return list_merge (org_l1, org_l2, pred, merge_pred_function);
2009 }
2010
2011
2012 static Lisp_Object
2013 list_merge (Lisp_Object org_l1, Lisp_Object org_l2, 1987 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
2014 Lisp_Object lisp_arg, 1988 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2015 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg)) 1989 Lisp_Object, Lisp_Object),
1990 Lisp_Object predicate, Lisp_Object key_func)
2016 { 1991 {
2017 Lisp_Object value; 1992 Lisp_Object value;
2018 Lisp_Object tail; 1993 Lisp_Object tail;
2019 Lisp_Object tem; 1994 Lisp_Object tem;
2020 Lisp_Object l1, l2; 1995 Lisp_Object l1, l2;
2021 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 1996 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1997 int looped = 0;
2022 1998
2023 l1 = org_l1; 1999 l1 = org_l1;
2024 l2 = org_l2; 2000 l2 = org_l2;
2025 tail = Qnil; 2001 tail = Qnil;
2026 value = Qnil; 2002 value = Qnil;
2027 2003
2004 if (NULL == c_predicate)
2005 {
2006 c_predicate = EQ (key_func, Qidentity) ?
2007 c_merge_predicate_nokey : c_merge_predicate_key;
2008 }
2009
2028 /* It is sufficient to protect org_l1 and org_l2. 2010 /* It is sufficient to protect org_l1 and org_l2.
2029 When l1 and l2 are updated, we copy the new values 2011 When l1 and l2 are updated, we copy the new values
2030 back into the org_ vars. */ 2012 back into the org_ vars. */
2031 2013
2032 GCPRO4 (org_l1, org_l2, lisp_arg, value); 2014 GCPRO4 (org_l1, org_l2, predicate, value);
2033 2015
2034 while (1) 2016 while (1)
2035 { 2017 {
2036 if (NILP (l1)) 2018 if (NILP (l1))
2037 { 2019 {
2048 return l1; 2030 return l1;
2049 Fsetcdr (tail, l1); 2031 Fsetcdr (tail, l1);
2050 return value; 2032 return value;
2051 } 2033 }
2052 2034
2053 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0) 2035 if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
2054 { 2036 {
2055 tem = l1; 2037 tem = l1;
2056 l1 = Fcdr (l1); 2038 l1 = Fcdr (l1);
2057 org_l1 = l1; 2039 org_l1 = l1;
2058 } 2040 }
2065 if (NILP (tail)) 2047 if (NILP (tail))
2066 value = tem; 2048 value = tem;
2067 else 2049 else
2068 Fsetcdr (tail, tem); 2050 Fsetcdr (tail, tem);
2069 tail = tem; 2051 tail = tem;
2070 } 2052
2071 } 2053 if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2072 2054
2055 /* Just check the lists aren't circular:*/
2056 {
2057 EXTERNAL_LIST_LOOP_1 (l1)
2058 {
2059 }
2060 }
2061 {
2062 EXTERNAL_LIST_LOOP_1 (l2)
2063 {
2064 }
2065 }
2066 }
2067 }
2068
2069 static void
2070 array_merge (Lisp_Object *dest, Elemcount dest_len,
2071 Lisp_Object *front, Elemcount front_len,
2072 Lisp_Object *back, Elemcount back_len,
2073 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2074 Lisp_Object, Lisp_Object),
2075 Lisp_Object predicate, Lisp_Object key_func)
2076 {
2077 Elemcount ii, fronting, backing;
2078 Lisp_Object *front_staging = front;
2079 Lisp_Object *back_staging = back;
2080 struct gcpro gcpro1, gcpro2;
2081
2082 assert (dest_len == (back_len + front_len));
2083
2084 if (0 == dest_len)
2085 {
2086 return;
2087 }
2088
2089 if (front >= dest && front < (dest + dest_len))
2090 {
2091 front_staging = alloca_array (Lisp_Object, front_len);
2092
2093 for (ii = 0; ii < front_len; ++ii)
2094 {
2095 front_staging[ii] = front[ii];
2096 }
2097 }
2098
2099 if (back >= dest && back < (dest + dest_len))
2100 {
2101 back_staging = alloca_array (Lisp_Object, back_len);
2102
2103 for (ii = 0; ii < back_len; ++ii)
2104 {
2105 back_staging[ii] = back[ii];
2106 }
2107 }
2108
2109 GCPRO2 (front_staging[0], back_staging[0]);
2110 gcpro1.nvars = front_len;
2111 gcpro2.nvars = back_len;
2112
2113 for (ii = fronting = backing = 0; ii < dest_len; ++ii)
2114 {
2115 if (fronting >= front_len)
2116 {
2117 while (ii < dest_len)
2118 {
2119 dest[ii] = back_staging[backing];
2120 ++ii, ++backing;
2121 }
2122 UNGCPRO;
2123 return;
2124 }
2125
2126 if (backing >= back_len)
2127 {
2128 while (ii < dest_len)
2129 {
2130 dest[ii] = front_staging[fronting];
2131 ++ii, ++fronting;
2132 }
2133 UNGCPRO;
2134 return;
2135 }
2136
2137 if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
2138 predicate, key_func)))
2139 {
2140 dest[ii] = front_staging[fronting];
2141 ++fronting;
2142 }
2143 else
2144 {
2145 dest[ii] = back_staging[backing];
2146 ++backing;
2147 }
2148 }
2149
2150 UNGCPRO;
2151 }
2152
2153 static Lisp_Object
2154 list_array_merge_into_list (Lisp_Object list,
2155 Lisp_Object *array, Elemcount array_len,
2156 Lisp_Object (*c_predicate) (Lisp_Object,
2157 Lisp_Object,
2158 Lisp_Object,
2159 Lisp_Object),
2160 Lisp_Object predicate, Lisp_Object key_func,
2161 Boolint reverse_order)
2162 {
2163 Lisp_Object tail = Qnil, value = Qnil;
2164 struct gcpro gcpro1, gcpro2, gcpro3;
2165 Elemcount array_index = 0;
2166 int looped = 0;
2167
2168 GCPRO3 (list, tail, value);
2169
2170 while (1)
2171 {
2172 if (NILP (list))
2173 {
2174 UNGCPRO;
2175
2176 if (NILP (tail))
2177 {
2178 return Flist (array_len, array);
2179 }
2180
2181 Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
2182 return value;
2183 }
2184
2185 if (array_index >= array_len)
2186 {
2187 UNGCPRO;
2188 if (NILP (tail))
2189 {
2190 return list;
2191 }
2192
2193 Fsetcdr (tail, list);
2194 return value;
2195 }
2196
2197
2198 if (reverse_order ?
2199 !NILP (c_predicate (Fcar (list), array [array_index], predicate,
2200 key_func)) :
2201 NILP (c_predicate (array [array_index], Fcar (list), predicate,
2202 key_func)))
2203 {
2204 if (NILP (tail))
2205 {
2206 value = tail = list;
2207 }
2208 else
2209 {
2210 Fsetcdr (tail, list);
2211 tail = XCDR (tail);
2212 }
2213
2214 list = Fcdr (list);
2215 }
2216 else
2217 {
2218 if (NILP (tail))
2219 {
2220 value = tail = Fcons (array [array_index], Qnil);
2221 }
2222 else
2223 {
2224 Fsetcdr (tail, Fcons (array [array_index], tail));
2225 tail = XCDR (tail);
2226 }
2227 ++array_index;
2228 }
2229
2230 if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2231
2232 {
2233 EXTERNAL_LIST_LOOP_1 (list)
2234 {
2235 }
2236 }
2237 }
2238 }
2239
2240 static void
2241 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
2242 Lisp_Object list_one, Lisp_Object list_two,
2243 Lisp_Object (*c_predicate) (Lisp_Object,
2244 Lisp_Object,
2245 Lisp_Object,
2246 Lisp_Object),
2247 Lisp_Object predicate, Lisp_Object key_func)
2248 {
2249 Elemcount output_index = 0;
2250
2251 while (output_index < output_len)
2252 {
2253 if (NILP (list_one))
2254 {
2255 while (output_index < output_len)
2256 {
2257 output [output_index] = Fcar (list_two);
2258 list_two = Fcdr (list_two), ++output_index;
2259 }
2260 return;
2261 }
2262
2263 if (NILP (list_two))
2264 {
2265 while (output_index < output_len)
2266 {
2267 output [output_index] = Fcar (list_one);
2268 list_one = Fcdr (list_one), ++output_index;
2269 }
2270 return;
2271 }
2272
2273 if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
2274 key_func)))
2275 {
2276 output [output_index] = XCAR (list_one);
2277 list_one = XCDR (list_one);
2278 }
2279 else
2280 {
2281 output [output_index] = XCAR (list_two);
2282 list_two = XCDR (list_two);
2283 }
2284
2285 ++output_index;
2286
2287 /* No need to check for circularity. */
2288 }
2289 }
2290
2291 static void
2292 list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
2293 Lisp_Object list,
2294 Lisp_Object *array, Elemcount array_len,
2295 Lisp_Object (*c_predicate) (Lisp_Object,
2296 Lisp_Object,
2297 Lisp_Object,
2298 Lisp_Object),
2299 Lisp_Object predicate, Lisp_Object key_func,
2300 Boolint reverse_order)
2301 {
2302 Elemcount output_index = 0, array_index = 0;
2303
2304 while (output_index < output_len)
2305 {
2306 if (NILP (list))
2307 {
2308 if (array_len - array_index != output_len - output_index)
2309 {
2310 invalid_state ("List length modified during merge", Qunbound);
2311 }
2312
2313 while (array_index < array_len)
2314 {
2315 output [output_index++] = array [array_index++];
2316 }
2317
2318 return;
2319 }
2320
2321 if (array_index >= array_len)
2322 {
2323 while (output_index < output_len)
2324 {
2325 output [output_index++] = Fcar (list);
2326 list = Fcdr (list);
2327 }
2328
2329 return;
2330 }
2331
2332 if (reverse_order ?
2333 !NILP (c_predicate (Fcar (list), array [array_index], predicate,
2334 key_func)) :
2335 NILP (c_predicate (array [array_index], Fcar (list), predicate,
2336 key_func)))
2337 {
2338 output [output_index] = XCAR (list);
2339 list = XCDR (list);
2340 }
2341 else
2342 {
2343 output [output_index] = array [array_index];
2344 ++array_index;
2345 }
2346
2347 ++output_index;
2348 }
2349 }
2350
2351 #define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
2352 do { \
2353 c_array = alloca_array (Lisp_Object, len); \
2354 for (counter = 0; counter < len; ++counter) \
2355 { \
2356 c_array[counter] = make_char (itext_ichar (strdata)); \
2357 INC_IBYTEPTR (strdata); \
2358 } \
2359 } while (0)
2360
2361 #define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
2362 c_array = alloca_array (Lisp_Object, len); \
2363 for (counter = 0; counter < len; ++counter) \
2364 { \
2365 c_array[counter] = make_int (bit_vector_bit (v, counter)); \
2366 } \
2367 } while (0)
2368
2369 /* This macro might eventually find a better home than here. */
2370
2371 #define CHECK_KEY_ARGUMENT(key, c_predicate) \
2372 do { \
2373 if (NILP (key)) \
2374 { \
2375 key = Qidentity; \
2376 } \
2377 \
2378 if (EQ (key, Qidentity)) \
2379 { \
2380 c_predicate = c_merge_predicate_nokey; \
2381 } \
2382 else \
2383 { \
2384 key = indirect_function (key, 1); \
2385 c_predicate = c_merge_predicate_key; \
2386 } \
2387 } while (0)
2388
2389 DEFUN ("merge", Fmerge, 4, MANY, 0, /*
2390 Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence.
2391
2392 TYPE is the type of sequence to return. PREDICATE is a `less-than'
2393 predicate on the elements.
2394
2395 Optional keyword argument KEY is a function used to extract an object to be
2396 used for comparison from each element of SEQUENCE-ONE and SEQUENCE-TWO.
2397
2398 arguments: (TYPE SEQUENCE-ONE SEQUENCE-TWO PREDICATE &key (KEY #'IDENTITY))
2399 */
2400 (int nargs, Lisp_Object *args))
2401 {
2402 Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
2403 predicate = args[3], result = Qnil;
2404 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
2405 Lisp_Object);
2406
2407 PARSE_KEYWORDS (Qmerge, nargs, args, 4, 1, (key), NULL, 0);
2408
2409 CHECK_SEQUENCE (sequence_one);
2410 CHECK_SEQUENCE (sequence_two);
2411
2412 CHECK_KEY_ARGUMENT (key, c_predicate);
2413
2414 if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
2415 {
2416 if (NILP (sequence_two))
2417 {
2418 result = Fappend (2, args + 1);
2419 }
2420 else if (NILP (sequence_one))
2421 {
2422 args[3] = Qnil; /* Overwriting PREDICATE, and losing its GC
2423 protection, but that doesn't matter. */
2424 result = Fappend (2, args + 2);
2425 }
2426 else if (CONSP (sequence_one) && CONSP (sequence_two))
2427 {
2428 result = list_merge (sequence_one, sequence_two, c_predicate,
2429 predicate, key);
2430 }
2431 else
2432 {
2433 Lisp_Object *array_storage, swap;
2434 Elemcount array_length, i;
2435 Boolint reverse_order = 0;
2436
2437 if (!CONSP (sequence_one))
2438 {
2439 /* Make sequence_one the cons, sequence_two the array: */
2440 swap = sequence_one;
2441 sequence_one = sequence_two;
2442 sequence_two = swap;
2443 reverse_order = 1;
2444 }
2445
2446 if (VECTORP (sequence_two))
2447 {
2448 array_storage = XVECTOR_DATA (sequence_two);
2449 array_length = XVECTOR_LENGTH (sequence_two);
2450 }
2451 else if (STRINGP (sequence_two))
2452 {
2453 Ibyte *strdata = XSTRING_DATA (sequence_two);
2454 array_length = string_char_length (sequence_two);
2455 /* No need to GCPRO, characters are immediate. */
2456 STRING_DATA_TO_OBJECT_ARRAY (strdata, array_storage, i,
2457 array_length);
2458
2459 }
2460 else
2461 {
2462 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence_two);
2463 array_length = bit_vector_length (v);
2464 /* No need to GCPRO, fixnums are immediate. */
2465 BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length);
2466 }
2467
2468 result = list_array_merge_into_list (sequence_one,
2469 array_storage, array_length,
2470 c_predicate,
2471 predicate, key,
2472 reverse_order);
2473 }
2474 }
2475 else
2476 {
2477 Elemcount sequence_one_len = XINT (Flength (sequence_one)),
2478 sequence_two_len = XINT (Flength (sequence_two)), i;
2479 Elemcount output_len = 1 + sequence_one_len + sequence_two_len;
2480 Lisp_Object *output = alloca_array (Lisp_Object, output_len),
2481 *sequence_one_storage = NULL, *sequence_two_storage = NULL;
2482 Boolint do_coerce = !(EQ (type, Qvector) || EQ (type, Qstring)
2483 || EQ (type, Qbit_vector) || EQ (type, Qlist));
2484 Ibyte *strdata = NULL;
2485 Lisp_Bit_Vector *v = NULL;
2486 struct gcpro gcpro1;
2487
2488 output[0] = do_coerce ? Qlist : type;
2489 for (i = 1; i < output_len; ++i)
2490 {
2491 output[i] = Qnil;
2492 }
2493
2494 GCPRO1 (output[0]);
2495 gcpro1.nvars = output_len;
2496
2497 if (VECTORP (sequence_one))
2498 {
2499 sequence_one_storage = XVECTOR_DATA (sequence_one);
2500 }
2501 else if (STRINGP (sequence_one))
2502 {
2503 strdata = XSTRING_DATA (sequence_one);
2504 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_one_storage,
2505 i, sequence_one_len);
2506 }
2507 else if (BIT_VECTORP (sequence_one))
2508 {
2509 v = XBIT_VECTOR (sequence_one);
2510 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_one_storage,
2511 i, sequence_one_len);
2512 }
2513
2514 if (VECTORP (sequence_two))
2515 {
2516 sequence_two_storage = XVECTOR_DATA (sequence_two);
2517 }
2518 else if (STRINGP (sequence_two))
2519 {
2520 strdata = XSTRING_DATA (sequence_two);
2521 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_two_storage,
2522 i, sequence_two_len);
2523 }
2524 else if (BIT_VECTORP (sequence_two))
2525 {
2526 v = XBIT_VECTOR (sequence_two);
2527 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_two_storage,
2528 i, sequence_two_len);
2529 }
2530
2531 if (LISTP (sequence_one) && LISTP (sequence_two))
2532 {
2533 list_list_merge_into_array (output + 1, output_len - 1,
2534 sequence_one, sequence_two,
2535 c_predicate, predicate,
2536 key);
2537 }
2538 else if (LISTP (sequence_one))
2539 {
2540 list_array_merge_into_array (output + 1, output_len - 1,
2541 sequence_one,
2542 sequence_two_storage,
2543 sequence_two_len,
2544 c_predicate, predicate,
2545 key, 0);
2546 }
2547 else if (LISTP (sequence_two))
2548 {
2549 list_array_merge_into_array (output + 1, output_len - 1,
2550 sequence_two,
2551 sequence_one_storage,
2552 sequence_one_len,
2553 c_predicate, predicate,
2554 key, 1);
2555 }
2556 else
2557 {
2558 array_merge (output + 1, output_len - 1,
2559 sequence_one_storage, sequence_one_len,
2560 sequence_two_storage, sequence_two_len,
2561 c_predicate, predicate,
2562 key);
2563 }
2564
2565 result = Ffuncall (output_len, output);
2566
2567 if (do_coerce)
2568 {
2569 result = call2 (Qcoerce, result, type);
2570 }
2571
2572 UNGCPRO;
2573 }
2574
2575 return result;
2576 }
2577
2578 /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
2579 NOTE: This is backwards from the way qsort() works. */
2580 Lisp_Object
2581 list_sort (Lisp_Object list,
2582 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2583 Lisp_Object, Lisp_Object),
2584 Lisp_Object predicate, Lisp_Object key_func)
2585 {
2586 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2587 Lisp_Object back, tem;
2588 Lisp_Object front = list;
2589 Lisp_Object len = Flength (list);
2590
2591 if (XINT (len) < 2)
2592 return list;
2593
2594 if (NULL == c_predicate)
2595 {
2596 c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey :
2597 c_merge_predicate_key;
2598 }
2599
2600 len = make_int (XINT (len) / 2 - 1);
2601 tem = Fnthcdr (len, list);
2602 back = Fcdr (tem);
2603 Fsetcdr (tem, Qnil);
2604
2605 GCPRO4 (front, back, predicate, key_func);
2606 front = list_sort (front, c_predicate, predicate, key_func);
2607 back = list_sort (back, c_predicate, predicate, key_func);
2608
2609 RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func));
2610 }
2611
2612 static void
2613 array_sort (Lisp_Object *array, Elemcount array_len,
2614 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2615 Lisp_Object, Lisp_Object),
2616 Lisp_Object predicate, Lisp_Object key_func)
2617 {
2618 Elemcount split;
2619
2620 if (array_len < 2)
2621 return;
2622
2623 split = array_len / 2;
2624
2625 array_sort (array, split, c_predicate, predicate, key_func);
2626 array_sort (array + split, array_len - split, c_predicate, predicate,
2627 key_func);
2628 array_merge (array, array_len, array, split, array + split,
2629 array_len - split, c_predicate, predicate, key_func);
2630 }
2631
2632 DEFUN ("sort*", FsortX, 2, MANY, 0, /*
2633 Sort SEQUENCE, comparing elements using PREDICATE.
2634 Returns the sorted sequence. SEQUENCE is modified by side effect.
2635
2636 PREDICATE is called with two elements of SEQUENCE, and should return t if
2637 the first element is `less' than the second.
2638
2639 Optional keyword argument KEY is a function used to extract an object to be
2640 used for comparison from each element of SEQUENCE.
2641
2642 In this implementation, sorting is always stable; but call `stable-sort' if
2643 this stability is important to you, other implementations may not make the
2644 same guarantees.
2645
2646 arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))
2647 */
2648 (int nargs, Lisp_Object *args))
2649 {
2650 Lisp_Object sequence = args[0], predicate = args[1];
2651 Lisp_Object *sequence_carray;
2652 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
2653 Lisp_Object);
2654 Elemcount sequence_len, i;
2655
2656 PARSE_KEYWORDS (QsortX, nargs, args, 2, 1, (key), NULL, 0);
2657
2658 CHECK_SEQUENCE (sequence);
2659
2660 CHECK_KEY_ARGUMENT (key, c_predicate);
2661
2662 if (LISTP (sequence))
2663 {
2664 sequence = list_sort (sequence, c_predicate, predicate, key);
2665 }
2666 else if (VECTORP (sequence))
2667 {
2668 array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
2669 c_predicate, predicate, key);
2670 }
2671 else if (STRINGP (sequence))
2672 {
2673 Ibyte *strdata = XSTRING_DATA (sequence);
2674 Elemcount string_ascii_begin = 0;
2675 Ichar ch;
2676
2677 sequence_len = string_char_length (sequence);
2678
2679 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
2680
2681 /* No GCPRO necessary, characters are immediate. */
2682 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
2683
2684 strdata = XSTRING_DATA (sequence);
2685
2686 CHECK_LISP_WRITEABLE (sequence);
2687 for (i = 0; i < sequence_len; ++i)
2688 {
2689 ch = XCHAR (sequence_carray[i]);
2690 strdata += set_itext_ichar (strdata, ch);
2691
2692 if (string_ascii_begin <= i)
2693 {
2694 if (byte_ascii_p (ch))
2695 {
2696 string_ascii_begin = i;
2697 }
2698 else
2699 {
2700 string_ascii_begin = MAX_STRING_ASCII_BEGIN;
2701 }
2702 }
2703 }
2704
2705 XSET_STRING_ASCII_BEGIN (sequence, min (string_ascii_begin,
2706 MAX_STRING_ASCII_BEGIN));
2707 bump_string_modiff (sequence);
2708 sledgehammer_check_ascii_begin (sequence);
2709 }
2710 else if (BIT_VECTORP (sequence))
2711 {
2712 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
2713 sequence_len = bit_vector_length (v);
2714
2715 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
2716
2717 /* No GCPRO necessary, bits are immediate. */
2718 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
2719
2720 for (i = 0; i < sequence_len; ++i)
2721 {
2722 set_bit_vector_bit (v, i, XINT (sequence_carray [i]));
2723 }
2724 }
2725
2726 return sequence;
2727 }
2073 2728
2074 /************************************************************************/ 2729 /************************************************************************/
2075 /* property-list functions */ 2730 /* property-list functions */
2076 /************************************************************************/ 2731 /************************************************************************/
2077 2732
3122 { 3777 {
3123 return internal_old_equal (object1, object2, 0) ? Qt : Qnil; 3778 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
3124 } 3779 }
3125 3780
3126 3781
3127 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* 3782 DEFUN ("fill", Ffill, 2, MANY, 0, /*
3128 Destructively modify ARRAY by replacing each element with ITEM. 3783 Destructively modify SEQUENCE by replacing each element with ITEM.
3129 ARRAY is a vector, bit vector, or string. 3784 SEQUENCE is a list, vector, bit vector, or string.
3130 */ 3785
3131 (array, item)) 3786 Optional keyword START is the index of the first element of SEQUENCE
3132 { 3787 to be modified, and defaults to zero. Optional keyword END is the
3788 exclusive upper bound on the elements of SEQUENCE to be modified, and
3789 defaults to the length of SEQUENCE.
3790
3791 arguments: (SEQUENCE ITEM &key (START 0) END)
3792 */
3793 (int nargs, Lisp_Object *args))
3794 {
3795 Lisp_Object sequence = args[0];
3796 Lisp_Object item = args[1];
3797 Elemcount starting = 0, ending = EMACS_INT_MAX, ii;
3798
3799 PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end),
3800 (start = Qzero, end = Qunbound), 0);
3801
3802 CHECK_NATNUM (start);
3803 starting = XINT (start);
3804
3805 if (!UNBOUNDP (end))
3806 {
3807 CHECK_NATNUM (end);
3808 ending = XINT (end);
3809 }
3810
3133 retry: 3811 retry:
3134 if (STRINGP (array)) 3812 if (STRINGP (sequence))
3135 { 3813 {
3136 Bytecount old_bytecount = XSTRING_LENGTH (array); 3814 Bytecount old_bytecount, new_bytecount, item_bytecount;
3137 Bytecount new_bytecount;
3138 Bytecount item_bytecount;
3139 Ibyte item_buf[MAX_ICHAR_LEN]; 3815 Ibyte item_buf[MAX_ICHAR_LEN];
3140 Ibyte *p; 3816 Ibyte *p;
3141 Ibyte *end; 3817 Ibyte *pend;
3142 3818
3143 CHECK_CHAR_COERCE_INT (item); 3819 CHECK_CHAR_COERCE_INT (item);
3144 3820
3145 CHECK_LISP_WRITEABLE (array); 3821 CHECK_LISP_WRITEABLE (sequence);
3146 sledgehammer_check_ascii_begin (array); 3822 sledgehammer_check_ascii_begin (sequence);
3147 item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); 3823 item_bytecount = set_itext_ichar (item_buf, XCHAR (item));
3148 new_bytecount = item_bytecount * (Bytecount) string_char_length (array); 3824
3149 3825 p = XSTRING_DATA (sequence);
3150 resize_string (array, -1, new_bytecount - old_bytecount); 3826 p = (Ibyte *) itext_n_addr (p, starting);
3151 3827 old_bytecount = p - XSTRING_DATA (sequence);
3152 for (p = XSTRING_DATA (array), end = p + new_bytecount; 3828
3153 p < end; 3829 ending = min (ending, string_char_length (sequence));
3154 p += item_bytecount) 3830 pend = (Ibyte *) itext_n_addr (p, ending - starting);
3831
3832 new_bytecount = old_bytecount + (item_bytecount * (ending - starting));
3833 resize_string (sequence, -1, new_bytecount - old_bytecount);
3834
3835 for (; p < pend; p += item_bytecount)
3155 memcpy (p, item_buf, item_bytecount); 3836 memcpy (p, item_buf, item_bytecount);
3156 *p = '\0'; 3837 *p = '\0';
3157 3838
3158 XSET_STRING_ASCII_BEGIN (array, 3839 XSET_STRING_ASCII_BEGIN (sequence,
3159 item_bytecount == 1 ? 3840 item_bytecount == 1 ?
3160 min (new_bytecount, MAX_STRING_ASCII_BEGIN) : 3841 min (new_bytecount, MAX_STRING_ASCII_BEGIN) :
3161 0); 3842 0);
3162 bump_string_modiff (array); 3843 bump_string_modiff (sequence);
3163 sledgehammer_check_ascii_begin (array); 3844 sledgehammer_check_ascii_begin (sequence);
3164 } 3845 }
3165 else if (VECTORP (array)) 3846 else if (VECTORP (sequence))
3166 { 3847 {
3167 Lisp_Object *p = XVECTOR_DATA (array); 3848 Lisp_Object *p = XVECTOR_DATA (sequence);
3168 Elemcount len = XVECTOR_LENGTH (array); 3849 CHECK_LISP_WRITEABLE (sequence);
3169 CHECK_LISP_WRITEABLE (array); 3850
3170 while (len--) 3851 ending = min (ending, XVECTOR_LENGTH (sequence));
3171 *p++ = item; 3852 for (ii = starting; ii < ending; ++ii)
3172 } 3853 {
3173 else if (BIT_VECTORP (array)) 3854 p[ii] = item;
3174 { 3855 }
3175 Lisp_Bit_Vector *v = XBIT_VECTOR (array); 3856 }
3176 Elemcount len = bit_vector_length (v); 3857 else if (BIT_VECTORP (sequence))
3858 {
3859 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3177 int bit; 3860 int bit;
3178 CHECK_BIT (item); 3861 CHECK_BIT (item);
3179 bit = XINT (item); 3862 bit = XINT (item);
3180 CHECK_LISP_WRITEABLE (array); 3863 CHECK_LISP_WRITEABLE (sequence);
3181 while (len--) 3864
3182 set_bit_vector_bit (v, len, bit); 3865 ending = min (ending, bit_vector_length (v));
3866 for (ii = starting; ii < ending; ++ii)
3867 {
3868 set_bit_vector_bit (v, ii, bit);
3869 }
3870 }
3871 else if (LISTP (sequence))
3872 {
3873 Elemcount counting = 0;
3874
3875 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
3876 {
3877 if (counting >= starting)
3878 {
3879 if (counting < ending)
3880 {
3881 XSETCAR (tail, item);
3882 }
3883 else if (counting == ending)
3884 {
3885 break;
3886 }
3887 }
3888 ++counting;
3889 }
3183 } 3890 }
3184 else 3891 else
3185 { 3892 {
3186 array = wrong_type_argument (Qarrayp, array); 3893 sequence = wrong_type_argument (Qsequencep, sequence);
3187 goto retry; 3894 goto retry;
3188 } 3895 }
3189 return array; 3896 return sequence;
3190 } 3897 }
3191 3898
3192 Lisp_Object 3899 Lisp_Object
3193 nconc2 (Lisp_Object arg1, Lisp_Object arg2) 3900 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
3194 { 3901 {
4756 syms_of_fns (void) 5463 syms_of_fns (void)
4757 { 5464 {
4758 INIT_LISP_OBJECT (bit_vector); 5465 INIT_LISP_OBJECT (bit_vector);
4759 5466
4760 DEFSYMBOL (Qstring_lessp); 5467 DEFSYMBOL (Qstring_lessp);
5468 DEFSYMBOL (Qsort);
5469 DEFSYMBOL (Qmerge);
5470 DEFSYMBOL (Qfill);
4761 DEFSYMBOL (Qidentity); 5471 DEFSYMBOL (Qidentity);
4762 DEFSYMBOL (Qvector); 5472 DEFSYMBOL (Qvector);
4763 DEFSYMBOL (Qarray); 5473 DEFSYMBOL (Qarray);
4764 DEFSYMBOL (Qstring); 5474 DEFSYMBOL (Qstring);
4765 DEFSYMBOL (Qlist); 5475 DEFSYMBOL (Qlist);
4766 DEFSYMBOL (Qbit_vector); 5476 DEFSYMBOL (Qbit_vector);
5477 defsymbol (&QsortX, "sort*");
4767 5478
4768 DEFSYMBOL (Qyes_or_no_p); 5479 DEFSYMBOL (Qyes_or_no_p);
4769 5480
4770 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); 5481 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error);
4771 5482
4812 DEFSUBR (Fremassq); 5523 DEFSUBR (Fremassq);
4813 DEFSUBR (Fremrassoc); 5524 DEFSUBR (Fremrassoc);
4814 DEFSUBR (Fremrassq); 5525 DEFSUBR (Fremrassq);
4815 DEFSUBR (Fnreverse); 5526 DEFSUBR (Fnreverse);
4816 DEFSUBR (Freverse); 5527 DEFSUBR (Freverse);
4817 DEFSUBR (Fsort); 5528 DEFSUBR (FsortX);
5529 Ffset (intern ("sort"), QsortX);
5530 DEFSUBR (Fmerge);
4818 DEFSUBR (Fplists_eq); 5531 DEFSUBR (Fplists_eq);
4819 DEFSUBR (Fplists_equal); 5532 DEFSUBR (Fplists_equal);
4820 DEFSUBR (Flax_plists_eq); 5533 DEFSUBR (Flax_plists_eq);
4821 DEFSUBR (Flax_plists_equal); 5534 DEFSUBR (Flax_plists_equal);
4822 DEFSUBR (Fplist_get); 5535 DEFSUBR (Fplist_get);
4837 DEFSUBR (Fremprop); 5550 DEFSUBR (Fremprop);
4838 DEFSUBR (Fobject_plist); 5551 DEFSUBR (Fobject_plist);
4839 DEFSUBR (Fequal); 5552 DEFSUBR (Fequal);
4840 DEFSUBR (Fequalp); 5553 DEFSUBR (Fequalp);
4841 DEFSUBR (Fold_equal); 5554 DEFSUBR (Fold_equal);
4842 DEFSUBR (Ffillarray); 5555 DEFSUBR (Ffill);
5556 Ffset (intern ("fillarray"), Qfill);
5557
4843 DEFSUBR (Fnconc); 5558 DEFSUBR (Fnconc);
4844 DEFSUBR (FmapcarX); 5559 DEFSUBR (FmapcarX);
4845 DEFSUBR (Fmapvector); 5560 DEFSUBR (Fmapvector);
4846 DEFSUBR (Fmapcan); 5561 DEFSUBR (Fmapcan);
4847 DEFSUBR (Fmapc); 5562 DEFSUBR (Fmapc);