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