Mercurial > hg > xemacs-beta
annotate src/fns.c @ 5167:e374ea766cc1
clean up, rearrange allocation statistics code
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-21 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (assert_proper_sizing):
* alloc.c (c_readonly):
* alloc.c (malloced_storage_size):
* alloc.c (fixed_type_block_overhead):
* alloc.c (lisp_object_storage_size):
* alloc.c (inc_lrecord_stats):
* alloc.c (dec_lrecord_stats):
* alloc.c (pluralize_word):
* alloc.c (object_memory_usage_stats):
* alloc.c (Fobject_memory_usage):
* alloc.c (compute_memusage_stats_length):
* alloc.c (disksave_object_finalization_1):
* alloc.c (Fgarbage_collect):
* mc-alloc.c:
* mc-alloc.c (mc_alloced_storage_size):
* mc-alloc.h:
No functionality change here. Collect the allocations-statistics
code that was scattered throughout alloc.c into one place. Add
remaining section headings so that all sections have headings
clearly identifying the start of the section and its purpose.
Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS;
this fixes build problems and is related to the export of
lisp_object_storage_size() and malloced_storage_size() when
non-MEMORY_USAGE_STATS in the previous change set.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sun, 21 Mar 2010 04:41:49 -0500 |
parents | 7be849cb8828 |
children | 2e528066e2fc |
rev | line source |
---|---|
428 | 1 /* Random utility Lisp functions. |
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing. |
428 | 4 |
5 This file is part of XEmacs. | |
6 | |
7 XEmacs is free software; you can redistribute it and/or modify it | |
8 under the terms of the GNU General Public License as published by the | |
9 Free Software Foundation; either version 2, or (at your option) any | |
10 later version. | |
11 | |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with XEmacs; see the file COPYING. If not, write to | |
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 Boston, MA 02111-1307, USA. */ | |
21 | |
22 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
23 | |
24 /* This file has been Mule-ized. */ | |
25 | |
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */ | |
27 | |
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */ | |
29 | |
30 #include <config.h> | |
31 | |
32 /* Note on some machines this defines `vector' as a typedef, | |
33 so make sure we don't use that name in this file. */ | |
34 #undef vector | |
35 #define vector ***** | |
36 | |
37 #include "lisp.h" | |
38 | |
442 | 39 #include "sysfile.h" |
771 | 40 #include "sysproc.h" /* for qxe_getpid() */ |
428 | 41 |
42 #include "buffer.h" | |
43 #include "bytecode.h" | |
44 #include "device.h" | |
45 #include "events.h" | |
46 #include "extents.h" | |
47 #include "frame.h" | |
872 | 48 #include "process.h" |
428 | 49 #include "systime.h" |
50 #include "insdel.h" | |
51 #include "lstream.h" | |
52 #include "opaque.h" | |
53 | |
54 /* NOTE: This symbol is also used in lread.c */ | |
55 #define FEATUREP_SYNTAX | |
56 | |
57 Lisp_Object Qstring_lessp; | |
58 Lisp_Object Qidentity; | |
5002
0cd784a6ec44
fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents:
5001
diff
changeset
|
59 Lisp_Object Qvector, Qarray, Qbit_vector; |
428 | 60 |
563 | 61 Lisp_Object Qbase64_conversion_error; |
62 | |
771 | 63 Lisp_Object Vpath_separator; |
64 | |
428 | 65 static int internal_old_equal (Lisp_Object, Lisp_Object, int); |
454 | 66 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); |
428 | 67 |
68 static Lisp_Object | |
2286 | 69 mark_bit_vector (Lisp_Object UNUSED (obj)) |
428 | 70 { |
71 return Qnil; | |
72 } | |
73 | |
74 static void | |
2286 | 75 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, |
76 int UNUSED (escapeflag)) | |
428 | 77 { |
665 | 78 Elemcount i; |
440 | 79 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
665 | 80 Elemcount len = bit_vector_length (v); |
81 Elemcount last = len; | |
428 | 82 |
83 if (INTP (Vprint_length)) | |
84 last = min (len, XINT (Vprint_length)); | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
85 write_ascstring (printcharfun, "#*"); |
428 | 86 for (i = 0; i < last; i++) |
87 { | |
88 if (bit_vector_bit (v, i)) | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
89 write_ascstring (printcharfun, "1"); |
428 | 90 else |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
91 write_ascstring (printcharfun, "0"); |
428 | 92 } |
93 | |
94 if (last != len) | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
95 write_ascstring (printcharfun, "..."); |
428 | 96 } |
97 | |
98 static int | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
99 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
100 int UNUSED (foldcase)) |
428 | 101 { |
440 | 102 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); |
103 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); | |
428 | 104 |
105 return ((bit_vector_length (v1) == bit_vector_length (v2)) && | |
106 !memcmp (v1->bits, v2->bits, | |
107 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) * | |
108 sizeof (long))); | |
109 } | |
110 | |
665 | 111 static Hashcode |
2286 | 112 bit_vector_hash (Lisp_Object obj, int UNUSED (depth)) |
428 | 113 { |
440 | 114 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
428 | 115 return HASH2 (bit_vector_length (v), |
116 memory_hash (v->bits, | |
117 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * | |
118 sizeof (long))); | |
119 } | |
120 | |
665 | 121 static Bytecount |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
122 size_bit_vector (Lisp_Object obj) |
442 | 123 { |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
124 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
456 | 125 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, |
442 | 126 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); |
127 } | |
128 | |
1204 | 129 static const struct memory_description bit_vector_description[] = { |
428 | 130 { XD_END } |
131 }; | |
132 | |
133 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
134 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("bit-vector", bit_vector, |
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
135 mark_bit_vector, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
136 print_bit_vector, 0, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
137 bit_vector_equal, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
138 bit_vector_hash, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
139 bit_vector_description, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
140 size_bit_vector, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
141 Lisp_Bit_Vector); |
934 | 142 |
428 | 143 |
144 DEFUN ("identity", Fidentity, 1, 1, 0, /* | |
145 Return the argument unchanged. | |
146 */ | |
147 (arg)) | |
148 { | |
149 return arg; | |
150 } | |
151 | |
152 DEFUN ("random", Frandom, 0, 1, 0, /* | |
153 Return a pseudo-random number. | |
1983 | 154 All fixnums are equally likely. On most systems, this is 31 bits' worth. |
428 | 155 With positive integer argument N, return random number in interval [0,N). |
1983 | 156 N can be a bignum, in which case the range of possible values is extended. |
428 | 157 With argument t, set the random number seed from the current time and pid. |
158 */ | |
159 (limit)) | |
160 { | |
161 EMACS_INT val; | |
162 unsigned long denominator; | |
163 | |
164 if (EQ (limit, Qt)) | |
771 | 165 seed_random (qxe_getpid () + time (NULL)); |
428 | 166 if (NATNUMP (limit) && !ZEROP (limit)) |
167 { | |
168 /* Try to take our random number from the higher bits of VAL, | |
169 not the lower, since (says Gentzel) the low bits of `random' | |
170 are less random than the higher ones. We do this by using the | |
171 quotient rather than the remainder. At the high end of the RNG | |
172 it's possible to get a quotient larger than limit; discarding | |
173 these values eliminates the bias that would otherwise appear | |
174 when using a large limit. */ | |
2039 | 175 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit); |
428 | 176 do |
177 val = get_random () / denominator; | |
178 while (val >= XINT (limit)); | |
179 } | |
1983 | 180 #ifdef HAVE_BIGNUM |
181 else if (BIGNUMP (limit)) | |
182 { | |
183 bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); | |
184 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
185 } | |
186 #endif | |
428 | 187 else |
188 val = get_random (); | |
189 | |
190 return make_int (val); | |
191 } | |
192 | |
193 /* Random data-structure functions */ | |
194 | |
195 #ifdef LOSING_BYTECODE | |
196 | |
197 /* #### Delete this shit */ | |
198 | |
199 /* Charcount is a misnomer here as we might be dealing with the | |
200 length of a vector or list, but emphasizes that we're not dealing | |
201 with Bytecounts in strings */ | |
202 static Charcount | |
203 length_with_bytecode_hack (Lisp_Object seq) | |
204 { | |
205 if (!COMPILED_FUNCTIONP (seq)) | |
206 return XINT (Flength (seq)); | |
207 else | |
208 { | |
440 | 209 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); |
428 | 210 |
211 return (f->flags.interactivep ? COMPILED_INTERACTIVE : | |
212 f->flags.domainp ? COMPILED_DOMAIN : | |
213 COMPILED_DOC_STRING) | |
214 + 1; | |
215 } | |
216 } | |
217 | |
218 #endif /* LOSING_BYTECODE */ | |
219 | |
220 void | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
221 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq) |
428 | 222 { |
223 if (COMPILED_FUNCTIONP (seq)) | |
563 | 224 signal_ferror_with_frob |
225 (Qinvalid_argument, seq, | |
428 | 226 "As of 20.3, `%s' no longer works with compiled-function objects", |
227 function); | |
228 } | |
229 | |
230 DEFUN ("length", Flength, 1, 1, 0, /* | |
231 Return the length of vector, bit vector, list or string SEQUENCE. | |
232 */ | |
233 (sequence)) | |
234 { | |
235 retry: | |
236 if (STRINGP (sequence)) | |
826 | 237 return make_int (string_char_length (sequence)); |
428 | 238 else if (CONSP (sequence)) |
239 { | |
665 | 240 Elemcount len; |
428 | 241 GET_EXTERNAL_LIST_LENGTH (sequence, len); |
242 return make_int (len); | |
243 } | |
244 else if (VECTORP (sequence)) | |
245 return make_int (XVECTOR_LENGTH (sequence)); | |
246 else if (NILP (sequence)) | |
247 return Qzero; | |
248 else if (BIT_VECTORP (sequence)) | |
249 return make_int (bit_vector_length (XBIT_VECTOR (sequence))); | |
250 else | |
251 { | |
252 check_losing_bytecode ("length", sequence); | |
253 sequence = wrong_type_argument (Qsequencep, sequence); | |
254 goto retry; | |
255 } | |
256 } | |
257 | |
258 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* | |
259 Return the length of a list, but avoid error or infinite loop. | |
260 This function never gets an error. If LIST is not really a list, | |
261 it returns 0. If LIST is circular, it returns a finite value | |
262 which is at least the number of distinct elements. | |
263 */ | |
264 (list)) | |
265 { | |
266 Lisp_Object hare, tortoise; | |
665 | 267 Elemcount len; |
428 | 268 |
269 for (hare = tortoise = list, len = 0; | |
270 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); | |
271 hare = XCDR (hare), len++) | |
272 { | |
273 if (len & 1) | |
274 tortoise = XCDR (tortoise); | |
275 } | |
276 | |
277 return make_int (len); | |
278 } | |
279 | |
280 /*** string functions. ***/ | |
281 | |
282 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* | |
283 Return t if two strings have identical contents. | |
284 Case is significant. Text properties are ignored. | |
285 \(Under XEmacs, `equal' also ignores text properties and extents in | |
286 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20 | |
287 `equal' is the same as in XEmacs, in that respect.) | |
288 Symbols are also allowed; their print names are used instead. | |
289 */ | |
444 | 290 (string1, string2)) |
428 | 291 { |
292 Bytecount len; | |
793 | 293 Lisp_Object p1, p2; |
428 | 294 |
444 | 295 if (SYMBOLP (string1)) |
296 p1 = XSYMBOL (string1)->name; | |
428 | 297 else |
298 { | |
444 | 299 CHECK_STRING (string1); |
793 | 300 p1 = string1; |
428 | 301 } |
302 | |
444 | 303 if (SYMBOLP (string2)) |
304 p2 = XSYMBOL (string2)->name; | |
428 | 305 else |
306 { | |
444 | 307 CHECK_STRING (string2); |
793 | 308 p2 = string2; |
428 | 309 } |
310 | |
793 | 311 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) && |
312 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil; | |
428 | 313 } |
314 | |
801 | 315 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /* |
316 Compare the contents of two strings, maybe ignoring case. | |
317 In string STR1, skip the first START1 characters and stop at END1. | |
318 In string STR2, skip the first START2 characters and stop at END2. | |
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
319 END1 and END2 default to the full lengths of the respective strings, |
4797
a5eca70cf401
Fix typo in last patch.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4796
diff
changeset
|
320 and arguments that are outside the string (negative STARTi or ENDi |
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
321 greater than length) are coerced to 0 or string length as appropriate. |
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
322 |
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
323 Optional IGNORE-CASE non-nil means use case-insensitive comparison. |
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
324 Case is significant by default. |
801 | 325 |
326 The value is t if the strings (or specified portions) match. | |
327 If string STR1 is less, the value is a negative number N; | |
328 - 1 - N is the number of characters that match at the beginning. | |
329 If string STR1 is greater, the value is a positive number N; | |
330 N - 1 is the number of characters that match at the beginning. | |
331 */ | |
332 (str1, start1, end1, str2, start2, end2, ignore_case)) | |
333 { | |
334 Charcount ccstart1, ccend1, ccstart2, ccend2; | |
335 Bytecount bstart1, blen1, bstart2, blen2; | |
336 Charcount matching; | |
337 int res; | |
338 | |
339 CHECK_STRING (str1); | |
340 CHECK_STRING (str2); | |
341 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1, | |
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
342 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
801 | 343 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2, |
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
344 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
801 | 345 |
346 bstart1 = string_index_char_to_byte (str1, ccstart1); | |
347 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1); | |
348 bstart2 = string_index_char_to_byte (str2, ccstart2); | |
349 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2); | |
350 | |
351 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching) | |
352 (XSTRING_DATA (str1) + bstart1, blen1, | |
353 XSTRING_DATA (str2) + bstart2, blen2, | |
354 &matching)); | |
355 | |
356 if (!res) | |
357 return Qt; | |
358 else if (res > 0) | |
359 return make_int (1 + matching); | |
360 else | |
361 return make_int (-1 - matching); | |
362 } | |
363 | |
428 | 364 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /* |
365 Return t if first arg string is less than second in lexicographic order. | |
771 | 366 Comparison is simply done on a character-by-character basis using the |
367 numeric value of a character. (Note that this may not produce | |
368 particularly meaningful results under Mule if characters from | |
369 different charsets are being compared.) | |
428 | 370 |
371 Symbols are also allowed; their print names are used instead. | |
372 | |
771 | 373 Currently we don't do proper language-specific collation or handle |
374 multiple character sets. This may be changed when Unicode support | |
375 is implemented. | |
428 | 376 */ |
444 | 377 (string1, string2)) |
428 | 378 { |
793 | 379 Lisp_Object p1, p2; |
428 | 380 Charcount end, len2; |
381 int i; | |
382 | |
444 | 383 if (SYMBOLP (string1)) |
384 p1 = XSYMBOL (string1)->name; | |
793 | 385 else |
386 { | |
444 | 387 CHECK_STRING (string1); |
793 | 388 p1 = string1; |
428 | 389 } |
390 | |
444 | 391 if (SYMBOLP (string2)) |
392 p2 = XSYMBOL (string2)->name; | |
428 | 393 else |
394 { | |
444 | 395 CHECK_STRING (string2); |
793 | 396 p2 = string2; |
428 | 397 } |
398 | |
826 | 399 end = string_char_length (p1); |
400 len2 = string_char_length (p2); | |
428 | 401 if (end > len2) |
402 end = len2; | |
403 | |
404 { | |
867 | 405 Ibyte *ptr1 = XSTRING_DATA (p1); |
406 Ibyte *ptr2 = XSTRING_DATA (p2); | |
428 | 407 |
408 /* #### It is not really necessary to do this: We could compare | |
409 byte-by-byte and still get a reasonable comparison, since this | |
410 would compare characters with a charset in the same way. With | |
411 a little rearrangement of the leading bytes, we could make most | |
412 inter-charset comparisons work out the same, too; even if some | |
413 don't, this is not a big deal because inter-charset comparisons | |
414 aren't really well-defined anyway. */ | |
415 for (i = 0; i < end; i++) | |
416 { | |
867 | 417 if (itext_ichar (ptr1) != itext_ichar (ptr2)) |
418 return itext_ichar (ptr1) < itext_ichar (ptr2) ? Qt : Qnil; | |
419 INC_IBYTEPTR (ptr1); | |
420 INC_IBYTEPTR (ptr2); | |
428 | 421 } |
422 } | |
423 /* Can't do i < len2 because then comparison between "foo" and "foo^@" | |
424 won't work right in I18N2 case */ | |
425 return end < len2 ? Qt : Qnil; | |
426 } | |
427 | |
428 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /* | |
429 Return STRING's tick counter, incremented for each change to the string. | |
430 Each string has a tick counter which is incremented each time the contents | |
431 of the string are changed (e.g. with `aset'). It wraps around occasionally. | |
432 */ | |
433 (string)) | |
434 { | |
435 CHECK_STRING (string); | |
793 | 436 if (CONSP (XSTRING_PLIST (string)) && INTP (XCAR (XSTRING_PLIST (string)))) |
437 return XCAR (XSTRING_PLIST (string)); | |
428 | 438 else |
439 return Qzero; | |
440 } | |
441 | |
442 void | |
443 bump_string_modiff (Lisp_Object str) | |
444 { | |
793 | 445 Lisp_Object *ptr = &XSTRING_PLIST (str); |
428 | 446 |
447 #ifdef I18N3 | |
448 /* #### remove the `string-translatable' property from the string, | |
449 if there is one. */ | |
450 #endif | |
451 /* skip over extent info if it's there */ | |
452 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
453 ptr = &XCDR (*ptr); | |
454 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
793 | 455 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr))); |
428 | 456 else |
457 *ptr = Fcons (make_int (1), *ptr); | |
458 } | |
459 | |
460 | |
461 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector }; | |
462 static Lisp_Object concat (int nargs, Lisp_Object *args, | |
463 enum concat_target_type target_type, | |
464 int last_special); | |
465 | |
466 Lisp_Object | |
444 | 467 concat2 (Lisp_Object string1, Lisp_Object string2) |
428 | 468 { |
469 Lisp_Object args[2]; | |
444 | 470 args[0] = string1; |
471 args[1] = string2; | |
428 | 472 return concat (2, args, c_string, 0); |
473 } | |
474 | |
475 Lisp_Object | |
444 | 476 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3) |
428 | 477 { |
478 Lisp_Object args[3]; | |
444 | 479 args[0] = string1; |
480 args[1] = string2; | |
481 args[2] = string3; | |
428 | 482 return concat (3, args, c_string, 0); |
483 } | |
484 | |
485 Lisp_Object | |
444 | 486 vconcat2 (Lisp_Object vec1, Lisp_Object vec2) |
428 | 487 { |
488 Lisp_Object args[2]; | |
444 | 489 args[0] = vec1; |
490 args[1] = vec2; | |
428 | 491 return concat (2, args, c_vector, 0); |
492 } | |
493 | |
494 Lisp_Object | |
444 | 495 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3) |
428 | 496 { |
497 Lisp_Object args[3]; | |
444 | 498 args[0] = vec1; |
499 args[1] = vec2; | |
500 args[2] = vec3; | |
428 | 501 return concat (3, args, c_vector, 0); |
502 } | |
503 | |
504 DEFUN ("append", Fappend, 0, MANY, 0, /* | |
505 Concatenate all the arguments and make the result a list. | |
506 The result is a list whose elements are the elements of all the arguments. | |
507 Each argument may be a list, vector, bit vector, or string. | |
508 The last argument is not copied, just used as the tail of the new list. | |
509 Also see: `nconc'. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
510 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
511 arguments: (&rest ARGS) |
428 | 512 */ |
513 (int nargs, Lisp_Object *args)) | |
514 { | |
515 return concat (nargs, args, c_cons, 1); | |
516 } | |
517 | |
518 DEFUN ("concat", Fconcat, 0, MANY, 0, /* | |
519 Concatenate all the arguments and make the result a string. | |
520 The result is a string whose elements are the elements of all the arguments. | |
521 Each argument may be a string or a list or vector of characters. | |
522 | |
523 As of XEmacs 21.0, this function does NOT accept individual integers | |
524 as arguments. Old code that relies on, for example, (concat "foo" 50) | |
525 returning "foo50" will fail. To fix such code, either apply | |
526 `int-to-string' to the integer argument, or use `format'. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
527 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
528 arguments: (&rest ARGS) |
428 | 529 */ |
530 (int nargs, Lisp_Object *args)) | |
531 { | |
532 return concat (nargs, args, c_string, 0); | |
533 } | |
534 | |
535 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /* | |
536 Concatenate all the arguments and make the result a vector. | |
537 The result is a vector whose elements are the elements of all the arguments. | |
538 Each argument may be a list, vector, bit vector, or string. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
539 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
540 arguments: (&rest ARGS) |
428 | 541 */ |
542 (int nargs, Lisp_Object *args)) | |
543 { | |
544 return concat (nargs, args, c_vector, 0); | |
545 } | |
546 | |
547 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /* | |
548 Concatenate all the arguments and make the result a bit vector. | |
549 The result is a bit vector whose elements are the elements of all the | |
550 arguments. Each argument may be a list, vector, bit vector, or string. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
551 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
552 arguments: (&rest ARGS) |
428 | 553 */ |
554 (int nargs, Lisp_Object *args)) | |
555 { | |
556 return concat (nargs, args, c_bit_vector, 0); | |
557 } | |
558 | |
559 /* Copy a (possibly dotted) list. LIST must be a cons. | |
560 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ | |
561 static Lisp_Object | |
562 copy_list (Lisp_Object list) | |
563 { | |
564 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); | |
565 Lisp_Object last = list_copy; | |
566 Lisp_Object hare, tortoise; | |
665 | 567 Elemcount len; |
428 | 568 |
569 for (tortoise = hare = XCDR (list), len = 1; | |
570 CONSP (hare); | |
571 hare = XCDR (hare), len++) | |
572 { | |
573 XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); | |
574 last = XCDR (last); | |
575 | |
576 if (len < CIRCULAR_LIST_SUSPICION_LENGTH) | |
577 continue; | |
578 if (len & 1) | |
579 tortoise = XCDR (tortoise); | |
580 if (EQ (tortoise, hare)) | |
581 signal_circular_list_error (list); | |
582 } | |
583 | |
584 return list_copy; | |
585 } | |
586 | |
587 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* | |
588 Return a copy of list LIST, which may be a dotted list. | |
589 The elements of LIST are not copied; they are shared | |
590 with the original. | |
591 */ | |
592 (list)) | |
593 { | |
594 again: | |
595 if (NILP (list)) return list; | |
596 if (CONSP (list)) return copy_list (list); | |
597 | |
598 list = wrong_type_argument (Qlistp, list); | |
599 goto again; | |
600 } | |
601 | |
602 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* | |
603 Return a copy of list, vector, bit vector or string SEQUENCE. | |
604 The elements of a list or vector are not copied; they are shared | |
605 with the original. SEQUENCE may be a dotted list. | |
606 */ | |
607 (sequence)) | |
608 { | |
609 again: | |
610 if (NILP (sequence)) return sequence; | |
611 if (CONSP (sequence)) return copy_list (sequence); | |
612 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); | |
613 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); | |
614 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); | |
615 | |
616 check_losing_bytecode ("copy-sequence", sequence); | |
617 sequence = wrong_type_argument (Qsequencep, sequence); | |
618 goto again; | |
619 } | |
620 | |
621 struct merge_string_extents_struct | |
622 { | |
623 Lisp_Object string; | |
624 Bytecount entry_offset; | |
625 Bytecount entry_length; | |
626 }; | |
627 | |
628 static Lisp_Object | |
629 concat (int nargs, Lisp_Object *args, | |
630 enum concat_target_type target_type, | |
631 int last_special) | |
632 { | |
633 Lisp_Object val; | |
634 Lisp_Object tail = Qnil; | |
635 int toindex; | |
636 int argnum; | |
637 Lisp_Object last_tail; | |
638 Lisp_Object prev; | |
639 struct merge_string_extents_struct *args_mse = 0; | |
867 | 640 Ibyte *string_result = 0; |
641 Ibyte *string_result_ptr = 0; | |
428 | 642 struct gcpro gcpro1; |
851 | 643 int sdep = specpdl_depth (); |
428 | 644 |
645 /* The modus operandi in Emacs is "caller gc-protects args". | |
646 However, concat is called many times in Emacs on freshly | |
647 created stuff. So we help those callers out by protecting | |
648 the args ourselves to save them a lot of temporary-variable | |
649 grief. */ | |
650 | |
651 GCPRO1 (args[0]); | |
652 gcpro1.nvars = nargs; | |
653 | |
654 #ifdef I18N3 | |
655 /* #### if the result is a string and any of the strings have a string | |
656 for the `string-translatable' property, then concat should also | |
657 concat the args but use the `string-translatable' strings, and store | |
658 the result in the returned string's `string-translatable' property. */ | |
659 #endif | |
660 if (target_type == c_string) | |
661 args_mse = alloca_array (struct merge_string_extents_struct, nargs); | |
662 | |
663 /* In append, the last arg isn't treated like the others */ | |
664 if (last_special && nargs > 0) | |
665 { | |
666 nargs--; | |
667 last_tail = args[nargs]; | |
668 } | |
669 else | |
670 last_tail = Qnil; | |
671 | |
672 /* Check and coerce the arguments. */ | |
673 for (argnum = 0; argnum < nargs; argnum++) | |
674 { | |
675 Lisp_Object seq = args[argnum]; | |
676 if (LISTP (seq)) | |
677 ; | |
678 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq)) | |
679 ; | |
680 #ifdef LOSING_BYTECODE | |
681 else if (COMPILED_FUNCTIONP (seq)) | |
682 /* Urk! We allow this, for "compatibility"... */ | |
683 ; | |
684 #endif | |
685 #if 0 /* removed for XEmacs 21 */ | |
686 else if (INTP (seq)) | |
687 /* This is too revolting to think about but maintains | |
688 compatibility with FSF (and lots and lots of old code). */ | |
689 args[argnum] = Fnumber_to_string (seq); | |
690 #endif | |
691 else | |
692 { | |
693 check_losing_bytecode ("concat", seq); | |
694 args[argnum] = wrong_type_argument (Qsequencep, seq); | |
695 } | |
696 | |
697 if (args_mse) | |
698 { | |
699 if (STRINGP (seq)) | |
700 args_mse[argnum].string = seq; | |
701 else | |
702 args_mse[argnum].string = Qnil; | |
703 } | |
704 } | |
705 | |
706 { | |
707 /* Charcount is a misnomer here as we might be dealing with the | |
708 length of a vector or list, but emphasizes that we're not dealing | |
709 with Bytecounts in strings */ | |
710 Charcount total_length; | |
711 | |
712 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) | |
713 { | |
714 #ifdef LOSING_BYTECODE | |
715 Charcount thislen = length_with_bytecode_hack (args[argnum]); | |
716 #else | |
717 Charcount thislen = XINT (Flength (args[argnum])); | |
718 #endif | |
719 total_length += thislen; | |
720 } | |
721 | |
722 switch (target_type) | |
723 { | |
724 case c_cons: | |
725 if (total_length == 0) | |
851 | 726 { |
727 unbind_to (sdep); | |
728 /* In append, if all but last arg are nil, return last arg */ | |
729 RETURN_UNGCPRO (last_tail); | |
730 } | |
428 | 731 val = Fmake_list (make_int (total_length), Qnil); |
732 break; | |
733 case c_vector: | |
734 val = make_vector (total_length, Qnil); | |
735 break; | |
736 case c_bit_vector: | |
737 val = make_bit_vector (total_length, Qzero); | |
738 break; | |
739 case c_string: | |
740 /* We don't make the string yet because we don't know the | |
741 actual number of bytes. This loop was formerly written | |
742 to call Fmake_string() here and then call set_string_char() | |
743 for each char. This seems logical enough but is waaaaaaaay | |
744 slow -- set_string_char() has to scan the whole string up | |
745 to the place where the substitution is called for in order | |
746 to find the place to change, and may have to do some | |
747 realloc()ing in order to make the char fit properly. | |
748 O(N^2) yuckage. */ | |
749 val = Qnil; | |
851 | 750 string_result = |
867 | 751 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN); |
428 | 752 string_result_ptr = string_result; |
753 break; | |
754 default: | |
442 | 755 val = Qnil; |
2500 | 756 ABORT (); |
428 | 757 } |
758 } | |
759 | |
760 | |
761 if (CONSP (val)) | |
762 tail = val, toindex = -1; /* -1 in toindex is flag we are | |
763 making a list */ | |
764 else | |
765 toindex = 0; | |
766 | |
767 prev = Qnil; | |
768 | |
769 for (argnum = 0; argnum < nargs; argnum++) | |
770 { | |
771 Charcount thisleni = 0; | |
772 Charcount thisindex = 0; | |
773 Lisp_Object seq = args[argnum]; | |
867 | 774 Ibyte *string_source_ptr = 0; |
775 Ibyte *string_prev_result_ptr = string_result_ptr; | |
428 | 776 |
777 if (!CONSP (seq)) | |
778 { | |
779 #ifdef LOSING_BYTECODE | |
780 thisleni = length_with_bytecode_hack (seq); | |
781 #else | |
782 thisleni = XINT (Flength (seq)); | |
783 #endif | |
784 } | |
785 if (STRINGP (seq)) | |
786 string_source_ptr = XSTRING_DATA (seq); | |
787 | |
788 while (1) | |
789 { | |
790 Lisp_Object elt; | |
791 | |
792 /* We've come to the end of this arg, so exit. */ | |
793 if (NILP (seq)) | |
794 break; | |
795 | |
796 /* Fetch next element of `seq' arg into `elt' */ | |
797 if (CONSP (seq)) | |
798 { | |
799 elt = XCAR (seq); | |
800 seq = XCDR (seq); | |
801 } | |
802 else | |
803 { | |
804 if (thisindex >= thisleni) | |
805 break; | |
806 | |
807 if (STRINGP (seq)) | |
808 { | |
867 | 809 elt = make_char (itext_ichar (string_source_ptr)); |
810 INC_IBYTEPTR (string_source_ptr); | |
428 | 811 } |
812 else if (VECTORP (seq)) | |
813 elt = XVECTOR_DATA (seq)[thisindex]; | |
814 else if (BIT_VECTORP (seq)) | |
815 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq), | |
816 thisindex)); | |
817 else | |
818 elt = Felt (seq, make_int (thisindex)); | |
819 thisindex++; | |
820 } | |
821 | |
822 /* Store into result */ | |
823 if (toindex < 0) | |
824 { | |
825 /* toindex negative means we are making a list */ | |
826 XCAR (tail) = elt; | |
827 prev = tail; | |
828 tail = XCDR (tail); | |
829 } | |
830 else if (VECTORP (val)) | |
831 XVECTOR_DATA (val)[toindex++] = elt; | |
832 else if (BIT_VECTORP (val)) | |
833 { | |
834 CHECK_BIT (elt); | |
835 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt)); | |
836 } | |
837 else | |
838 { | |
839 CHECK_CHAR_COERCE_INT (elt); | |
867 | 840 string_result_ptr += set_itext_ichar (string_result_ptr, |
428 | 841 XCHAR (elt)); |
842 } | |
843 } | |
844 if (args_mse) | |
845 { | |
846 args_mse[argnum].entry_offset = | |
847 string_prev_result_ptr - string_result; | |
848 args_mse[argnum].entry_length = | |
849 string_result_ptr - string_prev_result_ptr; | |
850 } | |
851 } | |
852 | |
853 /* Now we finally make the string. */ | |
854 if (target_type == c_string) | |
855 { | |
856 val = make_string (string_result, string_result_ptr - string_result); | |
857 for (argnum = 0; argnum < nargs; argnum++) | |
858 { | |
859 if (STRINGP (args_mse[argnum].string)) | |
860 copy_string_extents (val, args_mse[argnum].string, | |
861 args_mse[argnum].entry_offset, 0, | |
862 args_mse[argnum].entry_length); | |
863 } | |
864 } | |
865 | |
866 if (!NILP (prev)) | |
867 XCDR (prev) = last_tail; | |
868 | |
851 | 869 unbind_to (sdep); |
428 | 870 RETURN_UNGCPRO (val); |
871 } | |
872 | |
873 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /* | |
874 Return a copy of ALIST. | |
875 This is an alist which represents the same mapping from objects to objects, | |
876 but does not share the alist structure with ALIST. | |
877 The objects mapped (cars and cdrs of elements of the alist) | |
878 are shared, however. | |
879 Elements of ALIST that are not conses are also shared. | |
880 */ | |
881 (alist)) | |
882 { | |
883 Lisp_Object tail; | |
884 | |
885 if (NILP (alist)) | |
886 return alist; | |
887 CHECK_CONS (alist); | |
888 | |
889 alist = concat (1, &alist, c_cons, 0); | |
890 for (tail = alist; CONSP (tail); tail = XCDR (tail)) | |
891 { | |
892 Lisp_Object car = XCAR (tail); | |
893 | |
894 if (CONSP (car)) | |
895 XCAR (tail) = Fcons (XCAR (car), XCDR (car)); | |
896 } | |
897 return alist; | |
898 } | |
899 | |
900 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /* | |
901 Return a copy of a list and substructures. | |
902 The argument is copied, and any lists contained within it are copied | |
903 recursively. Circularities and shared substructures are not preserved. | |
904 Second arg VECP causes vectors to be copied, too. Strings and bit vectors | |
905 are not copied. | |
906 */ | |
907 (arg, vecp)) | |
908 { | |
454 | 909 return safe_copy_tree (arg, vecp, 0); |
910 } | |
911 | |
912 Lisp_Object | |
913 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) | |
914 { | |
915 if (depth > 200) | |
563 | 916 stack_overflow ("Stack overflow in copy-tree", arg); |
454 | 917 |
428 | 918 if (CONSP (arg)) |
919 { | |
920 Lisp_Object rest; | |
921 rest = arg = Fcopy_sequence (arg); | |
922 while (CONSP (rest)) | |
923 { | |
924 Lisp_Object elt = XCAR (rest); | |
925 QUIT; | |
926 if (CONSP (elt) || VECTORP (elt)) | |
454 | 927 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1); |
428 | 928 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */ |
454 | 929 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1); |
428 | 930 rest = XCDR (rest); |
931 } | |
932 } | |
933 else if (VECTORP (arg) && ! NILP (vecp)) | |
934 { | |
935 int i = XVECTOR_LENGTH (arg); | |
936 int j; | |
937 arg = Fcopy_sequence (arg); | |
938 for (j = 0; j < i; j++) | |
939 { | |
940 Lisp_Object elt = XVECTOR_DATA (arg) [j]; | |
941 QUIT; | |
942 if (CONSP (elt) || VECTORP (elt)) | |
454 | 943 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1); |
428 | 944 } |
945 } | |
946 return arg; | |
947 } | |
948 | |
949 DEFUN ("subseq", Fsubseq, 2, 3, 0, /* | |
442 | 950 Return the subsequence of SEQUENCE starting at START and ending before END. |
951 END may be omitted; then the subsequence runs to the end of SEQUENCE. | |
952 If START or END is negative, it counts from the end. | |
953 The returned subsequence is always of the same type as SEQUENCE. | |
954 If SEQUENCE is a string, relevant parts of the string-extent-data | |
955 are copied to the new string. | |
428 | 956 */ |
442 | 957 (sequence, start, end)) |
428 | 958 { |
442 | 959 EMACS_INT len, s, e; |
960 | |
5089
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
961 if (STRINGP (sequence)) |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
962 { |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
963 Charcount ccstart, ccend; |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
964 Bytecount bstart, blen; |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
965 Lisp_Object val; |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
966 |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
967 CHECK_INT (start); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
968 get_string_range_char (sequence, start, end, &ccstart, &ccend, |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
969 GB_HISTORICAL_STRING_BEHAVIOR); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
970 bstart = string_index_char_to_byte (sequence, ccstart); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
971 blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
972 val = make_string (XSTRING_DATA (sequence) + bstart, blen); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
973 /* Copy any applicable extent information into the new string. */ |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
974 copy_string_extents (val, sequence, 0, bstart, blen); |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
975 return val; |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
976 } |
99f8ebc082d9
Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5051
diff
changeset
|
977 |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
978 CHECK_SEQUENCE (sequence); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
979 |
442 | 980 len = XINT (Flength (sequence)); |
981 | |
982 CHECK_INT (start); | |
983 s = XINT (start); | |
984 if (s < 0) | |
985 s = len + s; | |
986 | |
987 if (NILP (end)) | |
988 e = len; | |
428 | 989 else |
990 { | |
442 | 991 CHECK_INT (end); |
992 e = XINT (end); | |
993 if (e < 0) | |
994 e = len + e; | |
428 | 995 } |
996 | |
442 | 997 if (!(0 <= s && s <= e && e <= len)) |
998 args_out_of_range_3 (sequence, make_int (s), make_int (e)); | |
999 | |
1000 if (VECTORP (sequence)) | |
428 | 1001 { |
442 | 1002 Lisp_Object result = make_vector (e - s, Qnil); |
428 | 1003 EMACS_INT i; |
442 | 1004 Lisp_Object *in_elts = XVECTOR_DATA (sequence); |
428 | 1005 Lisp_Object *out_elts = XVECTOR_DATA (result); |
1006 | |
442 | 1007 for (i = s; i < e; i++) |
1008 out_elts[i - s] = in_elts[i]; | |
428 | 1009 return result; |
1010 } | |
442 | 1011 else if (LISTP (sequence)) |
428 | 1012 { |
1013 Lisp_Object result = Qnil; | |
1014 EMACS_INT i; | |
1015 | |
442 | 1016 sequence = Fnthcdr (make_int (s), sequence); |
1017 | |
1018 for (i = s; i < e; i++) | |
428 | 1019 { |
442 | 1020 result = Fcons (Fcar (sequence), result); |
1021 sequence = Fcdr (sequence); | |
428 | 1022 } |
1023 | |
1024 return Fnreverse (result); | |
1025 } | |
442 | 1026 else if (BIT_VECTORP (sequence)) |
1027 { | |
1028 Lisp_Object result = make_bit_vector (e - s, Qzero); | |
1029 EMACS_INT i; | |
1030 | |
1031 for (i = s; i < e; i++) | |
1032 set_bit_vector_bit (XBIT_VECTOR (result), i - s, | |
1033 bit_vector_bit (XBIT_VECTOR (sequence), i)); | |
1034 return result; | |
1035 } | |
1036 else | |
1037 { | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
1038 ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
1039 error */ |
442 | 1040 return Qnil; |
1041 } | |
428 | 1042 } |
1043 | |
771 | 1044 /* Split STRING into a list of substrings. The substrings are the |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1045 parts of original STRING separated by SEPCHAR. |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1046 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1047 If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1048 SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1049 necessary for ESCAPECHAR to appear once in a substring. */ |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1050 |
771 | 1051 static Lisp_Object |
867 | 1052 split_string_by_ichar_1 (const Ibyte *string, Bytecount size, |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1053 Ichar sepchar, int unescape, Ichar escapechar) |
771 | 1054 { |
1055 Lisp_Object result = Qnil; | |
867 | 1056 const Ibyte *end = string + size; |
771 | 1057 |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1058 if (unescape) |
771 | 1059 { |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1060 Ibyte unescape_buffer[64], *unescape_buffer_ptr = unescape_buffer, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1061 escaped[MAX_ICHAR_LEN], *unescape_cursor; |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1062 Bytecount unescape_buffer_size = countof (unescape_buffer), |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1063 escaped_len = set_itext_ichar (escaped, escapechar); |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1064 Boolint deleting_escapes, previous_escaped; |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1065 Ichar pchar; |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1066 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1067 while (1) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1068 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1069 const Ibyte *p = string, *cursor; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1070 deleting_escapes = 0; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1071 previous_escaped = 0; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1072 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1073 while (p < end) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1074 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1075 pchar = itext_ichar (p); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1076 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1077 if (pchar == sepchar) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1078 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1079 if (!previous_escaped) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1080 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1081 break; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1082 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1083 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1084 else if (pchar == escapechar |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1085 /* Doubled escapes don't escape: */ |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1086 && !previous_escaped) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1087 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1088 ++deleting_escapes; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1089 previous_escaped = 1; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1090 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1091 else |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1092 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1093 previous_escaped = 0; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1094 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1095 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1096 INC_IBYTEPTR (p); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1097 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1098 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1099 if (deleting_escapes) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1100 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1101 if (((p - string) - (escaped_len * deleting_escapes)) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1102 > unescape_buffer_size) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1103 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1104 unescape_buffer_size = |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1105 ((p - string) - (escaped_len * deleting_escapes)) * 1.5; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1106 unescape_buffer_ptr = alloca_ibytes (unescape_buffer_size); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1107 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1108 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1109 cursor = string; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1110 unescape_cursor = unescape_buffer_ptr; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1111 previous_escaped = 0; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1112 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1113 while (cursor < p) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1114 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1115 pchar = itext_ichar (cursor); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1116 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1117 if (pchar != escapechar || previous_escaped) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1118 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1119 memcpy (unescape_cursor, cursor, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1120 itext_ichar_len (cursor)); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1121 INC_IBYTEPTR (unescape_cursor); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1122 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1123 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1124 previous_escaped = !previous_escaped |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1125 && (pchar == escapechar); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1126 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1127 INC_IBYTEPTR (cursor); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1128 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1129 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1130 result = Fcons (make_string (unescape_buffer_ptr, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1131 unescape_cursor |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1132 - unescape_buffer_ptr), |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1133 result); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1134 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1135 else |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1136 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1137 result = Fcons (make_string (string, p - string), result); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1138 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1139 if (p < end) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1140 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1141 string = p; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1142 INC_IBYTEPTR (string); /* skip sepchar */ |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1143 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1144 else |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1145 break; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1146 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1147 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1148 else |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1149 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1150 while (1) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1151 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1152 const Ibyte *p = string; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1153 while (p < end) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1154 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1155 if (itext_ichar (p) == sepchar) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1156 break; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1157 INC_IBYTEPTR (p); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1158 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1159 result = Fcons (make_string (string, p - string), result); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1160 if (p < end) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1161 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1162 string = p; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1163 INC_IBYTEPTR (string); /* skip sepchar */ |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1164 } |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1165 else |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1166 break; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1167 } |
771 | 1168 } |
1169 return Fnreverse (result); | |
1170 } | |
1171 | |
1172 /* The same as the above, except PATH is an external C string (it is | |
1173 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR | |
1174 (':' or whatever). */ | |
1175 Lisp_Object | |
1176 split_external_path (const Extbyte *path) | |
1177 { | |
1178 Bytecount newlen; | |
867 | 1179 Ibyte *newpath; |
771 | 1180 if (!path) |
1181 return Qnil; | |
1182 | |
1183 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name); | |
1184 | |
1185 /* #### Does this make sense? It certainly does for | |
1186 split_env_path(), but it looks dubious here. Does any code | |
1187 depend on split_external_path("") returning nil instead of an empty | |
1188 string? */ | |
1189 if (!newlen) | |
1190 return Qnil; | |
1191 | |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1192 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR, 0, 0); |
771 | 1193 } |
1194 | |
1195 Lisp_Object | |
867 | 1196 split_env_path (const CIbyte *evarname, const Ibyte *default_) |
771 | 1197 { |
867 | 1198 const Ibyte *path = 0; |
771 | 1199 if (evarname) |
1200 path = egetenv (evarname); | |
1201 if (!path) | |
1202 path = default_; | |
1203 if (!path) | |
1204 return Qnil; | |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1205 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR, 0, 0); |
771 | 1206 } |
1207 | |
1208 /* Ben thinks this function should not exist or be exported to Lisp. | |
1209 We use it to define split-path-string in subr.el (not!). */ | |
1210 | |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1211 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 3, 0, /* |
771 | 1212 Split STRING into a list of substrings originally separated by SEPCHAR. |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1213 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1214 With optional ESCAPE-CHAR, any instances of SEPCHAR preceded by that |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1215 character will not split the string, and a double instance of ESCAPE-CHAR |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1216 will be necessary for a single ESCAPE-CHAR to appear in the output string. |
771 | 1217 */ |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1218 (string, sepchar, escape_char)) |
771 | 1219 { |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1220 Ichar escape_ichar = 0; |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1221 |
771 | 1222 CHECK_STRING (string); |
1223 CHECK_CHAR (sepchar); | |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1224 if (!NILP (escape_char)) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1225 { |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1226 CHECK_CHAR (escape_char); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1227 escape_ichar = XCHAR (escape_char); |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1228 } |
867 | 1229 return split_string_by_ichar_1 (XSTRING_DATA (string), |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1230 XSTRING_LENGTH (string), |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1231 XCHAR (sepchar), |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1232 !NILP (escape_char), escape_ichar); |
771 | 1233 } |
1234 | |
1235 /* #### This was supposed to be in subr.el, but is used VERY early in | |
1236 the bootstrap process, so it goes here. Damn. */ | |
1237 | |
1238 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /* | |
1239 Explode a search path into a list of strings. | |
1240 The path components are separated with the characters specified | |
1241 with `path-separator'. | |
1242 */ | |
1243 (path)) | |
1244 { | |
1245 CHECK_STRING (path); | |
1246 | |
1247 while (!STRINGP (Vpath_separator) | |
826 | 1248 || (string_char_length (Vpath_separator) != 1)) |
771 | 1249 Vpath_separator = signal_continuable_error |
1250 (Qinvalid_state, | |
1251 "`path-separator' should be set to a single-character string", | |
1252 Vpath_separator); | |
1253 | |
867 | 1254 return (split_string_by_ichar_1 |
771 | 1255 (XSTRING_DATA (path), XSTRING_LENGTH (path), |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1256 itext_ichar (XSTRING_DATA (Vpath_separator)), 0, 0)); |
771 | 1257 } |
1258 | |
428 | 1259 |
1260 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* | |
1261 Take cdr N times on LIST, and return the result. | |
1262 */ | |
1263 (n, list)) | |
1264 { | |
1920 | 1265 /* This function can GC */ |
647 | 1266 REGISTER EMACS_INT i; |
428 | 1267 REGISTER Lisp_Object tail = list; |
1268 CHECK_NATNUM (n); | |
1269 for (i = XINT (n); i; i--) | |
1270 { | |
1271 if (CONSP (tail)) | |
1272 tail = XCDR (tail); | |
1273 else if (NILP (tail)) | |
1274 return Qnil; | |
1275 else | |
1276 { | |
1277 tail = wrong_type_argument (Qlistp, tail); | |
1278 i++; | |
1279 } | |
1280 } | |
1281 return tail; | |
1282 } | |
1283 | |
1284 DEFUN ("nth", Fnth, 2, 2, 0, /* | |
1285 Return the Nth element of LIST. | |
1286 N counts from zero. If LIST is not that long, nil is returned. | |
1287 */ | |
1288 (n, list)) | |
1289 { | |
1920 | 1290 /* This function can GC */ |
428 | 1291 return Fcar (Fnthcdr (n, list)); |
1292 } | |
1293 | |
1294 DEFUN ("elt", Felt, 2, 2, 0, /* | |
1295 Return element of SEQUENCE at index N. | |
1296 */ | |
1297 (sequence, n)) | |
1298 { | |
1920 | 1299 /* This function can GC */ |
428 | 1300 retry: |
1301 CHECK_INT_COERCE_CHAR (n); /* yuck! */ | |
1302 if (LISTP (sequence)) | |
1303 { | |
1304 Lisp_Object tem = Fnthcdr (n, sequence); | |
1305 /* #### Utterly, completely, fucking disgusting. | |
1306 * #### The whole point of "elt" is that it operates on | |
1307 * #### sequences, and does error- (bounds-) checking. | |
1308 */ | |
1309 if (CONSP (tem)) | |
1310 return XCAR (tem); | |
1311 else | |
1312 #if 1 | |
1313 /* This is The Way It Has Always Been. */ | |
1314 return Qnil; | |
1315 #else | |
1316 /* This is The Way Mly and Cltl2 say It Should Be. */ | |
1317 args_out_of_range (sequence, n); | |
1318 #endif | |
1319 } | |
1320 else if (STRINGP (sequence) || | |
1321 VECTORP (sequence) || | |
1322 BIT_VECTORP (sequence)) | |
1323 return Faref (sequence, n); | |
1324 #ifdef LOSING_BYTECODE | |
1325 else if (COMPILED_FUNCTIONP (sequence)) | |
1326 { | |
1327 EMACS_INT idx = XINT (n); | |
1328 if (idx < 0) | |
1329 { | |
1330 lose: | |
1331 args_out_of_range (sequence, n); | |
1332 } | |
1333 /* Utter perversity */ | |
1334 { | |
1335 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); | |
1336 switch (idx) | |
1337 { | |
1338 case COMPILED_ARGLIST: | |
1339 return compiled_function_arglist (f); | |
1340 case COMPILED_INSTRUCTIONS: | |
1341 return compiled_function_instructions (f); | |
1342 case COMPILED_CONSTANTS: | |
1343 return compiled_function_constants (f); | |
1344 case COMPILED_STACK_DEPTH: | |
1345 return compiled_function_stack_depth (f); | |
1346 case COMPILED_DOC_STRING: | |
1347 return compiled_function_documentation (f); | |
1348 case COMPILED_DOMAIN: | |
1349 return compiled_function_domain (f); | |
1350 case COMPILED_INTERACTIVE: | |
1351 if (f->flags.interactivep) | |
1352 return compiled_function_interactive (f); | |
1353 /* if we return nil, can't tell interactive with no args | |
1354 from noninteractive. */ | |
1355 goto lose; | |
1356 default: | |
1357 goto lose; | |
1358 } | |
1359 } | |
1360 } | |
1361 #endif /* LOSING_BYTECODE */ | |
1362 else | |
1363 { | |
1364 check_losing_bytecode ("elt", sequence); | |
1365 sequence = wrong_type_argument (Qsequencep, sequence); | |
1366 goto retry; | |
1367 } | |
1368 } | |
1369 | |
1370 DEFUN ("last", Flast, 1, 2, 0, /* | |
1371 Return the tail of list LIST, of length N (default 1). | |
1372 LIST may be a dotted list, but not a circular list. | |
1373 Optional argument N must be a non-negative integer. | |
1374 If N is zero, then the atom that terminates the list is returned. | |
1375 If N is greater than the length of LIST, then LIST itself is returned. | |
1376 */ | |
1377 (list, n)) | |
1378 { | |
1379 EMACS_INT int_n, count; | |
1380 Lisp_Object retval, tortoise, hare; | |
1381 | |
1382 CHECK_LIST (list); | |
1383 | |
1384 if (NILP (n)) | |
1385 int_n = 1; | |
1386 else | |
1387 { | |
1388 CHECK_NATNUM (n); | |
1389 int_n = XINT (n); | |
1390 } | |
1391 | |
1392 for (retval = tortoise = hare = list, count = 0; | |
1393 CONSP (hare); | |
1394 hare = XCDR (hare), | |
1395 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), | |
1396 count++) | |
1397 { | |
1398 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
1399 | |
1400 if (count & 1) | |
1401 tortoise = XCDR (tortoise); | |
1402 if (EQ (hare, tortoise)) | |
1403 signal_circular_list_error (list); | |
1404 } | |
1405 | |
1406 return retval; | |
1407 } | |
1408 | |
1409 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* | |
1410 Modify LIST to remove the last N (default 1) elements. | |
1411 If LIST has N or fewer elements, nil is returned and LIST is unmodified. | |
1412 */ | |
1413 (list, n)) | |
1414 { | |
1415 EMACS_INT int_n; | |
1416 | |
1417 CHECK_LIST (list); | |
1418 | |
1419 if (NILP (n)) | |
1420 int_n = 1; | |
1421 else | |
1422 { | |
1423 CHECK_NATNUM (n); | |
1424 int_n = XINT (n); | |
1425 } | |
1426 | |
1427 { | |
1428 Lisp_Object last_cons = list; | |
1429 | |
1430 EXTERNAL_LIST_LOOP_1 (list) | |
1431 { | |
1432 if (int_n-- < 0) | |
1433 last_cons = XCDR (last_cons); | |
1434 } | |
1435 | |
1436 if (int_n >= 0) | |
1437 return Qnil; | |
1438 | |
1439 XCDR (last_cons) = Qnil; | |
1440 return list; | |
1441 } | |
1442 } | |
1443 | |
1444 DEFUN ("butlast", Fbutlast, 1, 2, 0, /* | |
1445 Return a copy of LIST with the last N (default 1) elements removed. | |
1446 If LIST has N or fewer elements, nil is returned. | |
1447 */ | |
1448 (list, n)) | |
1449 { | |
444 | 1450 EMACS_INT int_n; |
428 | 1451 |
1452 CHECK_LIST (list); | |
1453 | |
1454 if (NILP (n)) | |
1455 int_n = 1; | |
1456 else | |
1457 { | |
1458 CHECK_NATNUM (n); | |
1459 int_n = XINT (n); | |
1460 } | |
1461 | |
1462 { | |
1463 Lisp_Object retval = Qnil; | |
1464 Lisp_Object tail = list; | |
1465 | |
1466 EXTERNAL_LIST_LOOP_1 (list) | |
1467 { | |
1468 if (--int_n < 0) | |
1469 { | |
1470 retval = Fcons (XCAR (tail), retval); | |
1471 tail = XCDR (tail); | |
1472 } | |
1473 } | |
1474 | |
1475 return Fnreverse (retval); | |
1476 } | |
1477 } | |
1478 | |
1479 DEFUN ("member", Fmember, 2, 2, 0, /* | |
1480 Return non-nil if ELT is an element of LIST. Comparison done with `equal'. | |
1481 The value is actually the tail of LIST whose car is ELT. | |
1482 */ | |
1483 (elt, list)) | |
1484 { | |
1485 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
1486 { | |
1487 if (internal_equal (elt, list_elt, 0)) | |
1488 return tail; | |
1489 } | |
1490 return Qnil; | |
1491 } | |
1492 | |
1493 DEFUN ("old-member", Fold_member, 2, 2, 0, /* | |
1494 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'. | |
1495 The value is actually the tail of LIST whose car is ELT. | |
1496 This function is provided only for byte-code compatibility with v19. | |
1497 Do not use it. | |
1498 */ | |
1499 (elt, list)) | |
1500 { | |
1501 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
1502 { | |
1503 if (internal_old_equal (elt, list_elt, 0)) | |
1504 return tail; | |
1505 } | |
1506 return Qnil; | |
1507 } | |
1508 | |
1509 DEFUN ("memq", Fmemq, 2, 2, 0, /* | |
1510 Return non-nil if ELT is an element of LIST. Comparison done with `eq'. | |
1511 The value is actually the tail of LIST whose car is ELT. | |
1512 */ | |
1513 (elt, list)) | |
1514 { | |
1515 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
1516 { | |
1517 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
1518 return tail; | |
1519 } | |
1520 return Qnil; | |
1521 } | |
1522 | |
1523 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /* | |
1524 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'. | |
1525 The value is actually the tail of LIST whose car is ELT. | |
1526 This function is provided only for byte-code compatibility with v19. | |
1527 Do not use it. | |
1528 */ | |
1529 (elt, list)) | |
1530 { | |
1531 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
1532 { | |
1533 if (HACKEQ_UNSAFE (elt, list_elt)) | |
1534 return tail; | |
1535 } | |
1536 return Qnil; | |
1537 } | |
1538 | |
1539 Lisp_Object | |
1540 memq_no_quit (Lisp_Object elt, Lisp_Object list) | |
1541 { | |
1542 LIST_LOOP_3 (list_elt, list, tail) | |
1543 { | |
1544 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
1545 return tail; | |
1546 } | |
1547 return Qnil; | |
1548 } | |
1549 | |
1550 DEFUN ("assoc", Fassoc, 2, 2, 0, /* | |
444 | 1551 Return non-nil if KEY is `equal' to the car of an element of ALIST. |
1552 The value is actually the element of ALIST whose car equals KEY. | |
428 | 1553 */ |
444 | 1554 (key, alist)) |
428 | 1555 { |
1556 /* This function can GC. */ | |
444 | 1557 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1558 { |
1559 if (internal_equal (key, elt_car, 0)) | |
1560 return elt; | |
1561 } | |
1562 return Qnil; | |
1563 } | |
1564 | |
1565 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* | |
444 | 1566 Return non-nil if KEY is `old-equal' to the car of an element of ALIST. |
1567 The value is actually the element of ALIST whose car equals KEY. | |
428 | 1568 */ |
444 | 1569 (key, alist)) |
428 | 1570 { |
1571 /* This function can GC. */ | |
444 | 1572 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1573 { |
1574 if (internal_old_equal (key, elt_car, 0)) | |
1575 return elt; | |
1576 } | |
1577 return Qnil; | |
1578 } | |
1579 | |
1580 Lisp_Object | |
444 | 1581 assoc_no_quit (Lisp_Object key, Lisp_Object alist) |
428 | 1582 { |
1583 int speccount = specpdl_depth (); | |
1584 specbind (Qinhibit_quit, Qt); | |
771 | 1585 return unbind_to_1 (speccount, Fassoc (key, alist)); |
428 | 1586 } |
1587 | |
1588 DEFUN ("assq", Fassq, 2, 2, 0, /* | |
444 | 1589 Return non-nil if KEY is `eq' to the car of an element of ALIST. |
1590 The value is actually the element of ALIST whose car is KEY. | |
1591 Elements of ALIST that are not conses are ignored. | |
428 | 1592 */ |
444 | 1593 (key, alist)) |
428 | 1594 { |
444 | 1595 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1596 { |
1597 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
1598 return elt; | |
1599 } | |
1600 return Qnil; | |
1601 } | |
1602 | |
1603 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* | |
444 | 1604 Return non-nil if KEY is `old-eq' to the car of an element of ALIST. |
1605 The value is actually the element of ALIST whose car is KEY. | |
1606 Elements of ALIST that are not conses are ignored. | |
428 | 1607 This function is provided only for byte-code compatibility with v19. |
1608 Do not use it. | |
1609 */ | |
444 | 1610 (key, alist)) |
428 | 1611 { |
444 | 1612 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1613 { |
1614 if (HACKEQ_UNSAFE (key, elt_car)) | |
1615 return elt; | |
1616 } | |
1617 return Qnil; | |
1618 } | |
1619 | |
1620 /* Like Fassq but never report an error and do not allow quits. | |
1621 Use only on lists known never to be circular. */ | |
1622 | |
1623 Lisp_Object | |
444 | 1624 assq_no_quit (Lisp_Object key, Lisp_Object alist) |
428 | 1625 { |
1626 /* This cannot GC. */ | |
444 | 1627 LIST_LOOP_2 (elt, alist) |
428 | 1628 { |
1629 Lisp_Object elt_car = XCAR (elt); | |
1630 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
1631 return elt; | |
1632 } | |
1633 return Qnil; | |
1634 } | |
1635 | |
1636 DEFUN ("rassoc", Frassoc, 2, 2, 0, /* | |
444 | 1637 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. |
1638 The value is actually the element of ALIST whose cdr equals VALUE. | |
428 | 1639 */ |
444 | 1640 (value, alist)) |
428 | 1641 { |
444 | 1642 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1643 { |
444 | 1644 if (internal_equal (value, elt_cdr, 0)) |
428 | 1645 return elt; |
1646 } | |
1647 return Qnil; | |
1648 } | |
1649 | |
1650 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* | |
444 | 1651 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. |
1652 The value is actually the element of ALIST whose cdr equals VALUE. | |
428 | 1653 */ |
444 | 1654 (value, alist)) |
428 | 1655 { |
444 | 1656 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1657 { |
444 | 1658 if (internal_old_equal (value, elt_cdr, 0)) |
428 | 1659 return elt; |
1660 } | |
1661 return Qnil; | |
1662 } | |
1663 | |
1664 DEFUN ("rassq", Frassq, 2, 2, 0, /* | |
444 | 1665 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. |
1666 The value is actually the element of ALIST whose cdr is VALUE. | |
428 | 1667 */ |
444 | 1668 (value, alist)) |
428 | 1669 { |
444 | 1670 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1671 { |
444 | 1672 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
428 | 1673 return elt; |
1674 } | |
1675 return Qnil; | |
1676 } | |
1677 | |
1678 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* | |
444 | 1679 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. |
1680 The value is actually the element of ALIST whose cdr is VALUE. | |
428 | 1681 */ |
444 | 1682 (value, alist)) |
428 | 1683 { |
444 | 1684 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
428 | 1685 { |
444 | 1686 if (HACKEQ_UNSAFE (value, elt_cdr)) |
428 | 1687 return elt; |
1688 } | |
1689 return Qnil; | |
1690 } | |
1691 | |
444 | 1692 /* Like Frassq, but caller must ensure that ALIST is properly |
428 | 1693 nil-terminated and ebola-free. */ |
1694 Lisp_Object | |
444 | 1695 rassq_no_quit (Lisp_Object value, Lisp_Object alist) |
428 | 1696 { |
444 | 1697 LIST_LOOP_2 (elt, alist) |
428 | 1698 { |
1699 Lisp_Object elt_cdr = XCDR (elt); | |
444 | 1700 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
428 | 1701 return elt; |
1702 } | |
1703 return Qnil; | |
1704 } | |
1705 | |
1706 | |
1707 DEFUN ("delete", Fdelete, 2, 2, 0, /* | |
1708 Delete by side effect any occurrences of ELT as a member of LIST. | |
1709 The modified LIST is returned. Comparison is done with `equal'. | |
1710 If the first member of LIST is ELT, there is no way to remove it by side | |
1711 effect; therefore, write `(setq foo (delete element foo))' to be sure | |
1712 of changing the value of `foo'. | |
1713 Also see: `remove'. | |
1714 */ | |
1715 (elt, list)) | |
1716 { | |
1717 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
1718 (internal_equal (elt, list_elt, 0))); | |
1719 return list; | |
1720 } | |
1721 | |
1722 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* | |
1723 Delete by side effect any occurrences of ELT as a member of LIST. | |
1724 The modified LIST is returned. Comparison is done with `old-equal'. | |
1725 If the first member of LIST is ELT, there is no way to remove it by side | |
1726 effect; therefore, write `(setq foo (old-delete element foo))' to be sure | |
1727 of changing the value of `foo'. | |
1728 */ | |
1729 (elt, list)) | |
1730 { | |
1731 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
1732 (internal_old_equal (elt, list_elt, 0))); | |
1733 return list; | |
1734 } | |
1735 | |
1736 DEFUN ("delq", Fdelq, 2, 2, 0, /* | |
1737 Delete by side effect any occurrences of ELT as a member of LIST. | |
1738 The modified LIST is returned. Comparison is done with `eq'. | |
1739 If the first member of LIST is ELT, there is no way to remove it by side | |
1740 effect; therefore, write `(setq foo (delq element foo))' to be sure of | |
1741 changing the value of `foo'. | |
1742 */ | |
1743 (elt, list)) | |
1744 { | |
1745 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
1746 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
1747 return list; | |
1748 } | |
1749 | |
1750 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* | |
1751 Delete by side effect any occurrences of ELT as a member of LIST. | |
1752 The modified LIST is returned. Comparison is done with `old-eq'. | |
1753 If the first member of LIST is ELT, there is no way to remove it by side | |
1754 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of | |
1755 changing the value of `foo'. | |
1756 */ | |
1757 (elt, list)) | |
1758 { | |
1759 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
1760 (HACKEQ_UNSAFE (elt, list_elt))); | |
1761 return list; | |
1762 } | |
1763 | |
1764 /* Like Fdelq, but caller must ensure that LIST is properly | |
1765 nil-terminated and ebola-free. */ | |
1766 | |
1767 Lisp_Object | |
1768 delq_no_quit (Lisp_Object elt, Lisp_Object list) | |
1769 { | |
1770 LIST_LOOP_DELETE_IF (list_elt, list, | |
1771 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
1772 return list; | |
1773 } | |
1774 | |
1775 /* Be VERY careful with this. This is like delq_no_quit() but | |
1776 also calls free_cons() on the removed conses. You must be SURE | |
1777 that no pointers to the freed conses remain around (e.g. | |
1778 someone else is pointing to part of the list). This function | |
1779 is useful on internal lists that are used frequently and where | |
1780 the actual list doesn't escape beyond known code bounds. */ | |
1781 | |
1782 Lisp_Object | |
1783 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) | |
1784 { | |
1785 REGISTER Lisp_Object tail = list; | |
1786 REGISTER Lisp_Object prev = Qnil; | |
1787 | |
1788 while (!NILP (tail)) | |
1789 { | |
1790 REGISTER Lisp_Object tem = XCAR (tail); | |
1791 if (EQ (elt, tem)) | |
1792 { | |
1793 Lisp_Object cons_to_free = tail; | |
1794 if (NILP (prev)) | |
1795 list = XCDR (tail); | |
1796 else | |
1797 XCDR (prev) = XCDR (tail); | |
1798 tail = XCDR (tail); | |
853 | 1799 free_cons (cons_to_free); |
428 | 1800 } |
1801 else | |
1802 { | |
1803 prev = tail; | |
1804 tail = XCDR (tail); | |
1805 } | |
1806 } | |
1807 return list; | |
1808 } | |
1809 | |
1810 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* | |
444 | 1811 Delete by side effect any elements of ALIST whose car is `equal' to KEY. |
1812 The modified ALIST is returned. If the first member of ALIST has a car | |
428 | 1813 that is `equal' to KEY, there is no way to remove it by side effect; |
1814 therefore, write `(setq foo (remassoc key foo))' to be sure of changing | |
1815 the value of `foo'. | |
1816 */ | |
444 | 1817 (key, alist)) |
428 | 1818 { |
444 | 1819 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1820 (CONSP (elt) && |
1821 internal_equal (key, XCAR (elt), 0))); | |
444 | 1822 return alist; |
428 | 1823 } |
1824 | |
1825 Lisp_Object | |
444 | 1826 remassoc_no_quit (Lisp_Object key, Lisp_Object alist) |
428 | 1827 { |
1828 int speccount = specpdl_depth (); | |
1829 specbind (Qinhibit_quit, Qt); | |
771 | 1830 return unbind_to_1 (speccount, Fremassoc (key, alist)); |
428 | 1831 } |
1832 | |
1833 DEFUN ("remassq", Fremassq, 2, 2, 0, /* | |
444 | 1834 Delete by side effect any elements of ALIST whose car is `eq' to KEY. |
1835 The modified ALIST is returned. If the first member of ALIST has a car | |
428 | 1836 that is `eq' to KEY, there is no way to remove it by side effect; |
1837 therefore, write `(setq foo (remassq key foo))' to be sure of changing | |
1838 the value of `foo'. | |
1839 */ | |
444 | 1840 (key, alist)) |
428 | 1841 { |
444 | 1842 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1843 (CONSP (elt) && |
1844 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
444 | 1845 return alist; |
428 | 1846 } |
1847 | |
1848 /* no quit, no errors; be careful */ | |
1849 | |
1850 Lisp_Object | |
444 | 1851 remassq_no_quit (Lisp_Object key, Lisp_Object alist) |
428 | 1852 { |
444 | 1853 LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1854 (CONSP (elt) && |
1855 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
444 | 1856 return alist; |
428 | 1857 } |
1858 | |
1859 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* | |
444 | 1860 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. |
1861 The modified ALIST is returned. If the first member of ALIST has a car | |
428 | 1862 that is `equal' to VALUE, there is no way to remove it by side effect; |
1863 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing | |
1864 the value of `foo'. | |
1865 */ | |
444 | 1866 (value, alist)) |
428 | 1867 { |
444 | 1868 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1869 (CONSP (elt) && |
1870 internal_equal (value, XCDR (elt), 0))); | |
444 | 1871 return alist; |
428 | 1872 } |
1873 | |
1874 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* | |
444 | 1875 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. |
1876 The modified ALIST is returned. If the first member of ALIST has a car | |
428 | 1877 that is `eq' to VALUE, there is no way to remove it by side effect; |
1878 therefore, write `(setq foo (remrassq value foo))' to be sure of changing | |
1879 the value of `foo'. | |
1880 */ | |
444 | 1881 (value, alist)) |
428 | 1882 { |
444 | 1883 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1884 (CONSP (elt) && |
1885 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
444 | 1886 return alist; |
428 | 1887 } |
1888 | |
1889 /* Like Fremrassq, fast and unsafe; be careful */ | |
1890 Lisp_Object | |
444 | 1891 remrassq_no_quit (Lisp_Object value, Lisp_Object alist) |
428 | 1892 { |
444 | 1893 LIST_LOOP_DELETE_IF (elt, alist, |
428 | 1894 (CONSP (elt) && |
1895 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
444 | 1896 return alist; |
428 | 1897 } |
1898 | |
1899 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* | |
1900 Reverse LIST by destructively modifying cdr pointers. | |
1901 Return the beginning of the reversed list. | |
1902 Also see: `reverse'. | |
1903 */ | |
1904 (list)) | |
1905 { | |
1906 struct gcpro gcpro1, gcpro2; | |
1849 | 1907 Lisp_Object prev = Qnil; |
1908 Lisp_Object tail = list; | |
428 | 1909 |
1910 /* We gcpro our args; see `nconc' */ | |
1911 GCPRO2 (prev, tail); | |
1912 while (!NILP (tail)) | |
1913 { | |
1914 REGISTER Lisp_Object next; | |
1915 CONCHECK_CONS (tail); | |
1916 next = XCDR (tail); | |
1917 XCDR (tail) = prev; | |
1918 prev = tail; | |
1919 tail = next; | |
1920 } | |
1921 UNGCPRO; | |
1922 return prev; | |
1923 } | |
1924 | |
1925 DEFUN ("reverse", Freverse, 1, 1, 0, /* | |
1926 Reverse LIST, copying. Return the beginning of the reversed list. | |
1927 See also the function `nreverse', which is used more often. | |
1928 */ | |
1929 (list)) | |
1930 { | |
1931 Lisp_Object reversed_list = Qnil; | |
1932 EXTERNAL_LIST_LOOP_2 (elt, list) | |
1933 { | |
1934 reversed_list = Fcons (elt, reversed_list); | |
1935 } | |
1936 return reversed_list; | |
1937 } | |
1938 | |
1939 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
1940 Lisp_Object lisp_arg, | |
1941 int (*pred_fn) (Lisp_Object, Lisp_Object, | |
1942 Lisp_Object lisp_arg)); | |
1943 | |
872 | 1944 /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. |
1945 NOTE: This is backwards from the way qsort() works. */ | |
1946 | |
428 | 1947 Lisp_Object |
1948 list_sort (Lisp_Object list, | |
1949 Lisp_Object lisp_arg, | |
872 | 1950 int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2, |
428 | 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); | |
444 | 1957 |
1958 if (XINT (len) < 2) | |
428 | 1959 return list; |
1960 | |
444 | 1961 len = make_int (XINT (len) / 2 - 1); |
428 | 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 */ | |
853 | 1981 /* Emacs' GC doesn't actually relocate pointers, so this probably |
1982 isn't strictly necessary */ | |
771 | 1983 int speccount = begin_gc_forbidden (); |
428 | 1984 tmp = call2 (pred, obj1, obj2); |
771 | 1985 unbind_to (speccount); |
428 | 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 */ | |
444 | 1999 (list, predicate)) |
428 | 2000 { |
444 | 2001 return list_sort (list, predicate, merge_pred_function); |
428 | 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, | |
2014 Lisp_Object lisp_arg, | |
2015 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg)) | |
2016 { | |
2017 Lisp_Object value; | |
2018 Lisp_Object tail; | |
2019 Lisp_Object tem; | |
2020 Lisp_Object l1, l2; | |
2021 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
2022 | |
2023 l1 = org_l1; | |
2024 l2 = org_l2; | |
2025 tail = Qnil; | |
2026 value = Qnil; | |
2027 | |
2028 /* It is sufficient to protect org_l1 and org_l2. | |
2029 When l1 and l2 are updated, we copy the new values | |
2030 back into the org_ vars. */ | |
2031 | |
2032 GCPRO4 (org_l1, org_l2, lisp_arg, value); | |
2033 | |
2034 while (1) | |
2035 { | |
2036 if (NILP (l1)) | |
2037 { | |
2038 UNGCPRO; | |
2039 if (NILP (tail)) | |
2040 return l2; | |
2041 Fsetcdr (tail, l2); | |
2042 return value; | |
2043 } | |
2044 if (NILP (l2)) | |
2045 { | |
2046 UNGCPRO; | |
2047 if (NILP (tail)) | |
2048 return l1; | |
2049 Fsetcdr (tail, l1); | |
2050 return value; | |
2051 } | |
2052 | |
2053 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0) | |
2054 { | |
2055 tem = l1; | |
2056 l1 = Fcdr (l1); | |
2057 org_l1 = l1; | |
2058 } | |
2059 else | |
2060 { | |
2061 tem = l2; | |
2062 l2 = Fcdr (l2); | |
2063 org_l2 = l2; | |
2064 } | |
2065 if (NILP (tail)) | |
2066 value = tem; | |
2067 else | |
2068 Fsetcdr (tail, tem); | |
2069 tail = tem; | |
2070 } | |
2071 } | |
2072 | |
2073 | |
2074 /************************************************************************/ | |
2075 /* property-list functions */ | |
2076 /************************************************************************/ | |
2077 | |
2078 /* For properties of text, we need to do order-insensitive comparison of | |
2079 plists. That is, we need to compare two plists such that they are the | |
2080 same if they have the same set of keys, and equivalent values. | |
2081 So (a 1 b 2) would be equal to (b 2 a 1). | |
2082 | |
2083 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. | |
2084 LAXP means use `equal' for comparisons. | |
2085 */ | |
2086 int | |
2087 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2088 int laxp, int depth, int foldcase) |
428 | 2089 { |
438 | 2090 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ |
428 | 2091 int la, lb, m, i, fill; |
2092 Lisp_Object *keys, *vals; | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2093 Boolbyte *flags; |
428 | 2094 Lisp_Object rest; |
2095 | |
2096 if (NILP (a) && NILP (b)) | |
2097 return 0; | |
2098 | |
2099 Fcheck_valid_plist (a); | |
2100 Fcheck_valid_plist (b); | |
2101 | |
2102 la = XINT (Flength (a)); | |
2103 lb = XINT (Flength (b)); | |
2104 m = (la > lb ? la : lb); | |
2105 fill = 0; | |
2106 keys = alloca_array (Lisp_Object, m); | |
2107 vals = alloca_array (Lisp_Object, m); | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2108 flags = alloca_array (Boolbyte, m); |
428 | 2109 |
2110 /* First extract the pairs from A. */ | |
2111 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest))) | |
2112 { | |
2113 Lisp_Object k = XCAR (rest); | |
2114 Lisp_Object v = XCAR (XCDR (rest)); | |
2115 /* Maybe be Ebolified. */ | |
2116 if (nil_means_not_present && NILP (v)) continue; | |
2117 keys [fill] = k; | |
2118 vals [fill] = v; | |
2119 flags[fill] = 0; | |
2120 fill++; | |
2121 } | |
2122 /* Now iterate over B, and stop if we find something that's not in A, | |
2123 or that doesn't match. As we match, mark them. */ | |
2124 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest))) | |
2125 { | |
2126 Lisp_Object k = XCAR (rest); | |
2127 Lisp_Object v = XCAR (XCDR (rest)); | |
2128 /* Maybe be Ebolified. */ | |
2129 if (nil_means_not_present && NILP (v)) continue; | |
2130 for (i = 0; i < fill; i++) | |
2131 { | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2132 if (!laxp ? EQ (k, keys [i]) : |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2133 internal_equal_0 (k, keys [i], depth, foldcase)) |
428 | 2134 { |
434 | 2135 if (eqp |
2136 /* We narrowly escaped being Ebolified here. */ | |
2137 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2138 : !internal_equal_0 (v, vals [i], depth, foldcase)) |
428 | 2139 /* a property in B has a different value than in A */ |
2140 goto MISMATCH; | |
2141 flags [i] = 1; | |
2142 break; | |
2143 } | |
2144 } | |
2145 if (i == fill) | |
2146 /* there are some properties in B that are not in A */ | |
2147 goto MISMATCH; | |
2148 } | |
2149 /* Now check to see that all the properties in A were also in B */ | |
2150 for (i = 0; i < fill; i++) | |
2151 if (flags [i] == 0) | |
2152 goto MISMATCH; | |
2153 | |
2154 /* Ok. */ | |
2155 return 0; | |
2156 | |
2157 MISMATCH: | |
2158 return 1; | |
2159 } | |
2160 | |
2161 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /* | |
2162 Return non-nil if property lists A and B are `eq'. | |
2163 A property list is an alternating list of keywords and values. | |
2164 This function does order-insensitive comparisons of the property lists: | |
2165 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
2166 Comparison between values is done using `eq'. See also `plists-equal'. | |
2167 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2168 a nil value is ignored. This feature is a virus that has infected | |
2169 old Lisp implementations, but should not be used except for backward | |
2170 compatibility. | |
2171 */ | |
2172 (a, b, nil_means_not_present)) | |
2173 { | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2174 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0) |
428 | 2175 ? Qnil : Qt); |
2176 } | |
2177 | |
2178 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* | |
2179 Return non-nil if property lists A and B are `equal'. | |
2180 A property list is an alternating list of keywords and values. This | |
2181 function does order-insensitive comparisons of the property lists: For | |
2182 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
2183 Comparison between values is done using `equal'. See also `plists-eq'. | |
2184 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2185 a nil value is ignored. This feature is a virus that has infected | |
2186 old Lisp implementations, but should not be used except for backward | |
2187 compatibility. | |
2188 */ | |
2189 (a, b, nil_means_not_present)) | |
2190 { | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2191 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0) |
428 | 2192 ? Qnil : Qt); |
2193 } | |
2194 | |
2195 | |
2196 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* | |
2197 Return non-nil if lax property lists A and B are `eq'. | |
2198 A property list is an alternating list of keywords and values. | |
2199 This function does order-insensitive comparisons of the property lists: | |
2200 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
2201 Comparison between values is done using `eq'. See also `plists-equal'. | |
2202 A lax property list is like a regular one except that comparisons between | |
2203 keywords is done using `equal' instead of `eq'. | |
2204 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2205 a nil value is ignored. This feature is a virus that has infected | |
2206 old Lisp implementations, but should not be used except for backward | |
2207 compatibility. | |
2208 */ | |
2209 (a, b, nil_means_not_present)) | |
2210 { | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2211 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0) |
428 | 2212 ? Qnil : Qt); |
2213 } | |
2214 | |
2215 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* | |
2216 Return non-nil if lax property lists A and B are `equal'. | |
2217 A property list is an alternating list of keywords and values. This | |
2218 function does order-insensitive comparisons of the property lists: For | |
2219 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
2220 Comparison between values is done using `equal'. See also `plists-eq'. | |
2221 A lax property list is like a regular one except that comparisons between | |
2222 keywords is done using `equal' instead of `eq'. | |
2223 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2224 a nil value is ignored. This feature is a virus that has infected | |
2225 old Lisp implementations, but should not be used except for backward | |
2226 compatibility. | |
2227 */ | |
2228 (a, b, nil_means_not_present)) | |
2229 { | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2230 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0) |
428 | 2231 ? Qnil : Qt); |
2232 } | |
2233 | |
2234 /* Return the value associated with key PROPERTY in property list PLIST. | |
2235 Return nil if key not found. This function is used for internal | |
2236 property lists that cannot be directly manipulated by the user. | |
2237 */ | |
2238 | |
2239 Lisp_Object | |
2240 internal_plist_get (Lisp_Object plist, Lisp_Object property) | |
2241 { | |
2242 Lisp_Object tail; | |
2243 | |
2244 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
2245 { | |
2246 if (EQ (XCAR (tail), property)) | |
2247 return XCAR (XCDR (tail)); | |
2248 } | |
2249 | |
2250 return Qunbound; | |
2251 } | |
2252 | |
2253 /* Set PLIST's value for PROPERTY to VALUE. Analogous to | |
2254 internal_plist_get(). */ | |
2255 | |
2256 void | |
2257 internal_plist_put (Lisp_Object *plist, Lisp_Object property, | |
2258 Lisp_Object value) | |
2259 { | |
2260 Lisp_Object tail; | |
2261 | |
2262 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
2263 { | |
2264 if (EQ (XCAR (tail), property)) | |
2265 { | |
2266 XCAR (XCDR (tail)) = value; | |
2267 return; | |
2268 } | |
2269 } | |
2270 | |
2271 *plist = Fcons (property, Fcons (value, *plist)); | |
2272 } | |
2273 | |
2274 int | |
2275 internal_remprop (Lisp_Object *plist, Lisp_Object property) | |
2276 { | |
2277 Lisp_Object tail, prev; | |
2278 | |
2279 for (tail = *plist, prev = Qnil; | |
2280 !NILP (tail); | |
2281 tail = XCDR (XCDR (tail))) | |
2282 { | |
2283 if (EQ (XCAR (tail), property)) | |
2284 { | |
2285 if (NILP (prev)) | |
2286 *plist = XCDR (XCDR (tail)); | |
2287 else | |
2288 XCDR (XCDR (prev)) = XCDR (XCDR (tail)); | |
2289 return 1; | |
2290 } | |
2291 else | |
2292 prev = tail; | |
2293 } | |
2294 | |
2295 return 0; | |
2296 } | |
2297 | |
2298 /* Called on a malformed property list. BADPLACE should be some | |
2299 place where truncating will form a good list -- i.e. we shouldn't | |
2300 result in a list with an odd length. */ | |
2301 | |
2302 static Lisp_Object | |
578 | 2303 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
428 | 2304 { |
2305 if (ERRB_EQ (errb, ERROR_ME)) | |
2306 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace)); | |
2307 else | |
2308 { | |
2309 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
2310 { | |
2311 warn_when_safe_lispobj | |
2312 (Qlist, Qwarning, | |
771 | 2313 list2 (build_msg_string |
428 | 2314 ("Malformed property list -- list has been truncated"), |
2315 *plist)); | |
793 | 2316 /* #### WARNING: This is more dangerous than it seems; perhaps |
2317 not a good idea. It also violates the principle of least | |
2318 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
2319 ERROR_ME and ERROR_ME_NOT don't. */ | |
428 | 2320 *badplace = Qnil; |
2321 } | |
2322 return Qunbound; | |
2323 } | |
2324 } | |
2325 | |
2326 /* Called on a circular property list. BADPLACE should be some place | |
2327 where truncating will result in an even-length list, as above. | |
2328 If doesn't particularly matter where we truncate -- anywhere we | |
2329 truncate along the entire list will break the circularity, because | |
2330 it will create a terminus and the list currently doesn't have one. | |
2331 */ | |
2332 | |
2333 static Lisp_Object | |
578 | 2334 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
428 | 2335 { |
2336 if (ERRB_EQ (errb, ERROR_ME)) | |
2337 return Fsignal (Qcircular_property_list, list1 (*plist)); | |
2338 else | |
2339 { | |
2340 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
2341 { | |
2342 warn_when_safe_lispobj | |
2343 (Qlist, Qwarning, | |
771 | 2344 list2 (build_msg_string |
428 | 2345 ("Circular property list -- list has been truncated"), |
2346 *plist)); | |
793 | 2347 /* #### WARNING: This is more dangerous than it seems; perhaps |
2348 not a good idea. It also violates the principle of least | |
2349 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
2350 ERROR_ME and ERROR_ME_NOT don't. */ | |
428 | 2351 *badplace = Qnil; |
2352 } | |
2353 return Qunbound; | |
2354 } | |
2355 } | |
2356 | |
2357 /* Advance the tortoise pointer by two (one iteration of a property-list | |
2358 loop) and the hare pointer by four and verify that no malformations | |
2359 or circularities exist. If so, return zero and store a value into | |
2360 RETVAL that should be returned by the calling function. Otherwise, | |
2361 return 1. See external_plist_get(). | |
2362 */ | |
2363 | |
2364 static int | |
2365 advance_plist_pointers (Lisp_Object *plist, | |
2366 Lisp_Object **tortoise, Lisp_Object **hare, | |
578 | 2367 Error_Behavior errb, Lisp_Object *retval) |
428 | 2368 { |
2369 int i; | |
2370 Lisp_Object *tortsave = *tortoise; | |
2371 | |
2372 /* Note that our "fixing" may be more brutal than necessary, | |
2373 but it's the user's own problem, not ours, if they went in and | |
2374 manually fucked up a plist. */ | |
2375 | |
2376 for (i = 0; i < 2; i++) | |
2377 { | |
2378 /* This is a standard iteration of a defensive-loop-checking | |
2379 loop. We just do it twice because we want to advance past | |
2380 both the property and its value. | |
2381 | |
2382 If the pointer indirection is confusing you, remember that | |
2383 one level of indirection on the hare and tortoise pointers | |
2384 is only due to pass-by-reference for this function. The other | |
2385 level is so that the plist can be fixed in place. */ | |
2386 | |
2387 /* When we reach the end of a well-formed plist, **HARE is | |
2388 nil. In that case, we don't do anything at all except | |
2389 advance TORTOISE by one. Otherwise, we advance HARE | |
2390 by two (making sure it's OK to do so), then advance | |
2391 TORTOISE by one (it will always be OK to do so because | |
2392 the HARE is always ahead of the TORTOISE and will have | |
2393 already verified the path), then make sure TORTOISE and | |
2394 HARE don't contain the same non-nil object -- if the | |
2395 TORTOISE and the HARE ever meet, then obviously we're | |
2396 in a circularity, and if we're in a circularity, then | |
2397 the TORTOISE and the HARE can't cross paths without | |
2398 meeting, since the HARE only gains one step over the | |
2399 TORTOISE per iteration. */ | |
2400 | |
2401 if (!NILP (**hare)) | |
2402 { | |
2403 Lisp_Object *haresave = *hare; | |
2404 if (!CONSP (**hare)) | |
2405 { | |
2406 *retval = bad_bad_bunny (plist, haresave, errb); | |
2407 return 0; | |
2408 } | |
2409 *hare = &XCDR (**hare); | |
2410 /* In a non-plist, we'd check here for a nil value for | |
2411 **HARE, which is OK (it just means the list has an | |
2412 odd number of elements). In a plist, it's not OK | |
2413 for the list to have an odd number of elements. */ | |
2414 if (!CONSP (**hare)) | |
2415 { | |
2416 *retval = bad_bad_bunny (plist, haresave, errb); | |
2417 return 0; | |
2418 } | |
2419 *hare = &XCDR (**hare); | |
2420 } | |
2421 | |
2422 *tortoise = &XCDR (**tortoise); | |
2423 if (!NILP (**hare) && EQ (**tortoise, **hare)) | |
2424 { | |
2425 *retval = bad_bad_turtle (plist, tortsave, errb); | |
2426 return 0; | |
2427 } | |
2428 } | |
2429 | |
2430 return 1; | |
2431 } | |
2432 | |
2433 /* Return the value of PROPERTY from PLIST, or Qunbound if | |
2434 property is not on the list. | |
2435 | |
2436 PLIST is a Lisp-accessible property list, meaning that it | |
2437 has to be checked for malformations and circularities. | |
2438 | |
2439 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the | |
2440 function will never signal an error; and if ERRB is ERROR_ME_WARN, | |
2441 on finding a malformation or a circularity, it issues a warning and | |
2442 attempts to silently fix the problem. | |
2443 | |
2444 A pointer to PLIST is passed in so that PLIST can be successfully | |
2445 "fixed" even if the error is at the beginning of the plist. */ | |
2446 | |
2447 Lisp_Object | |
2448 external_plist_get (Lisp_Object *plist, Lisp_Object property, | |
578 | 2449 int laxp, Error_Behavior errb) |
428 | 2450 { |
2451 Lisp_Object *tortoise = plist; | |
2452 Lisp_Object *hare = plist; | |
2453 | |
2454 while (!NILP (*tortoise)) | |
2455 { | |
2456 Lisp_Object *tortsave = tortoise; | |
2457 Lisp_Object retval; | |
2458 | |
2459 /* We do the standard tortoise/hare march. We isolate the | |
2460 grungy stuff to do this in advance_plist_pointers(), though. | |
2461 To us, all this function does is advance the tortoise | |
2462 pointer by two and the hare pointer by four and make sure | |
2463 everything's OK. We first advance the pointers and then | |
2464 check if a property matched; this ensures that our | |
2465 check for a matching property is safe. */ | |
2466 | |
2467 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
2468 return retval; | |
2469 | |
2470 if (!laxp ? EQ (XCAR (*tortsave), property) | |
2471 : internal_equal (XCAR (*tortsave), property, 0)) | |
2472 return XCAR (XCDR (*tortsave)); | |
2473 } | |
2474 | |
2475 return Qunbound; | |
2476 } | |
2477 | |
2478 /* Set PLIST's value for PROPERTY to VALUE, given a possibly | |
2479 malformed or circular plist. Analogous to external_plist_get(). */ | |
2480 | |
2481 void | |
2482 external_plist_put (Lisp_Object *plist, Lisp_Object property, | |
578 | 2483 Lisp_Object value, int laxp, Error_Behavior errb) |
428 | 2484 { |
2485 Lisp_Object *tortoise = plist; | |
2486 Lisp_Object *hare = plist; | |
2487 | |
2488 while (!NILP (*tortoise)) | |
2489 { | |
2490 Lisp_Object *tortsave = tortoise; | |
2491 Lisp_Object retval; | |
2492 | |
2493 /* See above */ | |
2494 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
2495 return; | |
2496 | |
2497 if (!laxp ? EQ (XCAR (*tortsave), property) | |
2498 : internal_equal (XCAR (*tortsave), property, 0)) | |
2499 { | |
2500 XCAR (XCDR (*tortsave)) = value; | |
2501 return; | |
2502 } | |
2503 } | |
2504 | |
2505 *plist = Fcons (property, Fcons (value, *plist)); | |
2506 } | |
2507 | |
2508 int | |
2509 external_remprop (Lisp_Object *plist, Lisp_Object property, | |
578 | 2510 int laxp, Error_Behavior errb) |
428 | 2511 { |
2512 Lisp_Object *tortoise = plist; | |
2513 Lisp_Object *hare = plist; | |
2514 | |
2515 while (!NILP (*tortoise)) | |
2516 { | |
2517 Lisp_Object *tortsave = tortoise; | |
2518 Lisp_Object retval; | |
2519 | |
2520 /* See above */ | |
2521 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
2522 return 0; | |
2523 | |
2524 if (!laxp ? EQ (XCAR (*tortsave), property) | |
2525 : internal_equal (XCAR (*tortsave), property, 0)) | |
2526 { | |
2527 /* Now you see why it's so convenient to have that level | |
2528 of indirection. */ | |
2529 *tortsave = XCDR (XCDR (*tortsave)); | |
2530 return 1; | |
2531 } | |
2532 } | |
2533 | |
2534 return 0; | |
2535 } | |
2536 | |
2537 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /* | |
2538 Extract a value from a property list. | |
2539 PLIST is a property list, which is a list of the form | |
444 | 2540 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...). |
2541 PROPERTY is usually a symbol. | |
2542 This function returns the value corresponding to the PROPERTY, | |
2543 or DEFAULT if PROPERTY is not one of the properties on the list. | |
428 | 2544 */ |
444 | 2545 (plist, property, default_)) |
428 | 2546 { |
444 | 2547 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME); |
2548 return UNBOUNDP (value) ? default_ : value; | |
428 | 2549 } |
2550 | |
2551 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* | |
444 | 2552 Change value in PLIST of PROPERTY to VALUE. |
2553 PLIST is a property list, which is a list of the form | |
2554 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
2555 PROPERTY is usually a symbol and VALUE is any object. | |
2556 If PROPERTY is already a property on the list, its value is set to VALUE, | |
2557 otherwise the new PROPERTY VALUE pair is added. | |
2558 The new plist is returned; use `(setq x (plist-put x property value))' | |
2559 to be sure to use the new value. PLIST is modified by side effect. | |
428 | 2560 */ |
444 | 2561 (plist, property, value)) |
428 | 2562 { |
444 | 2563 external_plist_put (&plist, property, value, 0, ERROR_ME); |
428 | 2564 return plist; |
2565 } | |
2566 | |
2567 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /* | |
444 | 2568 Remove from PLIST the property PROPERTY and its value. |
2569 PLIST is a property list, which is a list of the form | |
2570 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
2571 PROPERTY is usually a symbol. | |
2572 The new plist is returned; use `(setq x (plist-remprop x property))' | |
2573 to be sure to use the new value. PLIST is modified by side effect. | |
428 | 2574 */ |
444 | 2575 (plist, property)) |
428 | 2576 { |
444 | 2577 external_remprop (&plist, property, 0, ERROR_ME); |
428 | 2578 return plist; |
2579 } | |
2580 | |
2581 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /* | |
444 | 2582 Return t if PROPERTY has a value specified in PLIST. |
428 | 2583 */ |
444 | 2584 (plist, property)) |
428 | 2585 { |
444 | 2586 Lisp_Object value = Fplist_get (plist, property, Qunbound); |
2587 return UNBOUNDP (value) ? Qnil : Qt; | |
428 | 2588 } |
2589 | |
2590 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* | |
2591 Given a plist, signal an error if there is anything wrong with it. | |
2592 This means that it's a malformed or circular plist. | |
2593 */ | |
2594 (plist)) | |
2595 { | |
2596 Lisp_Object *tortoise; | |
2597 Lisp_Object *hare; | |
2598 | |
2599 start_over: | |
2600 tortoise = &plist; | |
2601 hare = &plist; | |
2602 while (!NILP (*tortoise)) | |
2603 { | |
2604 Lisp_Object retval; | |
2605 | |
2606 /* See above */ | |
2607 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME, | |
2608 &retval)) | |
2609 goto start_over; | |
2610 } | |
2611 | |
2612 return Qnil; | |
2613 } | |
2614 | |
2615 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* | |
2616 Given a plist, return non-nil if its format is correct. | |
2617 If it returns nil, `check-valid-plist' will signal an error when given | |
442 | 2618 the plist; that means it's a malformed or circular plist. |
428 | 2619 */ |
2620 (plist)) | |
2621 { | |
2622 Lisp_Object *tortoise; | |
2623 Lisp_Object *hare; | |
2624 | |
2625 tortoise = &plist; | |
2626 hare = &plist; | |
2627 while (!NILP (*tortoise)) | |
2628 { | |
2629 Lisp_Object retval; | |
2630 | |
2631 /* See above */ | |
2632 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT, | |
2633 &retval)) | |
2634 return Qnil; | |
2635 } | |
2636 | |
2637 return Qt; | |
2638 } | |
2639 | |
2640 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /* | |
2641 Destructively remove any duplicate entries from a plist. | |
2642 In such cases, the first entry applies. | |
2643 | |
2644 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2645 a nil value is removed. This feature is a virus that has infected | |
2646 old Lisp implementations, but should not be used except for backward | |
2647 compatibility. | |
2648 | |
2649 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
2650 return value may not be EQ to the passed-in value, so make sure to | |
2651 `setq' the value back into where it came from. | |
2652 */ | |
2653 (plist, nil_means_not_present)) | |
2654 { | |
2655 Lisp_Object head = plist; | |
2656 | |
2657 Fcheck_valid_plist (plist); | |
2658 | |
2659 while (!NILP (plist)) | |
2660 { | |
2661 Lisp_Object prop = Fcar (plist); | |
2662 Lisp_Object next = Fcdr (plist); | |
2663 | |
2664 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
2665 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
2666 { | |
2667 if (EQ (head, plist)) | |
2668 head = Fcdr (next); | |
2669 plist = Fcdr (next); | |
2670 continue; | |
2671 } | |
2672 /* external_remprop returns 1 if it removed any property. | |
2673 We have to loop till it didn't remove anything, in case | |
2674 the property occurs many times. */ | |
2675 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) | |
2676 DO_NOTHING; | |
2677 plist = Fcdr (next); | |
2678 } | |
2679 | |
2680 return head; | |
2681 } | |
2682 | |
2683 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* | |
2684 Extract a value from a lax property list. | |
444 | 2685 LAX-PLIST is a lax property list, which is a list of the form |
2686 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
2687 properties is done using `equal' instead of `eq'. | |
2688 PROPERTY is usually a symbol. | |
2689 This function returns the value corresponding to PROPERTY, | |
2690 or DEFAULT if PROPERTY is not one of the properties on the list. | |
428 | 2691 */ |
444 | 2692 (lax_plist, property, default_)) |
428 | 2693 { |
444 | 2694 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME); |
2695 return UNBOUNDP (value) ? default_ : value; | |
428 | 2696 } |
2697 | |
2698 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* | |
444 | 2699 Change value in LAX-PLIST of PROPERTY to VALUE. |
2700 LAX-PLIST is a lax property list, which is a list of the form | |
2701 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
2702 properties is done using `equal' instead of `eq'. | |
2703 PROPERTY is usually a symbol and VALUE is any object. | |
2704 If PROPERTY is already a property on the list, its value is set to | |
2705 VALUE, otherwise the new PROPERTY VALUE pair is added. | |
2706 The new plist is returned; use `(setq x (lax-plist-put x property value))' | |
2707 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
428 | 2708 */ |
444 | 2709 (lax_plist, property, value)) |
428 | 2710 { |
444 | 2711 external_plist_put (&lax_plist, property, value, 1, ERROR_ME); |
428 | 2712 return lax_plist; |
2713 } | |
2714 | |
2715 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* | |
444 | 2716 Remove from LAX-PLIST the property PROPERTY and its value. |
2717 LAX-PLIST is a lax property list, which is a list of the form | |
2718 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
2719 properties is done using `equal' instead of `eq'. | |
2720 PROPERTY is usually a symbol. | |
2721 The new plist is returned; use `(setq x (lax-plist-remprop x property))' | |
2722 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
428 | 2723 */ |
444 | 2724 (lax_plist, property)) |
428 | 2725 { |
444 | 2726 external_remprop (&lax_plist, property, 1, ERROR_ME); |
428 | 2727 return lax_plist; |
2728 } | |
2729 | |
2730 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* | |
444 | 2731 Return t if PROPERTY has a value specified in LAX-PLIST. |
2732 LAX-PLIST is a lax property list, which is a list of the form | |
2733 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
2734 properties is done using `equal' instead of `eq'. | |
428 | 2735 */ |
444 | 2736 (lax_plist, property)) |
428 | 2737 { |
444 | 2738 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt; |
428 | 2739 } |
2740 | |
2741 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /* | |
2742 Destructively remove any duplicate entries from a lax plist. | |
2743 In such cases, the first entry applies. | |
2744 | |
2745 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
2746 a nil value is removed. This feature is a virus that has infected | |
2747 old Lisp implementations, but should not be used except for backward | |
2748 compatibility. | |
2749 | |
2750 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
2751 return value may not be EQ to the passed-in value, so make sure to | |
2752 `setq' the value back into where it came from. | |
2753 */ | |
2754 (lax_plist, nil_means_not_present)) | |
2755 { | |
2756 Lisp_Object head = lax_plist; | |
2757 | |
2758 Fcheck_valid_plist (lax_plist); | |
2759 | |
2760 while (!NILP (lax_plist)) | |
2761 { | |
2762 Lisp_Object prop = Fcar (lax_plist); | |
2763 Lisp_Object next = Fcdr (lax_plist); | |
2764 | |
2765 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
2766 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
2767 { | |
2768 if (EQ (head, lax_plist)) | |
2769 head = Fcdr (next); | |
2770 lax_plist = Fcdr (next); | |
2771 continue; | |
2772 } | |
2773 /* external_remprop returns 1 if it removed any property. | |
2774 We have to loop till it didn't remove anything, in case | |
2775 the property occurs many times. */ | |
2776 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) | |
2777 DO_NOTHING; | |
2778 lax_plist = Fcdr (next); | |
2779 } | |
2780 | |
2781 return head; | |
2782 } | |
2783 | |
2784 /* In C because the frame props stuff uses it */ | |
2785 | |
2786 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /* | |
2787 Convert association list ALIST into the equivalent property-list form. | |
2788 The plist is returned. This converts from | |
2789 | |
2790 \((a . 1) (b . 2) (c . 3)) | |
2791 | |
2792 into | |
2793 | |
2794 \(a 1 b 2 c 3) | |
2795 | |
2796 The original alist is destroyed in the process of constructing the plist. | |
2797 See also `alist-to-plist'. | |
2798 */ | |
2799 (alist)) | |
2800 { | |
2801 Lisp_Object head = alist; | |
2802 while (!NILP (alist)) | |
2803 { | |
2804 /* remember the alist element. */ | |
2805 Lisp_Object el = Fcar (alist); | |
2806 | |
2807 Fsetcar (alist, Fcar (el)); | |
2808 Fsetcar (el, Fcdr (el)); | |
2809 Fsetcdr (el, Fcdr (alist)); | |
2810 Fsetcdr (alist, el); | |
2811 alist = Fcdr (Fcdr (alist)); | |
2812 } | |
2813 | |
2814 return head; | |
2815 } | |
2816 | |
2817 DEFUN ("get", Fget, 2, 3, 0, /* | |
442 | 2818 Return the value of OBJECT's PROPERTY property. |
2819 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. | |
428 | 2820 If there is no such property, return optional third arg DEFAULT |
442 | 2821 \(which defaults to `nil'). OBJECT can be a symbol, string, extent, |
2822 face, or glyph. See also `put', `remprop', and `object-plist'. | |
428 | 2823 */ |
442 | 2824 (object, property, default_)) |
428 | 2825 { |
2826 /* Various places in emacs call Fget() and expect it not to quit, | |
2827 so don't quit. */ | |
442 | 2828 Lisp_Object val; |
2829 | |
2830 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) | |
2831 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); | |
428 | 2832 else |
563 | 2833 invalid_operation ("Object type has no properties", object); |
442 | 2834 |
2835 return UNBOUNDP (val) ? default_ : val; | |
428 | 2836 } |
2837 | |
2838 DEFUN ("put", Fput, 3, 3, 0, /* | |
442 | 2839 Set OBJECT's PROPERTY to VALUE. |
2840 It can be subsequently retrieved with `(get OBJECT PROPERTY)'. | |
2841 OBJECT can be a symbol, face, extent, or string. | |
428 | 2842 For a string, no properties currently have predefined meanings. |
2843 For the predefined properties for extents, see `set-extent-property'. | |
2844 For the predefined properties for faces, see `set-face-property'. | |
2845 See also `get', `remprop', and `object-plist'. | |
2846 */ | |
442 | 2847 (object, property, value)) |
428 | 2848 { |
1920 | 2849 /* This function cannot GC */ |
428 | 2850 CHECK_LISP_WRITEABLE (object); |
2851 | |
442 | 2852 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) |
428 | 2853 { |
442 | 2854 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop |
2855 (object, property, value)) | |
563 | 2856 invalid_change ("Can't set property on object", property); |
428 | 2857 } |
2858 else | |
563 | 2859 invalid_change ("Object type has no settable properties", object); |
428 | 2860 |
2861 return value; | |
2862 } | |
2863 | |
2864 DEFUN ("remprop", Fremprop, 2, 2, 0, /* | |
442 | 2865 Remove, from OBJECT's property list, PROPERTY and its corresponding value. |
2866 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil | |
2867 if the property list was actually modified (i.e. if PROPERTY was present | |
2868 in the property list). See also `get', `put', and `object-plist'. | |
428 | 2869 */ |
442 | 2870 (object, property)) |
428 | 2871 { |
442 | 2872 int ret = 0; |
2873 | |
428 | 2874 CHECK_LISP_WRITEABLE (object); |
2875 | |
442 | 2876 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) |
428 | 2877 { |
442 | 2878 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); |
2879 if (ret == -1) | |
563 | 2880 invalid_change ("Can't remove property from object", property); |
428 | 2881 } |
2882 else | |
563 | 2883 invalid_change ("Object type has no removable properties", object); |
442 | 2884 |
2885 return ret ? Qt : Qnil; | |
428 | 2886 } |
2887 | |
2888 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* | |
442 | 2889 Return a property list of OBJECT's properties. |
2890 For a symbol, this is equivalent to `symbol-plist'. | |
2891 OBJECT can be a symbol, string, extent, face, or glyph. | |
2892 Do not modify the returned property list directly; | |
2893 this may or may not have the desired effects. Use `put' instead. | |
428 | 2894 */ |
2895 (object)) | |
2896 { | |
442 | 2897 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) |
2898 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); | |
428 | 2899 else |
563 | 2900 invalid_operation ("Object type has no properties", object); |
428 | 2901 |
2902 return Qnil; | |
2903 } | |
2904 | |
2905 | |
853 | 2906 static Lisp_Object |
2907 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, | |
2908 Lisp_Object depth) | |
2909 { | |
2910 return make_int (internal_equal (obj1, obj2, XINT (depth))); | |
2911 } | |
2912 | |
2913 int | |
2914 internal_equal_trapping_problems (Lisp_Object warning_class, | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2915 const Ascbyte *warning_string, |
853 | 2916 int flags, |
2917 struct call_trapping_problems_result *p, | |
2918 int retval, | |
2919 Lisp_Object obj1, Lisp_Object obj2, | |
2920 int depth) | |
2921 { | |
2922 Lisp_Object glorp = | |
2923 va_call_trapping_problems (warning_class, warning_string, | |
2924 flags, p, | |
2925 (lisp_fn_t) tweaked_internal_equal, | |
2926 3, obj1, obj2, make_int (depth)); | |
2927 if (UNBOUNDP (glorp)) | |
2928 return retval; | |
2929 else | |
2930 return XINT (glorp); | |
2931 } | |
2932 | |
428 | 2933 int |
2934 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
2935 { | |
2936 if (depth > 200) | |
563 | 2937 stack_overflow ("Stack overflow in equal", Qunbound); |
428 | 2938 QUIT; |
2939 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) | |
2940 return 1; | |
2941 /* Note that (equal 20 20.0) should be nil */ | |
2942 if (XTYPE (obj1) != XTYPE (obj2)) | |
2943 return 0; | |
2944 if (LRECORDP (obj1)) | |
2945 { | |
442 | 2946 const struct lrecord_implementation |
428 | 2947 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), |
2948 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
2949 | |
2950 return (imp1 == imp2) && | |
2951 /* EQ-ness of the objects was noticed above */ | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2952 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0)); |
428 | 2953 } |
2954 | |
2955 return 0; | |
2956 } | |
2957 | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2958 enum array_type |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2959 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2960 ARRAY_NONE = 0, |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2961 ARRAY_STRING, |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2962 ARRAY_VECTOR, |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2963 ARRAY_BIT_VECTOR |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2964 }; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2965 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2966 static enum array_type |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2967 array_type (Lisp_Object obj) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2968 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2969 if (STRINGP (obj)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2970 return ARRAY_STRING; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2971 if (VECTORP (obj)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2972 return ARRAY_VECTOR; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2973 if (BIT_VECTORP (obj)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2974 return ARRAY_BIT_VECTOR; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2975 return ARRAY_NONE; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2976 } |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2977 |
801 | 2978 int |
2979 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
2980 { | |
2981 if (depth > 200) | |
2982 stack_overflow ("Stack overflow in equalp", Qunbound); | |
2983 QUIT; | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2984 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2985 /* 1. Objects that are `eq' are equal. This will catch the common case |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2986 of two equal fixnums or the same object seen twice. */ |
801 | 2987 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) |
2988 return 1; | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2989 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2990 /* 2. If both numbers, compare with `='. */ |
1983 | 2991 if (NUMBERP (obj1) && NUMBERP (obj2)) |
2992 { | |
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
2993 return (0 == bytecode_arithcompare (obj1, obj2)); |
1983 | 2994 } |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2995 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2996 /* 3. If characters, compare case-insensitively. */ |
801 | 2997 if (CHARP (obj1) && CHARP (obj2)) |
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
2998 return CANONCASE (0, XCHAR (obj1)) == CANONCASE (0, XCHAR (obj2)); |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2999 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3000 /* 4. If arrays of different types, compare their lengths, and |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3001 then compare element-by-element. */ |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3002 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3003 enum array_type artype1, artype2; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3004 artype1 = array_type (obj1); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3005 artype2 = array_type (obj2); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3006 if (artype1 != artype2 && artype1 && artype2) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3007 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3008 EMACS_INT i; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3009 EMACS_INT l1 = XINT (Flength (obj1)); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3010 EMACS_INT l2 = XINT (Flength (obj2)); |
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
3011 /* Both arrays, but of different lengths */ |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3012 if (l1 != l2) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3013 return 0; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3014 for (i = 0; i < l1; i++) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3015 if (!internal_equalp (Faref (obj1, make_int (i)), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3016 Faref (obj2, make_int (i)), depth + 1)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3017 return 0; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3018 return 1; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3019 } |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3020 } |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3021 /* 5. Else, they must be the same type. If so, call the equal() method, |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3022 telling it to fold case. For objects that care about case-folding |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3023 their contents, the equal() method will call internal_equal_0(). */ |
801 | 3024 if (XTYPE (obj1) != XTYPE (obj2)) |
3025 return 0; | |
3026 if (LRECORDP (obj1)) | |
3027 { | |
3028 const struct lrecord_implementation | |
3029 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), | |
3030 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
3031 | |
3032 return (imp1 == imp2) && | |
3033 /* EQ-ness of the objects was noticed above */ | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3034 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1)); |
801 | 3035 } |
3036 | |
3037 return 0; | |
3038 } | |
3039 | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3040 int |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3041 internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3042 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3043 if (foldcase) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3044 return internal_equalp (obj1, obj2, depth); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3045 else |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3046 return internal_equal (obj1, obj2, depth); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3047 } |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3048 |
428 | 3049 /* Note that we may be calling sub-objects that will use |
3050 internal_equal() (instead of internal_old_equal()). Oh well. | |
3051 We will get an Ebola note if there's any possibility of confusion, | |
3052 but that seems unlikely. */ | |
3053 | |
3054 static int | |
3055 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
3056 { | |
3057 if (depth > 200) | |
563 | 3058 stack_overflow ("Stack overflow in equal", Qunbound); |
428 | 3059 QUIT; |
3060 if (HACKEQ_UNSAFE (obj1, obj2)) | |
3061 return 1; | |
3062 /* Note that (equal 20 20.0) should be nil */ | |
3063 if (XTYPE (obj1) != XTYPE (obj2)) | |
3064 return 0; | |
3065 | |
3066 return internal_equal (obj1, obj2, depth); | |
3067 } | |
3068 | |
3069 DEFUN ("equal", Fequal, 2, 2, 0, /* | |
3070 Return t if two Lisp objects have similar structure and contents. | |
3071 They must have the same data type. | |
3072 Conses are compared by comparing the cars and the cdrs. | |
3073 Vectors and strings are compared element by element. | |
3074 Numbers are compared by value. Symbols must match exactly. | |
3075 */ | |
444 | 3076 (object1, object2)) |
428 | 3077 { |
444 | 3078 return internal_equal (object1, object2, 0) ? Qt : Qnil; |
428 | 3079 } |
3080 | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3081 DEFUN ("equalp", Fequalp, 2, 2, 0, /* |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3082 Return t if two Lisp objects have similar structure and contents. |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3083 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3084 This is like `equal', except that it accepts numerically equal |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3085 numbers of different types (float, integer, bignum, bigfloat), and also |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3086 compares strings and characters case-insensitively. |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3087 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3088 Type objects that are arrays (that is, strings, bit-vectors, and vectors) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3089 of the same length and with contents that are `equalp' are themselves |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3090 `equalp', regardless of whether the two objects have the same type. |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3091 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3092 Other objects whose primary purpose is as containers of other objects are |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3093 `equalp' if they would otherwise be equal (same length, type, etc.) and |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3094 their contents are `equalp'. This goes for conses, weak lists, |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3095 weak boxes, ephemerons, specifiers, hash tables, char tables and range |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3096 tables. However, objects that happen to contain other objects but are not |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3097 primarily designed for this purpose (e.g. compiled functions, events or |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3098 display-related objects such as glyphs, faces or extents) are currently |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3099 compared using `equalp' the same way as using `equal'. |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3100 |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3101 More specifically, two hash tables are `equalp' if they have the same test |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3102 (see `hash-table-test'), the same number of entries, and the same value for |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3103 `hash-table-weakness', and if, for each entry in one hash table, its key is |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3104 equivalent to a key in the other hash table using the hash table test, and |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3105 its value is `equalp' to the other hash table's value for that key. |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3106 */ |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3107 (object1, object2)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3108 { |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3109 return internal_equalp (object1, object2, 0) ? Qt : Qnil; |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3110 } |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3111 |
428 | 3112 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* |
3113 Return t if two Lisp objects have similar structure and contents. | |
3114 They must have the same data type. | |
3115 \(Note, however, that an exception is made for characters and integers; | |
3116 this is known as the "char-int confoundance disease." See `eq' and | |
3117 `old-eq'.) | |
3118 This function is provided only for byte-code compatibility with v19. | |
3119 Do not use it. | |
3120 */ | |
444 | 3121 (object1, object2)) |
428 | 3122 { |
444 | 3123 return internal_old_equal (object1, object2, 0) ? Qt : Qnil; |
428 | 3124 } |
3125 | |
3126 | |
3127 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* | |
434 | 3128 Destructively modify ARRAY by replacing each element with ITEM. |
428 | 3129 ARRAY is a vector, bit vector, or string. |
3130 */ | |
3131 (array, item)) | |
3132 { | |
3133 retry: | |
3134 if (STRINGP (array)) | |
3135 { | |
793 | 3136 Bytecount old_bytecount = XSTRING_LENGTH (array); |
434 | 3137 Bytecount new_bytecount; |
3138 Bytecount item_bytecount; | |
867 | 3139 Ibyte item_buf[MAX_ICHAR_LEN]; |
3140 Ibyte *p; | |
3141 Ibyte *end; | |
434 | 3142 |
428 | 3143 CHECK_CHAR_COERCE_INT (item); |
2720 | 3144 |
428 | 3145 CHECK_LISP_WRITEABLE (array); |
771 | 3146 sledgehammer_check_ascii_begin (array); |
867 | 3147 item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); |
826 | 3148 new_bytecount = item_bytecount * (Bytecount) string_char_length (array); |
793 | 3149 |
3150 resize_string (array, -1, new_bytecount - old_bytecount); | |
3151 | |
3152 for (p = XSTRING_DATA (array), end = p + new_bytecount; | |
434 | 3153 p < end; |
3154 p += item_bytecount) | |
3155 memcpy (p, item_buf, item_bytecount); | |
3156 *p = '\0'; | |
3157 | |
793 | 3158 XSET_STRING_ASCII_BEGIN (array, |
3159 item_bytecount == 1 ? | |
3160 min (new_bytecount, MAX_STRING_ASCII_BEGIN) : | |
3161 0); | |
428 | 3162 bump_string_modiff (array); |
771 | 3163 sledgehammer_check_ascii_begin (array); |
428 | 3164 } |
3165 else if (VECTORP (array)) | |
3166 { | |
3167 Lisp_Object *p = XVECTOR_DATA (array); | |
665 | 3168 Elemcount len = XVECTOR_LENGTH (array); |
428 | 3169 CHECK_LISP_WRITEABLE (array); |
3170 while (len--) | |
3171 *p++ = item; | |
3172 } | |
3173 else if (BIT_VECTORP (array)) | |
3174 { | |
440 | 3175 Lisp_Bit_Vector *v = XBIT_VECTOR (array); |
665 | 3176 Elemcount len = bit_vector_length (v); |
428 | 3177 int bit; |
3178 CHECK_BIT (item); | |
444 | 3179 bit = XINT (item); |
428 | 3180 CHECK_LISP_WRITEABLE (array); |
3181 while (len--) | |
3182 set_bit_vector_bit (v, len, bit); | |
3183 } | |
3184 else | |
3185 { | |
3186 array = wrong_type_argument (Qarrayp, array); | |
3187 goto retry; | |
3188 } | |
3189 return array; | |
3190 } | |
3191 | |
3192 Lisp_Object | |
3193 nconc2 (Lisp_Object arg1, Lisp_Object arg2) | |
3194 { | |
3195 Lisp_Object args[2]; | |
3196 struct gcpro gcpro1; | |
3197 args[0] = arg1; | |
3198 args[1] = arg2; | |
3199 | |
3200 GCPRO1 (args[0]); | |
3201 gcpro1.nvars = 2; | |
3202 | |
3203 RETURN_UNGCPRO (bytecode_nconc2 (args)); | |
3204 } | |
3205 | |
3206 Lisp_Object | |
3207 bytecode_nconc2 (Lisp_Object *args) | |
3208 { | |
3209 retry: | |
3210 | |
3211 if (CONSP (args[0])) | |
3212 { | |
3213 /* (setcdr (last args[0]) args[1]) */ | |
3214 Lisp_Object tortoise, hare; | |
665 | 3215 Elemcount count; |
428 | 3216 |
3217 for (hare = tortoise = args[0], count = 0; | |
3218 CONSP (XCDR (hare)); | |
3219 hare = XCDR (hare), count++) | |
3220 { | |
3221 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
3222 | |
3223 if (count & 1) | |
3224 tortoise = XCDR (tortoise); | |
3225 if (EQ (hare, tortoise)) | |
3226 signal_circular_list_error (args[0]); | |
3227 } | |
3228 XCDR (hare) = args[1]; | |
3229 return args[0]; | |
3230 } | |
3231 else if (NILP (args[0])) | |
3232 { | |
3233 return args[1]; | |
3234 } | |
3235 else | |
3236 { | |
3237 args[0] = wrong_type_argument (args[0], Qlistp); | |
3238 goto retry; | |
3239 } | |
3240 } | |
3241 | |
3242 DEFUN ("nconc", Fnconc, 0, MANY, 0, /* | |
3243 Concatenate any number of lists by altering them. | |
3244 Only the last argument is not altered, and need not be a list. | |
3245 Also see: `append'. | |
3246 If the first argument is nil, there is no way to modify it by side | |
3247 effect; therefore, write `(setq foo (nconc foo list))' to be sure of | |
3248 changing the value of `foo'. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
3249 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
3250 arguments: (&rest ARGS) |
428 | 3251 */ |
3252 (int nargs, Lisp_Object *args)) | |
3253 { | |
3254 int argnum = 0; | |
3255 struct gcpro gcpro1; | |
3256 | |
3257 /* The modus operandi in Emacs is "caller gc-protects args". | |
3258 However, nconc (particularly nconc2 ()) is called many times | |
3259 in Emacs on freshly created stuff (e.g. you see the idiom | |
3260 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those | |
3261 callers out by protecting the args ourselves to save them | |
3262 a lot of temporary-variable grief. */ | |
3263 | |
3264 GCPRO1 (args[0]); | |
3265 gcpro1.nvars = nargs; | |
3266 | |
3267 while (argnum < nargs) | |
3268 { | |
3269 Lisp_Object val; | |
3270 retry: | |
3271 val = args[argnum]; | |
3272 if (CONSP (val)) | |
3273 { | |
3274 /* `val' is the first cons, which will be our return value. */ | |
3275 /* `last_cons' will be the cons cell to mutate. */ | |
3276 Lisp_Object last_cons = val; | |
3277 Lisp_Object tortoise = val; | |
3278 | |
3279 for (argnum++; argnum < nargs; argnum++) | |
3280 { | |
3281 Lisp_Object next = args[argnum]; | |
3282 retry_next: | |
3283 if (CONSP (next) || argnum == nargs -1) | |
3284 { | |
3285 /* (setcdr (last val) next) */ | |
665 | 3286 Elemcount count; |
428 | 3287 |
3288 for (count = 0; | |
3289 CONSP (XCDR (last_cons)); | |
3290 last_cons = XCDR (last_cons), count++) | |
3291 { | |
3292 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
3293 | |
3294 if (count & 1) | |
3295 tortoise = XCDR (tortoise); | |
3296 if (EQ (last_cons, tortoise)) | |
3297 signal_circular_list_error (args[argnum-1]); | |
3298 } | |
3299 XCDR (last_cons) = next; | |
3300 } | |
3301 else if (NILP (next)) | |
3302 { | |
3303 continue; | |
3304 } | |
3305 else | |
3306 { | |
3307 next = wrong_type_argument (Qlistp, next); | |
3308 goto retry_next; | |
3309 } | |
3310 } | |
3311 RETURN_UNGCPRO (val); | |
3312 } | |
3313 else if (NILP (val)) | |
3314 argnum++; | |
3315 else if (argnum == nargs - 1) /* last arg? */ | |
3316 RETURN_UNGCPRO (val); | |
3317 else | |
3318 { | |
3319 args[argnum] = wrong_type_argument (Qlistp, val); | |
3320 goto retry; | |
3321 } | |
3322 } | |
3323 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ | |
3324 } | |
3325 | |
3326 | |
434 | 3327 /* This is the guts of several mapping functions. |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3328 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3329 Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3330 taking the elements from SEQUENCES. If VALS is non-NULL, store the |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3331 results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3332 non-nil, store the results into LISP_VALS, a sequence with sufficient |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3333 room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.) |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3334 Else, do not accumulate any result. |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3335 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3336 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3337 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3338 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3339 mapcarX. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3340 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3341 Otherwise, mapcarX signals a wrong-type-error if it encounters a |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3342 non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3343 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3344 destructively modifies SEQUENCES in a way that might affect the ongoing |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3345 traversal operation. |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3346 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3347 If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3348 values given by FUNCTION the first time it is non-nil, and abandon the |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3349 iterations. LISP_VALS must be a cons, and the return value will be |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3350 stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3351 in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3352 alone. */ |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3353 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3354 #define SOME_OR_EVERY_NEITHER 0 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3355 #define SOME_OR_EVERY_SOME 1 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3356 #define SOME_OR_EVERY_EVERY 2 |
428 | 3357 |
3358 static void | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3359 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3360 Lisp_Object function, int nsequences, Lisp_Object *sequences, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3361 int some_or_every) |
428 | 3362 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3363 Lisp_Object called, *args; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3364 struct gcpro gcpro1, gcpro2; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3365 int i, j; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3366 enum lrecord_type lisp_vals_type; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3367 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3368 assert (LRECORDP (lisp_vals)); |
4999 | 3369 lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3370 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3371 args = alloca_array (Lisp_Object, nsequences + 1); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3372 args[0] = function; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3373 for (i = 1; i <= nsequences; ++i) |
428 | 3374 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3375 args[i] = Qnil; |
428 | 3376 } |
3377 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3378 if (vals != NULL) |
428 | 3379 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3380 GCPRO2 (args[0], vals[0]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3381 gcpro1.nvars = nsequences + 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3382 gcpro2.nvars = 0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3383 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3384 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3385 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3386 GCPRO1 (args[0]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3387 gcpro1.nvars = nsequences + 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3388 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3389 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3390 /* Be extra nice in the event that we've been handed one list and one |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3391 only; make it possible for FUNCTION to set cdrs not yet processed to |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3392 non-cons, non-nil objects without ill-effect, if we have been handed |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3393 the stack space to do that. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3394 if (vals != NULL && 1 == nsequences && CONSP (sequences[0])) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3395 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3396 Lisp_Object lst = sequences[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3397 Lisp_Object *val = vals; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3398 for (i = 0; i < call_count; ++i) |
434 | 3399 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3400 *val++ = XCAR (lst); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3401 lst = XCDR (lst); |
428 | 3402 } |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3403 gcpro2.nvars = call_count; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3404 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3405 for (i = 0; i < call_count; ++i) |
428 | 3406 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3407 args[1] = vals[i]; |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3408 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args)); |
428 | 3409 } |
3410 } | |
3411 else | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3412 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3413 Binbyte *sequence_types = alloca_array (Binbyte, nsequences); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3414 for (j = 0; j < nsequences; ++j) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3415 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3416 sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3417 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3418 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3419 for (i = 0; i < call_count; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3420 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3421 for (j = 0; j < nsequences; ++j) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3422 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3423 switch (sequence_types[j]) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3424 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3425 case lrecord_type_cons: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3426 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3427 if (!CONSP (sequences[j])) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3428 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3429 /* This means FUNCTION has probably messed |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3430 around with a cons in one of the sequences, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3431 since we checked the type |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3432 (CHECK_SEQUENCE()) and the length and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3433 structure (with Flength()) correctly in our |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3434 callers. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3435 dead_wrong_type_argument (Qconsp, sequences[j]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3436 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3437 args[j + 1] = XCAR (sequences[j]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3438 sequences[j] = XCDR (sequences[j]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3439 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3440 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3441 case lrecord_type_vector: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3442 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3443 args[j + 1] = XVECTOR_DATA (sequences[j])[i]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3444 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3445 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3446 case lrecord_type_string: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3447 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3448 args[j + 1] = make_char (string_ichar (sequences[j], i)); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3449 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3450 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3451 case lrecord_type_bit_vector: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3452 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3453 args[j + 1] |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3454 = make_int (bit_vector_bit (XBIT_VECTOR (sequences[j]), |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3455 i)); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3456 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3457 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3458 default: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3459 ABORT(); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3460 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3461 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3462 called = Ffuncall (nsequences + 1, args); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3463 if (vals != NULL) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3464 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3465 vals[i] = IGNORE_MULTIPLE_VALUES (called); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3466 gcpro2.nvars += 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3467 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3468 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3469 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3470 switch (lisp_vals_type) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3471 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3472 case lrecord_type_symbol: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3473 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3474 case lrecord_type_cons: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3475 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3476 if (SOME_OR_EVERY_NEITHER == some_or_every) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3477 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3478 called = IGNORE_MULTIPLE_VALUES (called); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3479 if (!CONSP (lisp_vals)) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3480 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3481 /* If FUNCTION has inserted a non-cons non-nil |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3482 cdr into the list before we've processed the |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3483 relevant part, error. */ |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3484 dead_wrong_type_argument (Qconsp, lisp_vals); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3485 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3486 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3487 XSETCAR (lisp_vals, called); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3488 lisp_vals = XCDR (lisp_vals); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3489 break; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3490 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3491 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3492 if (SOME_OR_EVERY_SOME == some_or_every) |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3493 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3494 if (!NILP (IGNORE_MULTIPLE_VALUES (called))) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3495 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3496 XCAR (lisp_vals) = called; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3497 UNGCPRO; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3498 return; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3499 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3500 break; |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3501 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3502 |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3503 if (SOME_OR_EVERY_EVERY == some_or_every) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3504 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3505 called = IGNORE_MULTIPLE_VALUES (called); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3506 if (NILP (called)) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3507 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3508 XCAR (lisp_vals) = Qnil; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3509 UNGCPRO; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3510 return; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3511 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3512 break; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3513 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3514 |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3515 goto bad_some_or_every_flag; |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3516 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3517 case lrecord_type_vector: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3518 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3519 called = IGNORE_MULTIPLE_VALUES (called); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3520 i < XVECTOR_LENGTH (lisp_vals) ? |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3521 (XVECTOR_DATA (lisp_vals)[i] = called) : |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3522 /* Let #'aset error. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3523 Faset (lisp_vals, make_int (i), called); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3524 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3525 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3526 case lrecord_type_string: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3527 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3528 /* If this ever becomes a code hotspot, we can keep |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3529 around pointers into the data of the string, checking |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3530 each time that it hasn't been relocated. */ |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3531 called = IGNORE_MULTIPLE_VALUES (called); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3532 Faset (lisp_vals, make_int (i), called); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3533 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3534 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3535 case lrecord_type_bit_vector: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3536 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3537 called = IGNORE_MULTIPLE_VALUES (called); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3538 (BITP (called) && |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3539 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3540 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3541 XINT (called)) : |
5002
0cd784a6ec44
fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents:
5001
diff
changeset
|
3542 (void) Faset (lisp_vals, make_int (i), called); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3543 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3544 } |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3545 bad_some_or_every_flag: |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3546 default: |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3547 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3548 ABORT(); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3549 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3550 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3551 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3552 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3553 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3554 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3555 UNGCPRO; |
428 | 3556 } |
3557 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3558 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3559 Call FUNCTION on each element of SEQUENCE, and concat results to a string. |
751 | 3560 Between each pair of results, insert SEPARATOR. |
3561 | |
3562 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR | |
3563 results in spaces between the values returned by FUNCTION. SEQUENCE itself | |
3564 may be a list, a vector, a bit vector, or a string. | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3565 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3566 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3567 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3568 from each sequence will be used each time FUNCTION is called, and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3569 `mapconcat' will give up once the shortest sequence is exhausted. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3570 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3571 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES) |
428 | 3572 */ |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3573 (int nargs, Lisp_Object *args)) |
428 | 3574 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3575 Lisp_Object function = args[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3576 Lisp_Object sequence = args[1]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3577 Lisp_Object separator = args[2]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3578 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3579 Lisp_Object *args0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3580 EMACS_INT i, nargs0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3581 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3582 args[2] = sequence; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3583 args[1] = separator; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3584 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3585 for (i = 2; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3586 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3587 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3588 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3589 } |
428 | 3590 |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3591 if (len == 0) return build_ascstring (""); |
428 | 3592 |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3593 nargs0 = len + len - 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3594 args0 = alloca_array (Lisp_Object, nargs0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3595 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3596 /* Special-case this, it's very common and doesn't require any |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3597 funcalls. Upside of doing it here, instead of cl-macs.el: no consing, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3598 apart from the final string, we allocate everything on the stack. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3599 if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3600 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3601 for (i = 0; i < len; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3602 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3603 args0[i] = XCAR (sequence); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3604 sequence = XCDR (sequence); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3605 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3606 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3607 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3608 { |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3609 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3610 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3611 } |
428 | 3612 |
3613 for (i = len - 1; i >= 0; i--) | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3614 args0[i + i] = args0[i]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3615 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3616 for (i = 1; i < nargs0; i += 2) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3617 args0[i] = separator; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3618 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3619 return Fconcat (nargs0, args0); |
428 | 3620 } |
3621 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3622 DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3623 Call FUNCTION on each element of SEQUENCE; return a list of the results. |
434 | 3624 The result is a list of the same length as SEQUENCE. |
428 | 3625 SEQUENCE may be a list, a vector, a bit vector, or a string. |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3626 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3627 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3628 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3629 from each sequence will be used each time FUNCTION is called, and `mapcar' |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3630 stops calling FUNCTION once the shortest sequence is exhausted. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3631 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3632 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
428 | 3633 */ |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3634 (int nargs, Lisp_Object *args)) |
428 | 3635 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3636 Lisp_Object function = args[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3637 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3638 Lisp_Object *args0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3639 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3640 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3641 for (i = 1; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3642 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3643 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3644 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3645 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3646 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3647 args0 = alloca_array (Lisp_Object, len); |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3648 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3649 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3650 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3651 return Flist ((int) len, args0); |
428 | 3652 } |
3653 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3654 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3655 Call FUNCTION on each element of SEQUENCE; return a vector of the results. |
428 | 3656 The result is a vector of the same length as SEQUENCE. |
434 | 3657 SEQUENCE may be a list, a vector, a bit vector, or a string. |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3658 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3659 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3660 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3661 from each sequence will be used each time FUNCTION is called, and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3662 `mapvector' stops calling FUNCTION once the shortest sequence is exhausted. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3663 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3664 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
428 | 3665 */ |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3666 (int nargs, Lisp_Object *args)) |
428 | 3667 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3668 Lisp_Object function = args[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3669 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3670 Lisp_Object result; |
428 | 3671 struct gcpro gcpro1; |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3672 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3673 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3674 for (i = 1; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3675 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3676 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3677 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3678 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3679 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3680 result = make_vector (len, Qnil); |
428 | 3681 GCPRO1 (result); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3682 /* Don't pass result as the lisp_object argument, we want mapcarX to protect |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3683 a single list argument's elements from being garbage-collected. */ |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3684 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3685 SOME_OR_EVERY_NEITHER); |
428 | 3686 UNGCPRO; |
3687 | |
3688 return result; | |
3689 } | |
3690 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3691 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3692 Call FUNCTION on each element of SEQUENCE; chain the results together. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3693 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3694 FUNCTION must normally return a list; the results will be concatenated |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3695 together using `nconc'. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3696 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3697 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3698 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3699 from each sequence will be used each time FUNCTION is called, and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3700 `mapcan' stops calling FUNCTION once the shortest sequence is exhausted. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3701 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3702 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3703 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3704 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3705 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3706 Lisp_Object function = args[0], nconcing; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3707 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3708 Lisp_Object *args0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3709 struct gcpro gcpro1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3710 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3711 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3712 for (i = 1; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3713 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3714 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3715 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3716 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3717 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3718 args0 = alloca_array (Lisp_Object, len + 1); |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3719 mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3720 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3721 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3722 if (len < 2) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3723 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3724 return len ? args0[1] : Qnil; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3725 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3726 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3727 /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3728 mapcarX is no longer doing this for us. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3729 args0[0] = Fcons (Qnil, Qnil); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3730 GCPRO1 (args0[0]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3731 gcpro1.nvars = len + 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3732 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3733 for (i = 0; i < len; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3734 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3735 nconcing = bytecode_nconc2 (args0 + i); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3736 args0[i + 1] = nconcing; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3737 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3738 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3739 RETURN_UNGCPRO (XCDR (nconcing)); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3740 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3741 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3742 DEFUN ("mapc", Fmapc, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3743 Call FUNCTION on each element of SEQUENCE. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3744 |
428 | 3745 SEQUENCE may be a list, a vector, a bit vector, or a string. |
3746 This function is like `mapcar' but does not accumulate the results, | |
3747 which is more efficient if you do not use the results. | |
3748 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3749 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3750 there are SEQUENCES, plus one for the elements from SEQUENCE. One element |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3751 from each sequence will be used each time FUNCTION is called, and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3752 `mapc' stops calling FUNCTION once the shortest sequence is exhausted. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3753 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3754 Return SEQUENCE. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3755 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3756 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3757 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3758 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3759 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3760 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3761 Lisp_Object sequence = args[1]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3762 struct gcpro gcpro1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3763 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3764 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3765 for (i = 1; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3766 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3767 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3768 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3769 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3770 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3771 /* We need to GCPRO sequence, because mapcarX will modify the |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3772 elements of the args array handed to it, and this may involve |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3773 elements of sequence getting garbage collected. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3774 GCPRO1 (sequence); |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3775 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3776 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3777 RETURN_UNGCPRO (sequence); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3778 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3779 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3780 DEFUN ("map", Fmap, 3, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3781 Map FUNCTION across one or more sequences, returning a sequence. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3782 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3783 TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3784 the first argument sequence, SEQUENCES are the other argument sequences. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3785 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3786 FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3787 capable of accepting this number of arguments. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3788 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3789 Certain TYPEs are recognised internally by `map', but others are not, and |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3790 `coerce' may throw an error on an attempt to convert to a TYPE it does not |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3791 understand. A null TYPE means do not accumulate any values. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3792 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3793 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES) |
428 | 3794 */ |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3795 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3796 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3797 Lisp_Object type = args[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3798 Lisp_Object function = args[1]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3799 Lisp_Object result = Qnil; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3800 Lisp_Object *args0 = NULL; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3801 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3802 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3803 struct gcpro gcpro1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3804 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3805 for (i = 2; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3806 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3807 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3808 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3809 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3810 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3811 if (!NILP (type)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3812 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3813 args0 = alloca_array (Lisp_Object, len); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3814 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3815 |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3816 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3817 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3818 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3819 if (EQ (type, Qnil)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3820 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3821 return result; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3822 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3823 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3824 if (EQ (type, Qvector) || EQ (type, Qarray)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3825 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3826 result = Fvector (len, args0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3827 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3828 else if (EQ (type, Qstring)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3829 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3830 result = Fstring (len, args0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3831 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3832 else if (EQ (type, Qlist)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3833 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3834 result = Flist (len, args0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3835 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3836 else if (EQ (type, Qbit_vector)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3837 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3838 result = Fbit_vector (len, args0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3839 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3840 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3841 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3842 result = Flist (len, args0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3843 GCPRO1 (result); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3844 result = call2 (Qcoerce, result, type); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3845 UNGCPRO; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3846 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3847 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3848 return result; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3849 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3850 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3851 DEFUN ("map-into", Fmap_into, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3852 Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3853 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3854 RESULT-SEQUENCE and SEQUENCES can be lists or arrays. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3855 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3856 FUNCTION must accept at least as many arguments as there are SEQUENCES |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3857 \(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3858 the same length, stop when the shortest is exhausted; any elements of |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3859 RESULT-SEQUENCE beyond that are unmodified. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3860 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3861 Return RESULT-SEQUENCE. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3862 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3863 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3864 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3865 (int nargs, Lisp_Object *args)) |
428 | 3866 { |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3867 Elemcount len = EMACS_INT_MAX; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3868 Lisp_Object result_sequence = args[0]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3869 Lisp_Object function = args[1]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3870 int i; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3871 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3872 args[0] = function; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3873 args[1] = result_sequence; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3874 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3875 for (i = 1; i < nargs; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3876 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3877 CHECK_SEQUENCE (args[i]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3878 len = min (len, XINT (Flength (args[i]))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3879 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3880 |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3881 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3882 SOME_OR_EVERY_NEITHER); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3883 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3884 return result_sequence; |
428 | 3885 } |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3886 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3887 DEFUN ("some", Fsome, 2, MANY, 0, /* |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3888 Return true if PREDICATE gives non-nil for an element of SEQUENCE. |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3889 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3890 If so, return the value (possibly multiple) given by PREDICATE. |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3891 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3892 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3893 there are SEQUENCES (plus one for the element from SEQUENCE). |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3894 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3895 arguments: (PREDICATE SEQUENCE &rest SEQUENCES) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3896 */ |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3897 (int nargs, Lisp_Object *args)) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3898 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3899 Lisp_Object result_box = Fcons (Qnil, Qnil); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3900 struct gcpro gcpro1; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3901 Elemcount len = EMACS_INT_MAX; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3902 int i; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3903 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3904 GCPRO1 (result_box); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3905 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3906 for (i = 1; i < nargs; ++i) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3907 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3908 CHECK_SEQUENCE (args[i]); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3909 len = min (len, XINT (Flength (args[i]))); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3910 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3911 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3912 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3913 SOME_OR_EVERY_SOME); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3914 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3915 RETURN_UNGCPRO (XCAR (result_box)); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3916 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3917 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3918 DEFUN ("every", Fevery, 2, MANY, 0, /* |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3919 Return true if PREDICATE is true of every element of SEQUENCE. |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3920 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3921 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3922 there are SEQUENCES (plus one for the element from SEQUENCE). |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3923 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3924 In contrast to `some', `every' never returns multiple values. |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3925 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3926 arguments: (PREDICATE SEQUENCE &rest SEQUENCES) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3927 */ |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3928 (int nargs, Lisp_Object *args)) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3929 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3930 Lisp_Object result_box = Fcons (Qt, Qnil); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3931 struct gcpro gcpro1; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3932 Elemcount len = EMACS_INT_MAX; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3933 int i; |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3934 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3935 GCPRO1 (result_box); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3936 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3937 for (i = 1; i < nargs; ++i) |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3938 { |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3939 CHECK_SEQUENCE (args[i]); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3940 len = min (len, XINT (Flength (args[i]))); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3941 } |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3942 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3943 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3944 SOME_OR_EVERY_EVERY); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3945 |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3946 RETURN_UNGCPRO (XCAR (result_box)); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3947 } |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3948 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3949 /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3950 corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3951 until that #'nthcdr expression gives nil for some element of LISTS. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3952 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3953 If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3954 values from FUNCTION; if NCONCP is non-zero, nconc them together. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3955 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3956 In contrast to mapcarX, we don't require our callers to check LISTS for |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3957 well-formedness, we signal wrong-type-argument if it's not a list, or |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3958 circular-list if it's circular. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3959 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3960 static Lisp_Object |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3961 maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp, |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3962 int nconcp) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3963 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3964 Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3965 Lisp_Object nconcing[2], accum = result, *args; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3966 struct gcpro gcpro1, gcpro2, gcpro3; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3967 int i, j, continuing = (nlists > 0), called_count = 0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3968 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3969 args = alloca_array (Lisp_Object, nlists + 1); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3970 args[0] = function; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3971 for (i = 1; i <= nlists; ++i) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3972 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3973 args[i] = Qnil; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3974 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3975 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3976 if (nconcp) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3977 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3978 nconcing[0] = result; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3979 nconcing[1] = Qnil; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3980 GCPRO3 (args[0], nconcing[0], result); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3981 gcpro1.nvars = 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3982 gcpro2.nvars = 2; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3983 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3984 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3985 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3986 GCPRO2 (args[0], result); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3987 gcpro1.nvars = 1; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3988 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3989 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3990 while (continuing) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3991 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3992 for (j = 0; j < nlists; ++j) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3993 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3994 if (CONSP (lists[j])) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3995 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3996 args[j + 1] = lists[j]; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3997 lists[j] = XCDR (lists[j]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3998 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3999 else if (NILP (lists[j])) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4000 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4001 continuing = 0; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4002 break; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4003 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4004 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4005 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4006 dead_wrong_type_argument (Qlistp, lists[j]); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4007 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4008 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4009 if (!continuing) break; |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4010 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4011 if (!maplp) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4012 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4013 if (nconcp) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4014 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4015 /* This order of calls means we check that each list is |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4016 well-formed once and once only. The last result does |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4017 not have to be a list. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4018 nconcing[1] = funcalled; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4019 nconcing[0] = bytecode_nconc2 (nconcing); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4020 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4021 else |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4022 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4023 /* Add to the end, avoiding the need to call nreverse |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4024 once we're done: */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4025 XSETCDR (accum, Fcons (funcalled, Qnil)); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4026 accum = XCDR (accum); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4027 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4028 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4029 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4030 if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue; |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4031 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4032 for (j = 0; j < nlists; ++j) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4033 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4034 EXTERNAL_LIST_LOOP_1 (lists[j]) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4035 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4036 /* Just check the lists aren't circular, using the |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4037 EXTERNAL_LIST_LOOP_1 macro. */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4038 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4039 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4040 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4041 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4042 if (!maplp) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4043 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4044 result = XCDR (result); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4045 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4046 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4047 RETURN_UNGCPRO (result); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4048 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4049 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4050 DEFUN ("maplist", Fmaplist, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4051 Call FUNCTION on each sublist of LIST and LISTS. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4052 Like `mapcar', except applies to lists and their cdr's rather than to |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4053 the elements themselves." |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4054 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4055 arguments: (FUNCTION LIST &rest LISTS) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4056 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4057 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4058 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4059 return maplist (args[0], nargs - 1, args + 1, 0, 0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4060 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4061 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4062 DEFUN ("mapl", Fmapl, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4063 Like `maplist', but do not accumulate values returned by the function. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4064 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4065 arguments: (FUNCTION LIST &rest LISTS) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4066 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4067 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4068 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4069 return maplist (args[0], nargs - 1, args + 1, 1, 0); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4070 } |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4071 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4072 DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /* |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4073 Like `maplist', but chains together the values returned by FUNCTION. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4074 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4075 FUNCTION must return a list (unless it happens to be the last |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4076 iteration); the results will be concatenated together using `nconc'. |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4077 |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4078 arguments: (FUNCTION LIST &rest LISTS) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4079 */ |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4080 (int nargs, Lisp_Object *args)) |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4081 { |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4082 return maplist (args[0], nargs - 1, args + 1, 0, 1); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4083 } |
428 | 4084 |
771 | 4085 /* Extra random functions */ |
442 | 4086 |
4087 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* | |
4088 Destructively replace the list OLD with NEW. | |
4089 This is like (copy-sequence NEW) except that it reuses the | |
4090 conses in OLD as much as possible. If OLD and NEW are the same | |
4091 length, no consing will take place. | |
4092 */ | |
3025 | 4093 (old, new_)) |
442 | 4094 { |
2367 | 4095 Lisp_Object oldtail = old, prevoldtail = Qnil; |
4096 | |
3025 | 4097 EXTERNAL_LIST_LOOP_2 (elt, new_) |
442 | 4098 { |
4099 if (!NILP (oldtail)) | |
4100 { | |
4101 CHECK_CONS (oldtail); | |
2367 | 4102 XCAR (oldtail) = elt; |
442 | 4103 } |
4104 else if (!NILP (prevoldtail)) | |
4105 { | |
2367 | 4106 XCDR (prevoldtail) = Fcons (elt, Qnil); |
442 | 4107 prevoldtail = XCDR (prevoldtail); |
4108 } | |
4109 else | |
2367 | 4110 old = oldtail = Fcons (elt, Qnil); |
442 | 4111 |
4112 if (!NILP (oldtail)) | |
4113 { | |
4114 prevoldtail = oldtail; | |
4115 oldtail = XCDR (oldtail); | |
4116 } | |
4117 } | |
4118 | |
4119 if (!NILP (prevoldtail)) | |
4120 XCDR (prevoldtail) = Qnil; | |
4121 else | |
4122 old = Qnil; | |
4123 | |
4124 return old; | |
4125 } | |
4126 | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4127 |
771 | 4128 Lisp_Object |
2367 | 4129 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) |
771 | 4130 { |
4131 return Fintern (concat2 (Fsymbol_name (symbol), | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4132 build_ascstring (ascii_string)), |
771 | 4133 Qnil); |
4134 } | |
4135 | |
4136 Lisp_Object | |
2367 | 4137 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol) |
771 | 4138 { |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4139 return Fintern (concat2 (build_ascstring (ascii_string), |
771 | 4140 Fsymbol_name (symbol)), |
4141 Qnil); | |
4142 } | |
4143 | |
442 | 4144 |
428 | 4145 /* #### this function doesn't belong in this file! */ |
4146 | |
442 | 4147 #ifdef HAVE_GETLOADAVG |
4148 #ifdef HAVE_SYS_LOADAVG_H | |
4149 #include <sys/loadavg.h> | |
4150 #endif | |
4151 #else | |
4152 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */ | |
4153 #endif | |
4154 | |
428 | 4155 DEFUN ("load-average", Fload_average, 0, 1, 0, /* |
4156 Return list of 1 minute, 5 minute and 15 minute load averages. | |
4157 Each of the three load averages is multiplied by 100, | |
4158 then converted to integer. | |
4159 | |
4160 When USE-FLOATS is non-nil, floats will be used instead of integers. | |
4161 These floats are not multiplied by 100. | |
4162 | |
4163 If the 5-minute or 15-minute load averages are not available, return a | |
4164 shortened list, containing only those averages which are available. | |
4165 | |
4166 On some systems, this won't work due to permissions on /dev/kmem, | |
4167 in which case you can't use this. | |
4168 */ | |
4169 (use_floats)) | |
4170 { | |
4171 double load_ave[3]; | |
4172 int loads = getloadavg (load_ave, countof (load_ave)); | |
4173 Lisp_Object ret = Qnil; | |
4174 | |
4175 if (loads == -2) | |
563 | 4176 signal_error (Qunimplemented, |
4177 "load-average not implemented for this operating system", | |
4178 Qunbound); | |
428 | 4179 else if (loads < 0) |
563 | 4180 invalid_operation ("Could not get load-average", lisp_strerror (errno)); |
428 | 4181 |
4182 while (loads-- > 0) | |
4183 { | |
4184 Lisp_Object load = (NILP (use_floats) ? | |
4185 make_int ((int) (100.0 * load_ave[loads])) | |
4186 : make_float (load_ave[loads])); | |
4187 ret = Fcons (load, ret); | |
4188 } | |
4189 return ret; | |
4190 } | |
4191 | |
4192 | |
4193 Lisp_Object Vfeatures; | |
4194 | |
4195 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* | |
4196 Return non-nil if feature FEXP is present in this Emacs. | |
4197 Use this to conditionalize execution of lisp code based on the | |
4198 presence or absence of emacs or environment extensions. | |
4199 FEXP can be a symbol, a number, or a list. | |
4200 If it is a symbol, that symbol is looked up in the `features' variable, | |
4201 and non-nil will be returned if found. | |
4202 If it is a number, the function will return non-nil if this Emacs | |
4203 has an equal or greater version number than FEXP. | |
4204 If it is a list whose car is the symbol `and', it will return | |
4205 non-nil if all the features in its cdr are non-nil. | |
4206 If it is a list whose car is the symbol `or', it will return non-nil | |
4207 if any of the features in its cdr are non-nil. | |
4208 If it is a list whose car is the symbol `not', it will return | |
4209 non-nil if the feature is not present. | |
4210 | |
4211 Examples: | |
4212 | |
4213 (featurep 'xemacs) | |
4214 => ; Non-nil on XEmacs. | |
4215 | |
4216 (featurep '(and xemacs gnus)) | |
4217 => ; Non-nil on XEmacs with Gnus loaded. | |
4218 | |
4219 (featurep '(or tty-frames (and emacs 19.30))) | |
4220 => ; Non-nil if this Emacs supports TTY frames. | |
4221 | |
4222 (featurep '(or (and xemacs 19.15) (and emacs 19.34))) | |
4223 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. | |
4224 | |
442 | 4225 (featurep '(and xemacs 21.02)) |
4226 => ; Non-nil on XEmacs 21.2 and later. | |
4227 | |
428 | 4228 NOTE: The advanced arguments of this function (anything other than a |
4229 symbol) are not yet supported by FSF Emacs. If you feel they are useful | |
4230 for supporting multiple Emacs variants, lobby Richard Stallman at | |
442 | 4231 <bug-gnu-emacs@gnu.org>. |
428 | 4232 */ |
4233 (fexp)) | |
4234 { | |
4235 #ifndef FEATUREP_SYNTAX | |
4236 CHECK_SYMBOL (fexp); | |
4237 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
4238 #else /* FEATUREP_SYNTAX */ | |
4239 static double featurep_emacs_version; | |
4240 | |
4241 /* Brute force translation from Erik Naggum's lisp function. */ | |
4242 if (SYMBOLP (fexp)) | |
4243 { | |
4244 /* Original definition */ | |
4245 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
4246 } | |
4247 else if (INTP (fexp) || FLOATP (fexp)) | |
4248 { | |
4249 double d = extract_float (fexp); | |
4250 | |
4251 if (featurep_emacs_version == 0.0) | |
4252 { | |
4253 featurep_emacs_version = XINT (Vemacs_major_version) + | |
4254 (XINT (Vemacs_minor_version) / 100.0); | |
4255 } | |
4256 return featurep_emacs_version >= d ? Qt : Qnil; | |
4257 } | |
4258 else if (CONSP (fexp)) | |
4259 { | |
4260 Lisp_Object tem = XCAR (fexp); | |
4261 if (EQ (tem, Qnot)) | |
4262 { | |
4263 Lisp_Object negate; | |
4264 | |
4265 tem = XCDR (fexp); | |
4266 negate = Fcar (tem); | |
4267 if (!NILP (tem)) | |
4268 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil; | |
4269 else | |
4270 return Fsignal (Qinvalid_read_syntax, list1 (tem)); | |
4271 } | |
4272 else if (EQ (tem, Qand)) | |
4273 { | |
4274 tem = XCDR (fexp); | |
4275 /* Use Fcar/Fcdr for error-checking. */ | |
4276 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem)))) | |
4277 { | |
4278 tem = Fcdr (tem); | |
4279 } | |
4280 return NILP (tem) ? Qt : Qnil; | |
4281 } | |
4282 else if (EQ (tem, Qor)) | |
4283 { | |
4284 tem = XCDR (fexp); | |
4285 /* Use Fcar/Fcdr for error-checking. */ | |
4286 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem)))) | |
4287 { | |
4288 tem = Fcdr (tem); | |
4289 } | |
4290 return NILP (tem) ? Qnil : Qt; | |
4291 } | |
4292 else | |
4293 { | |
4294 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp))); | |
4295 } | |
4296 } | |
4297 else | |
4298 { | |
4299 return Fsignal (Qinvalid_read_syntax, list1 (fexp)); | |
4300 } | |
4301 } | |
4302 #endif /* FEATUREP_SYNTAX */ | |
4303 | |
4304 DEFUN ("provide", Fprovide, 1, 1, 0, /* | |
4305 Announce that FEATURE is a feature of the current Emacs. | |
4306 This function updates the value of the variable `features'. | |
4307 */ | |
4308 (feature)) | |
4309 { | |
4310 Lisp_Object tem; | |
4311 CHECK_SYMBOL (feature); | |
4312 if (!NILP (Vautoload_queue)) | |
4313 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue); | |
4314 tem = Fmemq (feature, Vfeatures); | |
4315 if (NILP (tem)) | |
4316 Vfeatures = Fcons (feature, Vfeatures); | |
4317 LOADHIST_ATTACH (Fcons (Qprovide, feature)); | |
4318 return feature; | |
4319 } | |
4320 | |
1067 | 4321 DEFUN ("require", Frequire, 1, 3, 0, /* |
3842 | 4322 Ensure that FEATURE is present in the Lisp environment. |
4323 FEATURE is a symbol naming a collection of resources (functions, etc). | |
4324 Optional FILENAME is a library from which to load resources; it defaults to | |
4325 the print name of FEATURE. | |
4326 Optional NOERROR, if non-nil, causes require to return nil rather than signal | |
4327 `file-error' if loading the library fails. | |
4328 | |
4329 If feature FEATURE is present in `features', update `load-history' to reflect | |
4330 the require and return FEATURE. Otherwise, try to load it from a library. | |
4331 The normal messages at start and end of loading are suppressed. | |
4332 If the library is successfully loaded and it calls `(provide FEATURE)', add | |
4333 FEATURE to `features', update `load-history' and return FEATURE. | |
4334 If the load succeeds but FEATURE is not provided by the library, signal | |
4335 `invalid-state'. | |
4336 | |
4337 The byte-compiler treats top-level calls to `require' specially, by evaluating | |
4338 them at compile time (and then compiling them normally). Thus a library may | |
4339 request that definitions that should be inlined such as macros and defsubsts | |
4340 be loaded into its compilation environment. Achieving this in other contexts | |
4341 requires an explicit \(eval-and-compile ...\) block. | |
428 | 4342 */ |
1067 | 4343 (feature, filename, noerror)) |
428 | 4344 { |
4345 Lisp_Object tem; | |
4346 CHECK_SYMBOL (feature); | |
4347 tem = Fmemq (feature, Vfeatures); | |
4348 LOADHIST_ATTACH (Fcons (Qrequire, feature)); | |
4349 if (!NILP (tem)) | |
4350 return feature; | |
4351 else | |
4352 { | |
4353 int speccount = specpdl_depth (); | |
4354 | |
4355 /* Value saved here is to be restored into Vautoload_queue */ | |
4356 record_unwind_protect (un_autoload, Vautoload_queue); | |
4357 Vautoload_queue = Qt; | |
4358 | |
1067 | 4359 tem = call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename, |
1261 | 4360 noerror, Qrequire, Qnil); |
1067 | 4361 /* If load failed entirely, return nil. */ |
4362 if (NILP (tem)) | |
4363 return unbind_to_1 (speccount, Qnil); | |
428 | 4364 |
4365 tem = Fmemq (feature, Vfeatures); | |
4366 if (NILP (tem)) | |
563 | 4367 invalid_state ("Required feature was not provided", feature); |
428 | 4368 |
4369 /* Once loading finishes, don't undo it. */ | |
4370 Vautoload_queue = Qt; | |
771 | 4371 return unbind_to_1 (speccount, feature); |
428 | 4372 } |
4373 } | |
4374 | |
4375 /* base64 encode/decode functions. | |
4376 | |
4377 Originally based on code from GNU recode. Ported to FSF Emacs by | |
4378 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and | |
4379 subsequently heavily hacked by Hrvoje Niksic. */ | |
4380 | |
4381 #define MIME_LINE_LENGTH 72 | |
4382 | |
4383 #define IS_ASCII(Character) \ | |
4384 ((Character) < 128) | |
4385 #define IS_BASE64(Character) \ | |
4386 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) | |
4387 | |
4388 /* Table of characters coding the 64 values. */ | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4389 static Ascbyte base64_value_to_char[64] = |
428 | 4390 { |
4391 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ | |
4392 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ | |
4393 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ | |
4394 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ | |
4395 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */ | |
4396 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */ | |
4397 '8', '9', '+', '/' /* 60-63 */ | |
4398 }; | |
4399 | |
4400 /* Table of base64 values for first 128 characters. */ | |
4401 static short base64_char_to_value[128] = | |
4402 { | |
4403 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */ | |
4404 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */ | |
4405 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */ | |
4406 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */ | |
4407 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */ | |
4408 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */ | |
4409 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */ | |
4410 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */ | |
4411 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */ | |
4412 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */ | |
4413 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */ | |
4414 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */ | |
4415 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */ | |
4416 }; | |
4417 | |
4418 /* The following diagram shows the logical steps by which three octets | |
4419 get transformed into four base64 characters. | |
4420 | |
4421 .--------. .--------. .--------. | |
4422 |aaaaaabb| |bbbbcccc| |ccdddddd| | |
4423 `--------' `--------' `--------' | |
4424 6 2 4 4 2 6 | |
4425 .--------+--------+--------+--------. | |
4426 |00aaaaaa|00bbbbbb|00cccccc|00dddddd| | |
4427 `--------+--------+--------+--------' | |
4428 | |
4429 .--------+--------+--------+--------. | |
4430 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD| | |
4431 `--------+--------+--------+--------' | |
4432 | |
4433 The octets are divided into 6 bit chunks, which are then encoded into | |
4434 base64 characters. */ | |
4435 | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4436 static DECLARE_DOESNT_RETURN (base64_conversion_error (const Ascbyte *, |
2268 | 4437 Lisp_Object)); |
4438 | |
575 | 4439 static DOESNT_RETURN |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4440 base64_conversion_error (const Ascbyte *reason, Lisp_Object frob) |
563 | 4441 { |
4442 signal_error (Qbase64_conversion_error, reason, frob); | |
4443 } | |
4444 | |
4445 #define ADVANCE_INPUT(c, stream) \ | |
867 | 4446 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \ |
563 | 4447 ((ec > 255) ? \ |
4448 (base64_conversion_error ("Non-ascii character in base64 input", \ | |
4449 make_char (ec)), 0) \ | |
867 | 4450 : (c = (Ibyte)ec), 1)) |
665 | 4451 |
4452 static Bytebpos | |
867 | 4453 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break) |
428 | 4454 { |
4455 EMACS_INT counter = 0; | |
867 | 4456 Ibyte *e = to; |
4457 Ichar ec; | |
428 | 4458 unsigned int value; |
4459 | |
4460 while (1) | |
4461 { | |
1204 | 4462 Ibyte c = 0; |
428 | 4463 if (!ADVANCE_INPUT (c, istream)) |
4464 break; | |
4465 | |
4466 /* Wrap line every 76 characters. */ | |
4467 if (line_break) | |
4468 { | |
4469 if (counter < MIME_LINE_LENGTH / 4) | |
4470 counter++; | |
4471 else | |
4472 { | |
4473 *e++ = '\n'; | |
4474 counter = 1; | |
4475 } | |
4476 } | |
4477 | |
4478 /* Process first byte of a triplet. */ | |
4479 *e++ = base64_value_to_char[0x3f & c >> 2]; | |
4480 value = (0x03 & c) << 4; | |
4481 | |
4482 /* Process second byte of a triplet. */ | |
4483 if (!ADVANCE_INPUT (c, istream)) | |
4484 { | |
4485 *e++ = base64_value_to_char[value]; | |
4486 *e++ = '='; | |
4487 *e++ = '='; | |
4488 break; | |
4489 } | |
4490 | |
4491 *e++ = base64_value_to_char[value | (0x0f & c >> 4)]; | |
4492 value = (0x0f & c) << 2; | |
4493 | |
4494 /* Process third byte of a triplet. */ | |
4495 if (!ADVANCE_INPUT (c, istream)) | |
4496 { | |
4497 *e++ = base64_value_to_char[value]; | |
4498 *e++ = '='; | |
4499 break; | |
4500 } | |
4501 | |
4502 *e++ = base64_value_to_char[value | (0x03 & c >> 6)]; | |
4503 *e++ = base64_value_to_char[0x3f & c]; | |
4504 } | |
4505 | |
4506 return e - to; | |
4507 } | |
4508 #undef ADVANCE_INPUT | |
4509 | |
4510 /* Get next character from the stream, except that non-base64 | |
4511 characters are ignored. This is in accordance with rfc2045. EC | |
867 | 4512 should be an Ichar, so that it can hold -1 as the value for EOF. */ |
428 | 4513 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ |
867 | 4514 ec = Lstream_get_ichar (stream); \ |
428 | 4515 ++streampos; \ |
4516 /* IS_BASE64 may not be called with negative arguments so check for \ | |
4517 EOF first. */ \ | |
4518 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ | |
4519 break; \ | |
4520 } while (1) | |
4521 | |
4522 #define STORE_BYTE(pos, val, ccnt) do { \ | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4523 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \ |
428 | 4524 ++ccnt; \ |
4525 } while (0) | |
4526 | |
665 | 4527 static Bytebpos |
867 | 4528 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr) |
428 | 4529 { |
4530 Charcount ccnt = 0; | |
867 | 4531 Ibyte *e = to; |
428 | 4532 EMACS_INT streampos = 0; |
4533 | |
4534 while (1) | |
4535 { | |
867 | 4536 Ichar ec; |
428 | 4537 unsigned long value; |
4538 | |
4539 /* Process first byte of a quadruplet. */ | |
4540 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
4541 if (ec < 0) | |
4542 break; | |
4543 if (ec == '=') | |
563 | 4544 base64_conversion_error ("Illegal `=' character while decoding base64", |
4545 make_int (streampos)); | |
428 | 4546 value = base64_char_to_value[ec] << 18; |
4547 | |
4548 /* Process second byte of a quadruplet. */ | |
4549 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
4550 if (ec < 0) | |
563 | 4551 base64_conversion_error ("Premature EOF while decoding base64", |
4552 Qunbound); | |
428 | 4553 if (ec == '=') |
563 | 4554 base64_conversion_error ("Illegal `=' character while decoding base64", |
4555 make_int (streampos)); | |
428 | 4556 value |= base64_char_to_value[ec] << 12; |
4557 STORE_BYTE (e, value >> 16, ccnt); | |
4558 | |
4559 /* Process third byte of a quadruplet. */ | |
4560 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
4561 if (ec < 0) | |
563 | 4562 base64_conversion_error ("Premature EOF while decoding base64", |
4563 Qunbound); | |
428 | 4564 |
4565 if (ec == '=') | |
4566 { | |
4567 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
4568 if (ec < 0) | |
563 | 4569 base64_conversion_error ("Premature EOF while decoding base64", |
4570 Qunbound); | |
428 | 4571 if (ec != '=') |
563 | 4572 base64_conversion_error |
4573 ("Padding `=' expected but not found while decoding base64", | |
4574 make_int (streampos)); | |
428 | 4575 continue; |
4576 } | |
4577 | |
4578 value |= base64_char_to_value[ec] << 6; | |
4579 STORE_BYTE (e, 0xff & value >> 8, ccnt); | |
4580 | |
4581 /* Process fourth byte of a quadruplet. */ | |
4582 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
4583 if (ec < 0) | |
563 | 4584 base64_conversion_error ("Premature EOF while decoding base64", |
4585 Qunbound); | |
428 | 4586 if (ec == '=') |
4587 continue; | |
4588 | |
4589 value |= base64_char_to_value[ec]; | |
4590 STORE_BYTE (e, 0xff & value, ccnt); | |
4591 } | |
4592 | |
4593 *ccptr = ccnt; | |
4594 return e - to; | |
4595 } | |
4596 #undef ADVANCE_INPUT | |
4597 #undef ADVANCE_INPUT_IGNORE_NONBASE64 | |
4598 #undef STORE_BYTE | |
4599 | |
4600 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* | |
444 | 4601 Base64-encode the region between START and END. |
428 | 4602 Return the length of the encoded text. |
4603 Optional third argument NO-LINE-BREAK means do not break long lines | |
4604 into shorter lines. | |
4605 */ | |
444 | 4606 (start, end, no_line_break)) |
428 | 4607 { |
867 | 4608 Ibyte *encoded; |
665 | 4609 Bytebpos encoded_length; |
428 | 4610 Charcount allength, length; |
4611 struct buffer *buf = current_buffer; | |
665 | 4612 Charbpos begv, zv, old_pt = BUF_PT (buf); |
428 | 4613 Lisp_Object input; |
851 | 4614 int speccount = specpdl_depth (); |
428 | 4615 |
444 | 4616 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
428 | 4617 barf_if_buffer_read_only (buf, begv, zv); |
4618 | |
4619 /* We need to allocate enough room for encoding the text. | |
4620 We need 33 1/3% more space, plus a newline every 76 | |
4621 characters, and then we round up. */ | |
4622 length = zv - begv; | |
4623 allength = length + length/3 + 1; | |
4624 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
4625 | |
4626 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
867 | 4627 /* We needn't multiply allength with MAX_ICHAR_LEN because all the |
428 | 4628 base64 characters will be single-byte. */ |
867 | 4629 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
428 | 4630 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
4631 NILP (no_line_break)); | |
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4632 assert (encoded_length <= allength); |
428 | 4633 Lstream_delete (XLSTREAM (input)); |
4634 | |
4635 /* Now we have encoded the region, so we insert the new contents | |
4636 and delete the old. (Insert first in order to preserve markers.) */ | |
4637 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); | |
851 | 4638 unbind_to (speccount); |
428 | 4639 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); |
4640 | |
4641 /* Simulate FSF Emacs implementation of this function: if point was | |
4642 in the region, place it at the beginning. */ | |
4643 if (old_pt >= begv && old_pt < zv) | |
4644 BUF_SET_PT (buf, begv); | |
4645 | |
4646 /* We return the length of the encoded text. */ | |
4647 return make_int (encoded_length); | |
4648 } | |
4649 | |
4650 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* | |
4651 Base64 encode STRING and return the result. | |
444 | 4652 Optional argument NO-LINE-BREAK means do not break long lines |
4653 into shorter lines. | |
428 | 4654 */ |
4655 (string, no_line_break)) | |
4656 { | |
4657 Charcount allength, length; | |
665 | 4658 Bytebpos encoded_length; |
867 | 4659 Ibyte *encoded; |
428 | 4660 Lisp_Object input, result; |
4661 int speccount = specpdl_depth(); | |
4662 | |
4663 CHECK_STRING (string); | |
4664 | |
826 | 4665 length = string_char_length (string); |
428 | 4666 allength = length + length/3 + 1; |
4667 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
4668 | |
4669 input = make_lisp_string_input_stream (string, 0, -1); | |
867 | 4670 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
428 | 4671 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
4672 NILP (no_line_break)); | |
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4673 assert (encoded_length <= allength); |
428 | 4674 Lstream_delete (XLSTREAM (input)); |
4675 result = make_string (encoded, encoded_length); | |
851 | 4676 unbind_to (speccount); |
428 | 4677 return result; |
4678 } | |
4679 | |
4680 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* | |
444 | 4681 Base64-decode the region between START and END. |
428 | 4682 Return the length of the decoded text. |
4683 If the region can't be decoded, return nil and don't modify the buffer. | |
4684 Characters out of the base64 alphabet are ignored. | |
4685 */ | |
444 | 4686 (start, end)) |
428 | 4687 { |
4688 struct buffer *buf = current_buffer; | |
665 | 4689 Charbpos begv, zv, old_pt = BUF_PT (buf); |
867 | 4690 Ibyte *decoded; |
665 | 4691 Bytebpos decoded_length; |
428 | 4692 Charcount length, cc_decoded_length; |
4693 Lisp_Object input; | |
4694 int speccount = specpdl_depth(); | |
4695 | |
444 | 4696 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
428 | 4697 barf_if_buffer_read_only (buf, begv, zv); |
4698 | |
4699 length = zv - begv; | |
4700 | |
4701 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
4702 /* We need to allocate enough room for decoding the text. */ | |
867 | 4703 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
428 | 4704 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); |
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4705 assert (decoded_length <= length * MAX_ICHAR_LEN); |
428 | 4706 Lstream_delete (XLSTREAM (input)); |
4707 | |
4708 /* Now we have decoded the region, so we insert the new contents | |
4709 and delete the old. (Insert first in order to preserve markers.) */ | |
4710 BUF_SET_PT (buf, begv); | |
4711 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); | |
851 | 4712 unbind_to (speccount); |
428 | 4713 buffer_delete_range (buf, begv + cc_decoded_length, |
4714 zv + cc_decoded_length, 0); | |
4715 | |
4716 /* Simulate FSF Emacs implementation of this function: if point was | |
4717 in the region, place it at the beginning. */ | |
4718 if (old_pt >= begv && old_pt < zv) | |
4719 BUF_SET_PT (buf, begv); | |
4720 | |
4721 return make_int (cc_decoded_length); | |
4722 } | |
4723 | |
4724 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* | |
4725 Base64-decode STRING and return the result. | |
4726 Characters out of the base64 alphabet are ignored. | |
4727 */ | |
4728 (string)) | |
4729 { | |
867 | 4730 Ibyte *decoded; |
665 | 4731 Bytebpos decoded_length; |
428 | 4732 Charcount length, cc_decoded_length; |
4733 Lisp_Object input, result; | |
4734 int speccount = specpdl_depth(); | |
4735 | |
4736 CHECK_STRING (string); | |
4737 | |
826 | 4738 length = string_char_length (string); |
428 | 4739 /* We need to allocate enough room for decoding the text. */ |
867 | 4740 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
428 | 4741 |
4742 input = make_lisp_string_input_stream (string, 0, -1); | |
4743 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, | |
4744 &cc_decoded_length); | |
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4745 assert (decoded_length <= length * MAX_ICHAR_LEN); |
428 | 4746 Lstream_delete (XLSTREAM (input)); |
4747 | |
4748 result = make_string (decoded, decoded_length); | |
851 | 4749 unbind_to (speccount); |
428 | 4750 return result; |
4751 } | |
4752 | |
4753 Lisp_Object Qyes_or_no_p; | |
4754 | |
4755 void | |
4756 syms_of_fns (void) | |
4757 { | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4758 INIT_LISP_OBJECT (bit_vector); |
442 | 4759 |
563 | 4760 DEFSYMBOL (Qstring_lessp); |
4761 DEFSYMBOL (Qidentity); | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4762 DEFSYMBOL (Qvector); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4763 DEFSYMBOL (Qarray); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4764 DEFSYMBOL (Qstring); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4765 DEFSYMBOL (Qlist); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4766 DEFSYMBOL (Qbit_vector); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4767 |
563 | 4768 DEFSYMBOL (Qyes_or_no_p); |
4769 | |
4770 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); | |
428 | 4771 |
4772 DEFSUBR (Fidentity); | |
4773 DEFSUBR (Frandom); | |
4774 DEFSUBR (Flength); | |
4775 DEFSUBR (Fsafe_length); | |
4776 DEFSUBR (Fstring_equal); | |
801 | 4777 DEFSUBR (Fcompare_strings); |
428 | 4778 DEFSUBR (Fstring_lessp); |
4779 DEFSUBR (Fstring_modified_tick); | |
4780 DEFSUBR (Fappend); | |
4781 DEFSUBR (Fconcat); | |
4782 DEFSUBR (Fvconcat); | |
4783 DEFSUBR (Fbvconcat); | |
4784 DEFSUBR (Fcopy_list); | |
4785 DEFSUBR (Fcopy_sequence); | |
4786 DEFSUBR (Fcopy_alist); | |
4787 DEFSUBR (Fcopy_tree); | |
4788 DEFSUBR (Fsubseq); | |
4789 DEFSUBR (Fnthcdr); | |
4790 DEFSUBR (Fnth); | |
4791 DEFSUBR (Felt); | |
4792 DEFSUBR (Flast); | |
4793 DEFSUBR (Fbutlast); | |
4794 DEFSUBR (Fnbutlast); | |
4795 DEFSUBR (Fmember); | |
4796 DEFSUBR (Fold_member); | |
4797 DEFSUBR (Fmemq); | |
4798 DEFSUBR (Fold_memq); | |
4799 DEFSUBR (Fassoc); | |
4800 DEFSUBR (Fold_assoc); | |
4801 DEFSUBR (Fassq); | |
4802 DEFSUBR (Fold_assq); | |
4803 DEFSUBR (Frassoc); | |
4804 DEFSUBR (Fold_rassoc); | |
4805 DEFSUBR (Frassq); | |
4806 DEFSUBR (Fold_rassq); | |
4807 DEFSUBR (Fdelete); | |
4808 DEFSUBR (Fold_delete); | |
4809 DEFSUBR (Fdelq); | |
4810 DEFSUBR (Fold_delq); | |
4811 DEFSUBR (Fremassoc); | |
4812 DEFSUBR (Fremassq); | |
4813 DEFSUBR (Fremrassoc); | |
4814 DEFSUBR (Fremrassq); | |
4815 DEFSUBR (Fnreverse); | |
4816 DEFSUBR (Freverse); | |
4817 DEFSUBR (Fsort); | |
4818 DEFSUBR (Fplists_eq); | |
4819 DEFSUBR (Fplists_equal); | |
4820 DEFSUBR (Flax_plists_eq); | |
4821 DEFSUBR (Flax_plists_equal); | |
4822 DEFSUBR (Fplist_get); | |
4823 DEFSUBR (Fplist_put); | |
4824 DEFSUBR (Fplist_remprop); | |
4825 DEFSUBR (Fplist_member); | |
4826 DEFSUBR (Fcheck_valid_plist); | |
4827 DEFSUBR (Fvalid_plist_p); | |
4828 DEFSUBR (Fcanonicalize_plist); | |
4829 DEFSUBR (Flax_plist_get); | |
4830 DEFSUBR (Flax_plist_put); | |
4831 DEFSUBR (Flax_plist_remprop); | |
4832 DEFSUBR (Flax_plist_member); | |
4833 DEFSUBR (Fcanonicalize_lax_plist); | |
4834 DEFSUBR (Fdestructive_alist_to_plist); | |
4835 DEFSUBR (Fget); | |
4836 DEFSUBR (Fput); | |
4837 DEFSUBR (Fremprop); | |
4838 DEFSUBR (Fobject_plist); | |
4839 DEFSUBR (Fequal); | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4840 DEFSUBR (Fequalp); |
428 | 4841 DEFSUBR (Fold_equal); |
4842 DEFSUBR (Ffillarray); | |
4843 DEFSUBR (Fnconc); | |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4844 DEFSUBR (FmapcarX); |
428 | 4845 DEFSUBR (Fmapvector); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4846 DEFSUBR (Fmapcan); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4847 DEFSUBR (Fmapc); |
428 | 4848 DEFSUBR (Fmapconcat); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4849 DEFSUBR (Fmap); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4850 DEFSUBR (Fmap_into); |
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4851 DEFSUBR (Fsome); |
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4852 DEFSUBR (Fevery); |
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4853 Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc"))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4854 Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*"))); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4855 DEFSUBR (Fmaplist); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4856 DEFSUBR (Fmapl); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4857 DEFSUBR (Fmapcon); |
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4858 |
442 | 4859 DEFSUBR (Freplace_list); |
428 | 4860 DEFSUBR (Fload_average); |
4861 DEFSUBR (Ffeaturep); | |
4862 DEFSUBR (Frequire); | |
4863 DEFSUBR (Fprovide); | |
4864 DEFSUBR (Fbase64_encode_region); | |
4865 DEFSUBR (Fbase64_encode_string); | |
4866 DEFSUBR (Fbase64_decode_region); | |
4867 DEFSUBR (Fbase64_decode_string); | |
771 | 4868 |
4869 DEFSUBR (Fsplit_string_by_char); | |
4870 DEFSUBR (Fsplit_path); /* #### */ | |
4871 } | |
4872 | |
4873 void | |
4874 vars_of_fns (void) | |
4875 { | |
4876 DEFVAR_LISP ("path-separator", &Vpath_separator /* | |
4877 The directory separator in search paths, as a string. | |
4878 */ ); | |
4879 { | |
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4880 Ascbyte c = SEPCHAR; |
867 | 4881 Vpath_separator = make_string ((Ibyte *) &c, 1); |
771 | 4882 } |
428 | 4883 } |
4884 | |
4885 void | |
4886 init_provide_once (void) | |
4887 { | |
4888 DEFVAR_LISP ("features", &Vfeatures /* | |
4889 A list of symbols which are the features of the executing emacs. | |
4890 Used by `featurep' and `require', and altered by `provide'. | |
4891 */ ); | |
4892 Vfeatures = Qnil; | |
4893 | |
4894 Fprovide (intern ("base64")); | |
4895 } |