Make #'require's NOERROR arg do its job properly.
[sxemacs] / src / fns.c
1 /* Random utility Lisp functions.
2    Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3    Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of SXEmacs
6
7 SXEmacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 SXEmacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
19
20
21 /* Synched up with: Mule 2.0, FSF 19.30. */
22
23 /* This file has been Mule-ized. */
24
25 /* Note: FSF 19.30 has bool vectors.  We have bit vectors. */
26
27 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
28
29 #include <config.h>
30
31 /* Note on some machines this defines `vector' as a typedef,
32    so make sure we don't use that name in this file.  */
33 #undef vector
34 #define vector *****
35
36 #include "lisp.h"
37
38 #include "sysfile.h"
39
40 #include "buffer.h"
41 #include "bytecode.h"
42 #include "ui/device.h"
43 #include "events/events.h"
44 #include "extents.h"
45 #include "ui/frame.h"
46 #include "systime.h"
47 #include "ui/insdel.h"
48 #include "lstream.h"
49 #include "ent/ent.h"
50 /* for the categorial views */
51 #include "category.h"
52 #include "seq.h"
53 /* for all the map* funs */
54 #include "map.h"
55
56 \f
57 /* NOTE: This symbol is also used in lread.c */
58 #define FEATUREP_SYNTAX
59
60 Lisp_Object Qstring_lessp, Qstring_greaterp;
61 Lisp_Object Qidentity;
62
63 static int internal_old_equal(Lisp_Object, Lisp_Object, int);
64 Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth);
65 int internal_equalp(Lisp_Object, Lisp_Object, int);
66
67 static Lisp_Object mark_bit_vector(Lisp_Object obj)
68 {
69         return Qnil;
70 }
71
72 static void
73 print_bit_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
74 {
75         size_t i;
76         Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
77         size_t len = bit_vector_length(v);
78         size_t last = len;
79
80         if (INTP(Vprint_length))
81                 last = min((EMACS_INT) len, XINT(Vprint_length));
82         write_c_string("#*", printcharfun);
83         for (i = 0; i < last; i++) {
84                 if (bit_vector_bit(v, i))
85                         write_c_string("1", printcharfun);
86                 else
87                         write_c_string("0", printcharfun);
88         }
89
90         if (last != len)
91                 write_c_string("...", printcharfun);
92 }
93
94 static int bit_vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
95 {
96         Lisp_Bit_Vector *v1 = XBIT_VECTOR(obj1);
97         Lisp_Bit_Vector *v2 = XBIT_VECTOR(obj2);
98
99         return ((bit_vector_length(v1) == bit_vector_length(v2)) &&
100                 !memcmp(v1->bits, v2->bits,
101                         BIT_VECTOR_LONG_STORAGE(bit_vector_length(v1)) *
102                         sizeof(long)));
103 }
104
105 static unsigned long bit_vector_hash(Lisp_Object obj, int depth)
106 {
107         Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
108         return HASH2(bit_vector_length(v),
109                      memory_hash(v->bits,
110                                  BIT_VECTOR_LONG_STORAGE(bit_vector_length(v)) *
111                                  sizeof(long)));
112 }
113
114 static size_t size_bit_vector(const void *lheader)
115 {
116         const Lisp_Bit_Vector *v = (const Lisp_Bit_Vector *) lheader;
117         return FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
118                                             bits,
119                                             BIT_VECTOR_LONG_STORAGE
120                                             (bit_vector_length(v)));
121 }
122
123 static const struct lrecord_description bit_vector_description[] = {
124         {XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next)},
125         {XD_END}
126 };
127
128 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION("bit-vector", bit_vector,
129                                              mark_bit_vector, print_bit_vector,
130                                              0, bit_vector_equal,
131                                              bit_vector_hash,
132                                              bit_vector_description,
133                                              size_bit_vector, Lisp_Bit_Vector);
134 \f
135 DEFUN("identity", Fidentity, 1, 1, 0,   /*
136 Return the argument unchanged.
137 */
138       (arg))
139 {
140         return arg;
141 }
142
143 extern long get_random(void);
144 extern void seed_random(long arg);
145
146 DEFUN("random", Frandom, 0, 1, 0,       /*
147 Return a pseudo-random number.
148 All integers representable in Lisp are equally likely.
149 On most systems, this is 31 bits' worth.
150
151 With positive integer argument LIMIT, return random number
152 in interval [0,LIMIT). LIMIT can be a big integer, in which
153 case the range of possible values is extended.
154
155 With argument t, set the random number seed from the
156 current time and pid.
157 */
158       (limit))
159 {
160         EMACS_INT val;
161         unsigned long denominator;
162
163         if (EQ(limit, Qt))
164                 seed_random(getpid() + time(NULL));
165         if (NATNUMP(limit) && !ZEROP(limit)) {
166                 /* Try to take our random number from the higher bits of VAL,
167                    not the lower, since (says Gentzel) the low bits of `random'
168                    are less random than the higher ones.  We do this by using the
169                    quotient rather than the remainder.  At the high end of the RNG
170                    it's possible to get a quotient larger than limit; discarding
171                    these values eliminates the bias that would otherwise appear
172                    when using a large limit.  */
173                 denominator = ((unsigned long)1 << INT_VALBITS) / XINT(limit);
174                 do
175                         val = get_random() / denominator;
176                 while (val >= XINT(limit));
177         } else if (ZEROP(limit)) {
178                 return wrong_type_argument(Qpositivep, limit);
179 #if defined HAVE_MPZ && defined WITH_GMP
180         } else if (BIGZP(limit)) {
181                 bigz bz;
182                 Lisp_Object result;
183
184                 if (bigz_sign(XBIGZ_DATA(limit)) <= 0)
185                         return wrong_type_argument(Qpositivep, limit);
186
187                 bigz_init(bz);
188
189                 bigz_random(bz, XBIGZ_DATA(limit));
190                 result = ent_mpz_downgrade_maybe(bz);
191
192                 bigz_fini(bz);
193                 return result;
194 #endif  /* HAVE_MPZ */
195         } else
196                 val = get_random();
197
198         return make_int(val);
199 }
200
201 #if defined(WITH_GMP) && defined(HAVE_MPZ)
202 DEFUN("randomb", Frandomb, 1, 1, 0,     /*
203 Return a uniform pseudo-random number in the range [0, 2^LIMIT).
204 */
205       (limit))
206 {
207         bigz bz;
208         unsigned long limui;
209         Lisp_Object result;
210
211         CHECK_INTEGER(limit);
212
213         if (NILP(Fnonnegativep(limit)))
214                 return wrong_type_argument(Qnonnegativep, limit);
215         else if (INTP(limit))
216                 limui = XINT(limit);
217         else if (BIGZP(limit) && bigz_fits_ulong_p(XBIGZ_DATA(limit)))
218                 limui = bigz_to_ulong(XBIGZ_DATA(limit));
219         else
220                 return wrong_type_argument(Qintegerp, limit);
221
222         bigz_init(bz);
223
224         mpz_urandomb(bz, random_state, limui);
225         result = make_bigz_bz(bz);
226
227         bigz_fini(bz);
228         return result;
229 }
230 #endif  /* HAVE_MPZ */
231
232 \f
233 /* Random data-structure functions */
234
235 #ifdef LOSING_BYTECODE
236
237 /* #### Delete this shit */
238
239 /* Charcount is a misnomer here as we might be dealing with the
240    length of a vector or list, but emphasizes that we're not dealing
241    with Bytecounts in strings */
242 static Charcount length_with_bytecode_hack(Lisp_Object seq)
243 {
244         if (!COMPILED_FUNCTIONP(seq))
245                 return XINT(Flength(seq));
246         else {
247                 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(seq);
248
249                 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
250                         f->flags.domainp ? COMPILED_DOMAIN :
251                         COMPILED_DOC_STRING)
252                     + 1;
253         }
254 }
255
256 #endif                          /* LOSING_BYTECODE */
257
258 void check_losing_bytecode(const char *function, Lisp_Object seq)
259 {
260         if (COMPILED_FUNCTIONP(seq))
261                 error_with_frob
262                     (seq,
263                      "As of 20.3, `%s' no longer works with compiled-function objects",
264                      function);
265 }
266
267 DEFUN("length", Flength, 1, 1, 0,       /*
268 Return the length of vector, bit vector, list or string SEQUENCE.
269 */
270       (sequence))
271 {
272 #if 1
273 /* that's whither we have to get */
274         if (LIKELY(!NILP(sequence))) {
275                 return make_int(seq_length((seq_t)sequence));
276         } else {
277                 return Qzero;
278         }
279 #elif 0
280 retry:
281         if (LIKELY(STRINGP(sequence) ||
282                    CONSP(sequence) ||
283                    VECTORP(sequence) ||
284                    DLLISTP(sequence) ||
285                    BIT_VECTORP(sequence))) {
286                 return make_int(seq_length(sequence));
287         } else if (NILP(sequence)) {
288                 return Qzero;
289         } else {
290                 check_losing_bytecode("length", sequence);
291                 sequence = wrong_type_argument(Qsequencep, sequence);
292                 goto retry;
293         }
294 #else
295 retry:
296         if (STRINGP(sequence))
297                 return make_int(XSTRING_CHAR_LENGTH(sequence));
298         else if (CONSP(sequence)) {
299                 return make_int(seq_length(sequence));
300         } else if (VECTORP(sequence))
301                 return make_int(seq_length(sequence));
302         else if (DLLISTP(sequence))
303                 return make_int(XDLLIST_SIZE(sequence));
304         else if (NILP(sequence))
305                 return Qzero;
306         else if (BIT_VECTORP(sequence))
307                 return make_int(bit_vector_length(XBIT_VECTOR(sequence)));
308         else {
309                 check_losing_bytecode("length", sequence);
310                 sequence = wrong_type_argument(Qsequencep, sequence);
311                 goto retry;
312         }
313 #endif
314 }
315
316 DEFUN("safe-length", Fsafe_length, 1, 1, 0,     /*
317 Return the length of a list, but avoid error or infinite loop.
318 This function never gets an error.  If LIST is not really a list,
319 it returns 0.  If LIST is circular, it returns a finite value
320 which is at least the number of distinct elements.
321 */
322       (list))
323 {
324         Lisp_Object hare, tortoise;
325         size_t len;
326
327         for (hare = tortoise = list, len = 0;
328              CONSP(hare) && (!EQ(hare, tortoise) || len == 0);
329              hare = XCDR(hare), len++) {
330                 if (len & 1)
331                         tortoise = XCDR(tortoise);
332         }
333
334         return make_int(len);
335 }
336
337 /*** string functions. ***/
338
339 DEFUN("string-equal", Fstring_equal, 2, 2, 0,   /*
340 Return t if two strings have identical contents.
341 Case is significant.  Text properties are ignored.
342 \(Under SXEmacs, `equal' also ignores text properties and extents in
343 strings, but this is not the case under FSF Emacs 19.  In FSF Emacs 20
344 `equal' is the same as in SXEmacs, in that respect.)
345 Symbols are also allowed; their print names are used instead.
346 */
347       (string1, string2))
348 {
349         Bytecount len;
350         Lisp_String *p1, *p2;
351
352         if (SYMBOLP(string1))
353                 p1 = XSYMBOL(string1)->name;
354         else {
355                 CHECK_STRING(string1);
356                 p1 = XSTRING(string1);
357         }
358
359         if (SYMBOLP(string2))
360                 p2 = XSYMBOL(string2)->name;
361         else {
362                 CHECK_STRING(string2);
363                 p2 = XSTRING(string2);
364         }
365
366         return (((len = string_length(p1)) == string_length(p2)) &&
367                 !memcmp(string_data(p1), string_data(p2), len)) ? Qt : Qnil;
368 }
369
370 DEFUN("string-lessp", Fstring_lessp, 2, 2, 0,   /*
371 Return t if first arg string is less than second in lexicographic order.
372 If I18N2 support (but not Mule support) was compiled in, ordering is
373 determined by the locale. (Case is significant for the default C locale.)
374 In all other cases, comparison is simply done on a character-by-
375 character basis using the numeric value of a character. (Note that
376 this may not produce particularly meaningful results under Mule if
377 characters from different charsets are being compared.)
378
379 Symbols are also allowed; their print names are used instead.
380
381 The reason that the I18N2 locale-specific collation is not used under
382 Mule is that the locale model of internationalization does not handle
383 multiple charsets and thus has no hope of working properly under Mule.
384 What we really should do is create a collation table over all built-in
385 charsets.  This is extremely difficult to do from scratch, however.
386
387 Unicode is a good first step towards solving this problem.  In fact,
388 it is quite likely that a collation table exists (or will exist) for
389 Unicode.  When Unicode support is added to SXEmacs/Mule, this problem
390 may be solved.
391 */
392       (string1, string2))
393 {
394         Lisp_String *p1, *p2;
395         Charcount end, len2;
396         int i;
397
398         if (SYMBOLP(string1))
399                 p1 = XSYMBOL(string1)->name;
400         else {
401                 CHECK_STRING(string1);
402                 p1 = XSTRING(string1);
403         }
404
405         if (SYMBOLP(string2))
406                 p2 = XSYMBOL(string2)->name;
407         else {
408                 CHECK_STRING(string2);
409                 p2 = XSTRING(string2);
410         }
411
412         end = string_char_length(p1);
413         len2 = string_char_length(p2);
414         if (end > len2)
415                 end = len2;
416
417 #if defined (I18N2) && !defined (MULE)
418         /* There is no hope of this working under Mule.  Even if we converted
419            the data into an external format so that strcoll() processed it
420            properly, it would still not work because strcoll() does not
421            handle multiple locales.  This is the fundamental flaw in the
422            locale model. */
423         {
424                 Bytecount bcend = charcount_to_bytecount(string_data(p1), end);
425                 /* Compare strings using collation order of locale. */
426                 /* Need to be tricky to handle embedded nulls. */
427
428                 for (i = 0; i < bcend;
429                      i += strlen((char *)string_data(p1) + i) + 1) {
430                         int val = strcoll((char *)string_data(p1) + i,
431                                           (char *)string_data(p2) + i);
432                         if (val < 0)
433                                 return Qt;
434                         if (val > 0)
435                                 return Qnil;
436                 }
437         }
438 #else                           /* not I18N2, or MULE */
439         {
440                 Bufbyte *ptr1 = string_data(p1);
441                 Bufbyte *ptr2 = string_data(p2);
442
443                 /* #### It is not really necessary to do this: We could compare
444                    byte-by-byte and still get a reasonable comparison, since this
445                    would compare characters with a charset in the same way.  With
446                    a little rearrangement of the leading bytes, we could make most
447                    inter-charset comparisons work out the same, too; even if some
448                    don't, this is not a big deal because inter-charset comparisons
449                    aren't really well-defined anyway. */
450                 for (i = 0; i < end; i++) {
451                         if (charptr_emchar(ptr1) != charptr_emchar(ptr2))
452                                 return charptr_emchar(ptr1) <
453                                     charptr_emchar(ptr2) ? Qt : Qnil;
454                         INC_CHARPTR(ptr1);
455                         INC_CHARPTR(ptr2);
456                 }
457         }
458 #endif                          /* not I18N2, or MULE */
459         /* Can't do i < len2 because then comparison between "foo" and "foo^@"
460            won't work right in I18N2 case */
461         return end < len2 ? Qt : Qnil;
462 }
463
464 DEFUN("string-greaterp", Fstring_greaterp, 2, 2, 0, /*
465 Return t if first arg string is greater than second in lexicographic order.
466 If I18N2 support (but not Mule support) was compiled in, ordering is
467 determined by the locale. (Case is significant for the default C locale.)
468 In all other cases, comparison is simply done on a character-by-
469 character basis using the numeric value of a character. (Note that
470 this may not produce particularly meaningful results under Mule if
471 characters from different charsets are being compared.)
472
473 Symbols are also allowed; their print names are used instead.
474
475 The reason that the I18N2 locale-specific collation is not used under
476 Mule is that the locale model of internationalization does not handle
477 multiple charsets and thus has no hope of working properly under Mule.
478 What we really should do is create a collation table over all built-in
479 charsets.  This is extremely difficult to do from scratch, however.
480
481 Unicode is a good first step towards solving this problem.  In fact,
482 it is quite likely that a collation table exists (or will exist) for
483 Unicode.  When Unicode support is added to SXEmacs/Mule, this problem
484 may be solved.
485 */
486       (string1, string2))
487 {
488         return Fstring_lessp(string2, string1);
489 }
490
491 DEFUN("string-modified-tick", Fstring_modified_tick, 1, 1, 0,   /*
492 Return STRING's tick counter, incremented for each change to the string.
493 Each string has a tick counter which is incremented each time the contents
494 of the string are changed (e.g. with `aset').  It wraps around occasionally.
495 */
496       (string))
497 {
498         Lisp_String *s;
499
500         CHECK_STRING(string);
501         s = XSTRING(string);
502         if (CONSP(s->plist) && INTP(XCAR(s->plist)))
503                 return XCAR(s->plist);
504         else
505                 return Qzero;
506 }
507
508 void bump_string_modiff(Lisp_Object str)
509 {
510         Lisp_String *s = XSTRING(str);
511         Lisp_Object *ptr = &s->plist;
512
513 #ifdef I18N3
514         /* #### remove the `string-translatable' property from the string,
515            if there is one. */
516 #endif
517         /* skip over extent info if it's there */
518         if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
519                 ptr = &XCDR(*ptr);
520         if (CONSP(*ptr) && INTP(XCAR(*ptr)))
521                 XSETINT(XCAR(*ptr), 1 + XINT(XCAR(*ptr)));
522         else
523                 *ptr = Fcons(make_int(1), *ptr);
524 }
525 \f
526 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector, c_dllist };
527 static Lisp_Object concat(int nargs, Lisp_Object * args,
528                           enum concat_target_type target_type,
529                           int last_special);
530
531 Lisp_Object concat2(Lisp_Object string1, Lisp_Object string2)
532 {
533         Lisp_Object args[2];
534         args[0] = string1;
535         args[1] = string2;
536         return concat(2, args, c_string, 0);
537 }
538
539 Lisp_Object
540 concat3(Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
541 {
542         Lisp_Object args[3];
543         args[0] = string1;
544         args[1] = string2;
545         args[2] = string3;
546         return concat(3, args, c_string, 0);
547 }
548
549 Lisp_Object vconcat2(Lisp_Object vec1, Lisp_Object vec2)
550 {
551         Lisp_Object args[2];
552         args[0] = vec1;
553         args[1] = vec2;
554         return concat(2, args, c_vector, 0);
555 }
556
557 Lisp_Object vconcat3(Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
558 {
559         Lisp_Object args[3];
560         args[0] = vec1;
561         args[1] = vec2;
562         args[2] = vec3;
563         return concat(3, args, c_vector, 0);
564 }
565
566 DEFUN("append", Fappend, 0, MANY, 0,    /*
567 Concatenate all the arguments and make the result a list.
568 The result is a list whose elements are the elements of all the arguments.
569 Each argument may be a list, vector, bit vector, or string.
570 The last argument is not copied, just used as the tail of the new list.
571 Also see: `nconc'.
572 */
573       (int nargs, Lisp_Object * args))
574 {
575         return concat(nargs, args, c_cons, 1);
576 }
577
578 DEFUN("concat", Fconcat, 0, MANY, 0,    /*
579 Concatenate all the arguments and make the result a string.
580 The result is a string whose elements are the elements of all the arguments.
581 Each argument may be a string or a list or vector of characters.
582
583 As of XEmacs 21.0, this function does NOT accept individual integers
584 as arguments.  Old code that relies on, for example, (concat "foo" 50)
585 returning "foo50" will fail.  To fix such code, either apply
586 `int-to-string' to the integer argument, or use `format'.
587 */
588       (int nargs, Lisp_Object * args))
589 {
590         return concat(nargs, args, c_string, 0);
591 }
592
593 DEFUN("vconcat", Fvconcat, 0, MANY, 0,  /*
594 Concatenate all the arguments and make the result a vector.
595 The result is a vector whose elements are the elements of all the arguments.
596 Each argument may be a list, vector, bit vector, or string.
597 */
598       (int nargs, Lisp_Object * args))
599 {
600         return concat(nargs, args, c_vector, 0);
601 }
602
603 DEFUN("bvconcat", Fbvconcat, 0, MANY, 0,        /*
604 Concatenate all the arguments and make the result a bit vector.
605 The result is a bit vector whose elements are the elements of all the
606 arguments.  Each argument may be a list, vector, bit vector, or string.
607 */
608       (int nargs, Lisp_Object * args))
609 {
610         return concat(nargs, args, c_bit_vector, 0);
611 }
612
613 /* Copy a (possibly dotted) list.  LIST must be a cons.
614    Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
615 static Lisp_Object copy_list(Lisp_Object list)
616 {
617         Lisp_Object list_copy = Fcons(XCAR(list), XCDR(list));
618         Lisp_Object last = list_copy;
619         Lisp_Object hare, tortoise;
620         size_t len;
621
622         for (tortoise = hare = XCDR(list), len = 1;
623              CONSP(hare); hare = XCDR(hare), len++) {
624                 XCDR(last) = Fcons(XCAR(hare), XCDR(hare));
625                 last = XCDR(last);
626
627                 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
628                         continue;
629                 if (len & 1)
630                         tortoise = XCDR(tortoise);
631                 if (EQ(tortoise, hare))
632                         signal_circular_list_error(list);
633         }
634
635         return list_copy;
636 }
637
638 DEFUN("copy-list", Fcopy_list, 1, 1, 0, /*
639 Return a copy of list LIST, which may be a dotted list.
640 The elements of LIST are not copied; they are shared
641 with the original.
642 */
643       (list))
644 {
645       again:
646         if (NILP(list))
647                 return list;
648         if (CONSP(list))
649                 return copy_list(list);
650
651         list = wrong_type_argument(Qlistp, list);
652         goto again;
653 }
654
655 DEFUN("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
656 Return a copy of list, dllist, vector, bit vector or string SEQUENCE.
657 The elements of a list or vector are not copied; they are shared
658 with the original. SEQUENCE may be a dotted list.
659 */
660       (sequence))
661 {
662       again:
663         if (NILP(sequence))
664                 return sequence;
665         if (CONSP(sequence))
666                 return copy_list(sequence);
667         if (DLLISTP(sequence))
668                 return Fcopy_dllist(sequence);
669         if (STRINGP(sequence))
670                 return concat(1, &sequence, c_string, 0);
671         if (VECTORP(sequence))
672                 return concat(1, &sequence, c_vector, 0);
673         if (BIT_VECTORP(sequence))
674                 return concat(1, &sequence, c_bit_vector, 0);
675
676         check_losing_bytecode("copy-sequence", sequence);
677         sequence = wrong_type_argument(Qsequencep, sequence);
678         goto again;
679 }
680
681 struct merge_string_extents_struct {
682         Lisp_Object string;
683         Bytecount entry_offset;
684         Bytecount entry_length;
685 };
686
687 static Lisp_Object
688 concat(int nargs, Lisp_Object * args,
689        enum concat_target_type target_type, int last_special)
690 {
691         Lisp_Object val;
692         Lisp_Object tail = Qnil;
693         int toindex;
694         int argnum;
695         Lisp_Object last_tail;
696         Lisp_Object prev;
697         struct merge_string_extents_struct *args_mse = 0;
698         Bufbyte *string_result = NULL;
699         Bufbyte *string_result_ptr = NULL;
700         struct gcpro gcpro1;
701         int speccount = specpdl_depth();
702         Charcount total_length;
703
704
705         /* The modus operandi in Emacs is "caller gc-protects args".
706            However, concat is called many times in Emacs on freshly
707            created stuff.  So we help those callers out by protecting
708            the args ourselves to save them a lot of temporary-variable
709            grief. */
710
711         GCPROn(args, nargs);
712
713 #ifdef I18N3
714         /* #### if the result is a string and any of the strings have a string
715            for the `string-translatable' property, then concat should also
716            concat the args but use the `string-translatable' strings, and store
717            the result in the returned string's `string-translatable' property. */
718 #endif
719         if (target_type == c_string)
720                 XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
721
722         /* In append, the last arg isn't treated like the others */
723         if (last_special && nargs > 0) {
724                 nargs--;
725                 last_tail = args[nargs];
726         } else
727                 last_tail = Qnil;
728
729         /* Check and coerce the arguments. */
730         for (argnum = 0; argnum < nargs; argnum++) {
731                 Lisp_Object seq = args[argnum];
732                 if (LISTP(seq) || DLLISTP(seq)) ;
733                 else if (VECTORP(seq) || STRINGP(seq) || BIT_VECTORP(seq)) ;
734 #ifdef LOSING_BYTECODE
735                 else if (COMPILED_FUNCTIONP(seq))
736                         /* Urk!  We allow this, for "compatibility"... */
737                         ;
738 #endif
739 #if 0                           /* removed for XEmacs 21 */
740                 else if (INTP(seq))
741                         /* This is too revolting to think about but maintains
742                            compatibility with FSF (and lots and lots of old code). */
743                         args[argnum] = Fnumber_to_string(seq);
744 #endif
745                 else {
746                         check_losing_bytecode("concat", seq);
747                         args[argnum] = wrong_type_argument(Qsequencep, seq);
748                 }
749
750                 if (args_mse) {
751                         if (STRINGP(seq))
752                                 args_mse[argnum].string = seq;
753                         else
754                                 args_mse[argnum].string = Qnil;
755                 }
756         }
757
758         {
759                 /* Charcount is a misnomer here as we might be dealing with the
760                    length of a vector or list, but emphasizes that we're not dealing
761                    with Bytecounts in strings */
762                 /* Charcount total_length; */
763
764                 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) {
765 #ifdef LOSING_BYTECODE
766                         Charcount thislen =
767                             length_with_bytecode_hack(args[argnum]);
768 #else
769                         Charcount thislen = XINT(Flength(args[argnum]));
770 #endif
771                         total_length += thislen;
772                 }
773
774                 switch (target_type) {
775                 case c_cons:
776                         if (total_length == 0) {
777                                 /* In append, if all but last arg are nil,
778                                    return last arg */
779                                 XMALLOC_UNBIND(args_mse, nargs, speccount);
780                                 RETURN_UNGCPRO(last_tail);
781                         }
782                         val = Fmake_list(make_int(total_length), Qnil);
783                         break;
784                 case c_dllist:
785                         if (total_length == 0) {
786                                 /* In append, if all but last arg are nil,
787                                    return last arg */
788                                 XMALLOC_UNBIND(args_mse, nargs, speccount);
789                                 RETURN_UNGCPRO(last_tail);
790                         }
791                         val = Fmake_list(make_int(total_length), Qnil);
792                         break;
793                 case c_vector:
794                         val = make_vector(total_length, Qnil);
795                         break;
796                 case c_bit_vector:
797                         val = make_bit_vector(total_length, Qzero);
798                         break;
799                 case c_string:
800                         /* We don't make the string yet because we don't know
801                            the actual number of bytes.  This loop was formerly
802                            written to call Fmake_string() here and then call
803                            set_string_char() for each char.  This seems logical
804                            enough but is waaaaaaaay slow -- set_string_char()
805                            has to scan the whole string up to the place where
806                            the substitution is called for in order to find the
807                            place to change, and may have to do some realloc()ing
808                            in order to make the char fit properly.  O(N^2)
809                            yuckage. */
810                         val = Qnil;
811                         XMALLOC_ATOMIC_OR_ALLOCA( string_result,
812                                                   total_length * MAX_EMCHAR_LEN,
813                                                   Bufbyte );
814                         string_result_ptr = string_result;
815                         break;
816                 default:
817                         val = Qnil;
818                         abort();
819                 }
820         }
821
822         if (CONSP(val))
823                 tail = val, toindex = -1;       /* -1 in toindex is flag we are
824                                                    making a list */
825         else
826                 toindex = 0;
827
828         prev = Qnil;
829
830         for (argnum = 0; argnum < nargs; argnum++) {
831                 Charcount thisleni = 0;
832                 Charcount thisindex = 0;
833                 Lisp_Object seq = args[argnum];
834                 Bufbyte *string_source_ptr = 0;
835                 Bufbyte *string_prev_result_ptr = string_result_ptr;
836
837                 if (!CONSP(seq)) {
838 #ifdef LOSING_BYTECODE
839                         thisleni = length_with_bytecode_hack(seq);
840 #else
841                         thisleni = XINT(Flength(seq));
842 #endif
843                 }
844                 if (STRINGP(seq))
845                         string_source_ptr = XSTRING_DATA(seq);
846
847                 while (1) {
848                         Lisp_Object elt;
849
850                         /* We've come to the end of this arg, so exit. */
851                         if (NILP(seq))
852                                 break;
853
854                         /* Fetch next element of `seq' arg into `elt' */
855                         if (CONSP(seq)) {
856                                 elt = XCAR(seq);
857                                 seq = XCDR(seq);
858                         } else {
859                                 if (thisindex >= thisleni)
860                                         break;
861
862                                 if (STRINGP(seq)) {
863                                         elt =
864                                             make_char(charptr_emchar
865                                                       (string_source_ptr));
866                                         INC_CHARPTR(string_source_ptr);
867                                 } else if (VECTORP(seq))
868                                         elt = XVECTOR_DATA(seq)[thisindex];
869                                 else if (BIT_VECTORP(seq))
870                                         elt =
871                                             make_int(bit_vector_bit
872                                                      (XBIT_VECTOR(seq),
873                                                       thisindex));
874                                 else
875                                         elt = Felt(seq, make_int(thisindex));
876                                 thisindex++;
877                         }
878
879                         /* Store into result */
880                         if (toindex < 0) {
881                                 /* toindex negative means we are making a list */
882                                 XCAR(tail) = elt;
883                                 prev = tail;
884                                 tail = XCDR(tail);
885                         } else if (VECTORP(val))
886                                 XVECTOR_DATA(val)[toindex++] = elt;
887                         else if (BIT_VECTORP(val)) {
888                                 CHECK_BIT(elt);
889                                 set_bit_vector_bit(XBIT_VECTOR(val), toindex++,
890                                                    XINT(elt));
891                         } else {
892                                 CHECK_CHAR_COERCE_INT(elt);
893                                 if(string_result_ptr != NULL) {
894                                         string_result_ptr +=
895                                                 set_charptr_emchar(string_result_ptr,
896                                                                    XCHAR(elt));
897                                 } else {
898                                         abort();
899                                 }
900                         }
901                 }
902                 if (args_mse) {
903                         args_mse[argnum].entry_offset =
904                             string_prev_result_ptr - string_result;
905                         args_mse[argnum].entry_length =
906                             string_result_ptr - string_prev_result_ptr;
907                 }
908         }
909
910         /* Now we finally make the string. */
911         if (target_type == c_string) {
912                 val =
913                     make_string(string_result,
914                                 string_result_ptr - string_result);
915                 if (args_mse != NULL) {
916                         for (argnum = 0; argnum < nargs; argnum++) {
917                                 if (STRINGP(args_mse[argnum].string))
918                                         copy_string_extents(val,
919                                                             args_mse[argnum].string,
920                                                             args_mse[argnum].
921                                                             entry_offset, 0,
922                                                             args_mse[argnum].
923                                                             entry_length);
924                         }
925                         XMALLOC_UNBIND(string_result,
926                                        total_length * MAX_EMCHAR_LEN, speccount);
927                         XMALLOC_UNBIND(args_mse, nargs, speccount);
928                 } else {
929                         abort();
930                 }
931         }
932
933         if (!NILP(prev))
934                 XCDR(prev) = last_tail;
935
936         RETURN_UNGCPRO(val);
937 }
938 \f
939 DEFUN("copy-alist", Fcopy_alist, 1, 1, 0,       /*
940 Return a copy of ALIST.
941 This is an alist which represents the same mapping from objects to objects,
942 but does not share the alist structure with ALIST.
943 The objects mapped (cars and cdrs of elements of the alist)
944 are shared, however.
945 Elements of ALIST that are not conses are also shared.
946 */
947       (alist))
948 {
949         Lisp_Object tail;
950
951         if (NILP(alist))
952                 return alist;
953         CHECK_CONS(alist);
954
955         alist = concat(1, &alist, c_cons, 0);
956         for (tail = alist; CONSP(tail); tail = XCDR(tail)) {
957                 Lisp_Object car = XCAR(tail);
958
959                 if (CONSP(car))
960                         XCAR(tail) = Fcons(XCAR(car), XCDR(car));
961         }
962         return alist;
963 }
964
965 DEFUN("copy-tree", Fcopy_tree, 1, 2, 0, /*
966 Return a copy of a list and substructures.
967 The argument is copied, and any lists contained within it are copied
968 recursively.  Circularities and shared substructures are not preserved.
969 Second arg VECP causes vectors to be copied, too.  Strings and bit vectors
970 are not copied.
971 */
972       (arg, vecp))
973 {
974         return safe_copy_tree(arg, vecp, 0);
975 }
976
977 Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth)
978 {
979         if (depth > 200)
980                 signal_simple_error("Stack overflow in copy-tree", arg);
981
982         if (CONSP(arg)) {
983                 Lisp_Object rest;
984                 rest = arg = Fcopy_sequence(arg);
985                 while (CONSP(rest)) {
986                         Lisp_Object elt = XCAR(rest);
987                         QUIT;
988                         if (CONSP(elt) || VECTORP(elt))
989                                 XCAR(rest) =
990                                     safe_copy_tree(elt, vecp, depth + 1);
991                         if (VECTORP(XCDR(rest)))        /* hack for (a b . [c d]) */
992                                 XCDR(rest) =
993                                     safe_copy_tree(XCDR(rest), vecp, depth + 1);
994                         rest = XCDR(rest);
995                 }
996         } else if (VECTORP(arg) && !NILP(vecp)) {
997                 int i = XVECTOR_LENGTH(arg);
998                 int j;
999                 arg = Fcopy_sequence(arg);
1000                 for (j = 0; j < i; j++) {
1001                         Lisp_Object elt = XVECTOR_DATA(arg)[j];
1002                         QUIT;
1003                         if (CONSP(elt) || VECTORP(elt))
1004                                 XVECTOR_DATA(arg)[j] =
1005                                     safe_copy_tree(elt, vecp, depth + 1);
1006                 }
1007         }
1008         return arg;
1009 }
1010
1011 DEFUN("substring", Fsubstring, 2, 3, 0, /*
1012 Return the substring of STRING starting at START and ending before END.
1013 END may be nil or omitted; then the substring runs to the end of STRING.
1014 If START or END is negative, it counts from the end.
1015 Relevant parts of the string-extent-data are copied to the new string.
1016 */
1017       (string, start, end))
1018 {
1019         Charcount ccstart, ccend;
1020         Bytecount bstart, blen;
1021         Lisp_Object val;
1022
1023         CHECK_STRING(string);
1024         CHECK_INT(start);
1025         get_string_range_char(string, start, end, &ccstart, &ccend,
1026                               GB_HISTORICAL_STRING_BEHAVIOR);
1027         bstart = charcount_to_bytecount(XSTRING_DATA(string), ccstart);
1028         blen =
1029             charcount_to_bytecount(XSTRING_DATA(string) + bstart,
1030                                    ccend - ccstart);
1031         val = make_string(XSTRING_DATA(string) + bstart, blen);
1032         /* Copy any applicable extent information into the new string. */
1033         copy_string_extents(val, string, 0, bstart, blen);
1034         return val;
1035 }
1036
1037 DEFUN("subseq", Fsubseq, 2, 3, 0,       /*
1038 Return the subsequence of SEQUENCE starting at START and ending before END.
1039 END may be omitted; then the subsequence runs to the end of SEQUENCE.
1040 If START or END is negative, it counts from the end.
1041 The returned subsequence is always of the same type as SEQUENCE.
1042 If SEQUENCE is a string, relevant parts of the string-extent-data
1043 are copied to the new string.
1044 */
1045       (sequence, start, end))
1046 {
1047         EMACS_INT len, s, e;
1048
1049         if (STRINGP(sequence))
1050                 return Fsubstring(sequence, start, end);
1051
1052         len = XINT(Flength(sequence));
1053
1054         CHECK_INT(start);
1055         s = XINT(start);
1056         if (s < 0)
1057                 s = len + s;
1058
1059         if (NILP(end))
1060                 e = len;
1061         else {
1062                 CHECK_INT(end);
1063                 e = XINT(end);
1064                 if (e < 0)
1065                         e = len + e;
1066         }
1067
1068         if (!(0 <= s && s <= e && e <= len))
1069                 args_out_of_range_3(sequence, make_int(s), make_int(e));
1070
1071         if (VECTORP(sequence)) {
1072                 Lisp_Object result = make_vector(e - s, Qnil);
1073                 EMACS_INT i;
1074                 Lisp_Object *in_elts = XVECTOR_DATA(sequence);
1075                 Lisp_Object *out_elts = XVECTOR_DATA(result);
1076
1077                 for (i = s; i < e; i++)
1078                         out_elts[i - s] = in_elts[i];
1079                 return result;
1080         } else if (LISTP(sequence)) {
1081                 Lisp_Object result = Qnil;
1082                 EMACS_INT i;
1083
1084                 sequence = Fnthcdr(make_int(s), sequence);
1085
1086                 for (i = s; i < e; i++) {
1087                         result = Fcons(Fcar(sequence), result);
1088                         sequence = Fcdr(sequence);
1089                 }
1090
1091                 return Fnreverse(result);
1092         } else if (BIT_VECTORP(sequence)) {
1093                 Lisp_Object result = make_bit_vector(e - s, Qzero);
1094                 EMACS_INT i;
1095
1096                 for (i = s; i < e; i++)
1097                         set_bit_vector_bit(XBIT_VECTOR(result), i - s,
1098                                            bit_vector_bit(XBIT_VECTOR(sequence),
1099                                                           i));
1100                 return result;
1101         } else {
1102                 abort();        /* unreachable, since Flength (sequence) did not get
1103                                    an error */
1104                 return Qnil;
1105         }
1106 }
1107 \f
1108 DEFUN("nthcdr", Fnthcdr, 2, 2, 0,       /*
1109 Take cdr N times on LIST, and return the result.
1110 */
1111       (n, list))
1112 {
1113         REGISTER size_t i;
1114         REGISTER Lisp_Object tail = list;
1115         CHECK_NATNUM(n);
1116         for (i = XINT(n); i; i--) {
1117                 if (CONSP(tail))
1118                         tail = XCDR(tail);
1119                 else if (NILP(tail))
1120                         return Qnil;
1121                 else {
1122                         tail = wrong_type_argument(Qlistp, tail);
1123                         i++;
1124                 }
1125         }
1126         return tail;
1127 }
1128
1129 DEFUN("nth", Fnth, 2, 2, 0,     /*
1130 Return the Nth element of LIST.
1131 N counts from zero.  If LIST is not that long, nil is returned.
1132 */
1133       (n, list))
1134 {
1135         return Fcar(Fnthcdr(n, list));
1136 }
1137
1138 DEFUN("elt", Felt, 2, 2, 0,     /*
1139 Return element of SEQUENCE at index N.
1140 */
1141       (sequence, n))
1142 {
1143 retry:
1144         if (!(INTP(n) || CHARP(n))) {
1145                 n = wrong_type_argument(Qinteger_or_char_p, n);
1146                 goto retry;
1147         }
1148
1149         if (LISTP(sequence)) {
1150                 Lisp_Object tem = Fnthcdr(n, sequence);
1151                 /* #### Utterly, completely, fucking disgusting.
1152                  * #### The whole point of "elt" is that it operates on
1153                  * #### sequences, and does error- (bounds-) checking.
1154                  */
1155                 if (CONSP(tem))
1156                         return XCAR(tem);
1157                 else
1158 #if 1
1159                         /* This is The Way It Has Always Been. */
1160                         return Qnil;
1161 #else
1162                         /* This is The Way Mly and Cltl2 say It Should Be. */
1163                         args_out_of_range(sequence, n);
1164 #endif
1165         } else if (DLLISTP(sequence)) {
1166                 dllist_item_t elm = NULL;
1167                 int rev = 0;
1168                 REGISTER size_t i;
1169                 EMACS_INT rn = ent_int(n);
1170
1171                 if (rn < 0) {
1172                         args_out_of_range(sequence, n);
1173                         return Qnil;
1174                 }
1175
1176                 if (rn * 2 < (EMACS_INT)XDLLIST_SIZE(sequence)) {
1177                         /* start at the front */
1178                         elm = XDLLIST_FIRST(sequence);
1179                         i = rn;
1180                 } else {
1181                         /* start at the end */
1182                         elm = XDLLIST_LAST(sequence);
1183                         rev = 1;
1184                         i = XDLLIST_SIZE(sequence) - rn - 1;
1185                 }
1186
1187                 for (; i > 0 && elm != NULL; i--)
1188                         if (rev == 0)
1189                                 elm = elm->next;
1190                         else
1191                                 elm = elm->prev;
1192
1193                 if (elm)
1194                         return (Lisp_Object)elm->item;
1195                 else
1196                         return Qnil;
1197
1198         } else if (STRINGP(sequence) ||
1199                    VECTORP(sequence) || BIT_VECTORP(sequence))
1200                 return Faref(sequence, n);
1201 #ifdef LOSING_BYTECODE
1202         else if (COMPILED_FUNCTIONP(sequence)) {
1203                 EMACS_INT idx = ent_int(n);
1204                 if (idx < 0) {
1205                       lose:
1206                         args_out_of_range(sequence, n);
1207                 }
1208                 /* Utter perversity */
1209                 {
1210                         Lisp_Compiled_Function *f =
1211                             XCOMPILED_FUNCTION(sequence);
1212                         switch (idx) {
1213                         case COMPILED_ARGLIST:
1214                                 return compiled_function_arglist(f);
1215                         case COMPILED_INSTRUCTIONS:
1216                                 return compiled_function_instructions(f);
1217                         case COMPILED_CONSTANTS:
1218                                 return compiled_function_constants(f);
1219                         case COMPILED_STACK_DEPTH:
1220                                 return compiled_function_stack_depth(f);
1221                         case COMPILED_DOC_STRING:
1222                                 return compiled_function_documentation(f);
1223                         case COMPILED_DOMAIN:
1224                                 return compiled_function_domain(f);
1225                         case COMPILED_INTERACTIVE:
1226                                 if (f->flags.interactivep)
1227                                         return compiled_function_interactive(f);
1228                                 /* if we return nil, can't tell interactive with no args
1229                                    from noninteractive. */
1230                                 goto lose;
1231                         default:
1232                                 goto lose;
1233                         }
1234                 }
1235         }
1236 #endif                          /* LOSING_BYTECODE */
1237         else {
1238                 check_losing_bytecode("elt", sequence);
1239                 sequence = wrong_type_argument(Qsequencep, sequence);
1240                 goto retry;
1241         }
1242 }
1243
1244 DEFUN("last", Flast, 1, 2, 0,   /*
1245 Return the tail of list LIST, of length N (default 1).
1246 LIST may be a dotted list, but not a circular list.
1247 Optional argument N must be a non-negative integer.
1248 If N is zero, then the atom that terminates the list is returned.
1249 If N is greater than the length of LIST, then LIST itself is returned.
1250 */
1251       (list, n))
1252 {
1253         EMACS_INT int_n, count;
1254         Lisp_Object retval, tortoise, hare;
1255
1256         if (DLLISTP(list))
1257                 return Fdllist_rac(list);
1258
1259         CHECK_LIST(list);
1260
1261         if (NILP(n))
1262                 int_n = 1;
1263         else {
1264                 CHECK_NATNUM(n);
1265                 int_n = XINT(n);
1266         }
1267
1268         for (retval = tortoise = hare = list, count = 0;
1269              CONSP(hare);
1270              hare = XCDR(hare),
1271              (int_n-- <= 0 ? ((void)(retval = XCDR(retval))) : (void)0),
1272              count++) {
1273                 if (count < CIRCULAR_LIST_SUSPICION_LENGTH)
1274                         continue;
1275
1276                 if (count & 1)
1277                         tortoise = XCDR(tortoise);
1278                 if (EQ(hare, tortoise))
1279                         signal_circular_list_error(list);
1280         }
1281
1282         return retval;
1283 }
1284
1285 DEFUN("nbutlast", Fnbutlast, 1, 2, 0,   /*
1286 Modify LIST to remove the last N (default 1) elements.
1287 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1288 */
1289       (list, n))
1290 {
1291         EMACS_INT int_n;
1292
1293         CHECK_LIST(list);
1294
1295         if (NILP(n))
1296                 int_n = 1;
1297         else {
1298                 CHECK_NATNUM(n);
1299                 int_n = XINT(n);
1300         }
1301
1302         {
1303                 Lisp_Object last_cons = list;
1304
1305                 EXTERNAL_LIST_LOOP_1(list) {
1306                         if (int_n-- < 0)
1307                                 last_cons = XCDR(last_cons);
1308                 }
1309
1310                 if (int_n >= 0)
1311                         return Qnil;
1312
1313                 XCDR(last_cons) = Qnil;
1314                 return list;
1315         }
1316 }
1317
1318 DEFUN("butlast", Fbutlast, 1, 2, 0,     /*
1319 Return a copy of LIST with the last N (default 1) elements removed.
1320 If LIST has N or fewer elements, nil is returned.
1321 */
1322       (list, n))
1323 {
1324         EMACS_INT int_n;
1325
1326         CHECK_LIST(list);
1327
1328         if (NILP(n))
1329                 int_n = 1;
1330         else {
1331                 CHECK_NATNUM(n);
1332                 int_n = XINT(n);
1333         }
1334
1335         {
1336                 Lisp_Object retval = Qnil;
1337                 Lisp_Object tail = list;
1338
1339                 EXTERNAL_LIST_LOOP_1(list) {
1340                         if (--int_n < 0) {
1341                                 retval = Fcons(XCAR(tail), retval);
1342                                 tail = XCDR(tail);
1343                         }
1344                 }
1345
1346                 return Fnreverse(retval);
1347         }
1348 }
1349
1350 DEFUN("member", Fmember, 2, 2, 0,       /*
1351 Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.
1352 The value is actually the tail of LIST whose car is ELT.
1353 */
1354       (elt, list))
1355 {
1356         EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1357                 if (internal_equal(elt, list_elt, 0))
1358                         return tail;
1359         }
1360         return Qnil;
1361 }
1362
1363 DEFUN("old-member", Fold_member, 2, 2, 0,       /*
1364 Return non-nil if ELT is an element of LIST.  Comparison done with `old-equal'.
1365 The value is actually the tail of LIST whose car is ELT.
1366 This function is provided only for byte-code compatibility with v19.
1367 Do not use it.
1368 */
1369       (elt, list))
1370 {
1371         EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1372                 if (internal_old_equal(elt, list_elt, 0))
1373                         return tail;
1374         }
1375         return Qnil;
1376 }
1377
1378 DEFUN("memq", Fmemq, 2, 2, 0,   /*
1379 Return non-nil if ELT is an element of LIST.  Comparison done with `eq'.
1380 The value is actually the tail of LIST whose car is ELT.
1381 */
1382       (elt, list))
1383 {
1384         EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1385                 if (EQ_WITH_EBOLA_NOTICE(elt, list_elt))
1386                         return tail;
1387         }
1388         return Qnil;
1389 }
1390
1391 DEFUN("old-memq", Fold_memq, 2, 2, 0,   /*
1392 Return non-nil if ELT is an element of LIST.  Comparison done with `old-eq'.
1393 The value is actually the tail of LIST whose car is ELT.
1394 This function is provided only for byte-code compatibility with v19.
1395 Do not use it.
1396 */
1397       (elt, list))
1398 {
1399         EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1400                 if (HACKEQ_UNSAFE(elt, list_elt))
1401                         return tail;
1402         }
1403         return Qnil;
1404 }
1405
1406 Lisp_Object memq_no_quit(Lisp_Object elt, Lisp_Object list)
1407 {
1408         LIST_LOOP_3(list_elt, list, tail) {
1409                 if (EQ_WITH_EBOLA_NOTICE(elt, list_elt))
1410                         return tail;
1411         }
1412         return Qnil;
1413 }
1414
1415 DEFUN("assoc", Fassoc, 2, 2, 0, /*
1416 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1417 The value is actually the element of ALIST whose car equals KEY.
1418 */
1419       (key, alist))
1420 {
1421         /* This function can GC. */
1422         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1423                 if (internal_equal(key, elt_car, 0))
1424                         return elt;
1425         }
1426         return Qnil;
1427 }
1428
1429 DEFUN("old-assoc", Fold_assoc, 2, 2, 0, /*
1430 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
1431 The value is actually the element of ALIST whose car equals KEY.
1432 */
1433       (key, alist))
1434 {
1435         /* This function can GC. */
1436         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1437                 if (internal_old_equal(key, elt_car, 0))
1438                         return elt;
1439         }
1440         return Qnil;
1441 }
1442
1443 Lisp_Object assoc_no_quit(Lisp_Object key, Lisp_Object alist)
1444 {
1445         int speccount = specpdl_depth();
1446         specbind(Qinhibit_quit, Qt);
1447         return unbind_to(speccount, Fassoc(key, alist));
1448 }
1449
1450 DEFUN("assq", Fassq, 2, 2, 0,   /*
1451 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1452 The value is actually the element of ALIST whose car is KEY.
1453 Elements of ALIST that are not conses are ignored.
1454 */
1455       (key, alist))
1456 {
1457         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1458                 if (EQ_WITH_EBOLA_NOTICE(key, elt_car))
1459                         return elt;
1460         }
1461         return Qnil;
1462 }
1463
1464 DEFUN("old-assq", Fold_assq, 2, 2, 0,   /*
1465 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
1466 The value is actually the element of ALIST whose car is KEY.
1467 Elements of ALIST that are not conses are ignored.
1468 This function is provided only for byte-code compatibility with v19.
1469 Do not use it.
1470 */
1471       (key, alist))
1472 {
1473         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1474                 if (HACKEQ_UNSAFE(key, elt_car))
1475                         return elt;
1476         }
1477         return Qnil;
1478 }
1479
1480 /* Like Fassq but never report an error and do not allow quits.
1481    Use only on lists known never to be circular.  */
1482
1483 Lisp_Object assq_no_quit(Lisp_Object key, Lisp_Object alist)
1484 {
1485         /* This cannot GC. */
1486         LIST_LOOP_2(elt, alist) {
1487                 Lisp_Object elt_car = XCAR(elt);
1488                 if (EQ_WITH_EBOLA_NOTICE(key, elt_car))
1489                         return elt;
1490         }
1491         return Qnil;
1492 }
1493
1494 DEFUN("rassoc", Frassoc, 2, 2, 0,       /*
1495 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1496 The value is actually the element of ALIST whose cdr equals VALUE.
1497 */
1498       (value, alist))
1499 {
1500         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1501                 if (internal_equal(value, elt_cdr, 0))
1502                         return elt;
1503         }
1504         return Qnil;
1505 }
1506
1507 DEFUN("old-rassoc", Fold_rassoc, 2, 2, 0,       /*
1508 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
1509 The value is actually the element of ALIST whose cdr equals VALUE.
1510 */
1511       (value, alist))
1512 {
1513         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1514                 if (internal_old_equal(value, elt_cdr, 0))
1515                         return elt;
1516         }
1517         return Qnil;
1518 }
1519
1520 DEFUN("rassq", Frassq, 2, 2, 0, /*
1521 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1522 The value is actually the element of ALIST whose cdr is VALUE.
1523 */
1524       (value, alist))
1525 {
1526         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1527                 if (EQ_WITH_EBOLA_NOTICE(value, elt_cdr))
1528                         return elt;
1529         }
1530         return Qnil;
1531 }
1532
1533 DEFUN("old-rassq", Fold_rassq, 2, 2, 0, /*
1534 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
1535 The value is actually the element of ALIST whose cdr is VALUE.
1536 */
1537       (value, alist))
1538 {
1539         EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1540                 if (HACKEQ_UNSAFE(value, elt_cdr))
1541                         return elt;
1542         }
1543         return Qnil;
1544 }
1545
1546 /* Like Frassq, but caller must ensure that ALIST is properly
1547    nil-terminated and ebola-free. */
1548 Lisp_Object rassq_no_quit(Lisp_Object value, Lisp_Object alist)
1549 {
1550         LIST_LOOP_2(elt, alist) {
1551                 Lisp_Object elt_cdr = XCDR(elt);
1552                 if (EQ_WITH_EBOLA_NOTICE(value, elt_cdr))
1553                         return elt;
1554         }
1555         return Qnil;
1556 }
1557 \f
1558 DEFUN("delete", Fdelete, 2, 2, 0,       /*
1559 Delete by side effect any occurrences of ELT as a member of LIST.
1560 The modified LIST is returned.  Comparison is done with `equal'.
1561 If the first member of LIST is ELT, there is no way to remove it by side
1562 effect; therefore, write `(setq foo (delete element foo))' to be sure
1563 of changing the value of `foo'.
1564 Also see: `remove'.
1565 */
1566       (elt, list))
1567 {
1568         EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1569                                      (internal_equal(elt, list_elt, 0)));
1570         return list;
1571 }
1572
1573 DEFUN("old-delete", Fold_delete, 2, 2, 0,       /*
1574 Delete by side effect any occurrences of ELT as a member of LIST.
1575 The modified LIST is returned.  Comparison is done with `old-equal'.
1576 If the first member of LIST is ELT, there is no way to remove it by side
1577 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1578 of changing the value of `foo'.
1579 */
1580       (elt, list))
1581 {
1582         EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1583                                      (internal_old_equal(elt, list_elt, 0)));
1584         return list;
1585 }
1586
1587 DEFUN("delq", Fdelq, 2, 2, 0,   /*
1588 Delete by side effect any occurrences of ELT as a member of LIST.
1589 The modified LIST is returned.  Comparison is done with `eq'.
1590 If the first member of LIST is ELT, there is no way to remove it by side
1591 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1592 changing the value of `foo'.
1593 */
1594       (elt, list))
1595 {
1596         EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1597                                      (EQ_WITH_EBOLA_NOTICE(elt, list_elt)));
1598         return list;
1599 }
1600
1601 DEFUN("old-delq", Fold_delq, 2, 2, 0,   /*
1602 Delete by side effect any occurrences of ELT as a member of LIST.
1603 The modified LIST is returned.  Comparison is done with `old-eq'.
1604 If the first member of LIST is ELT, there is no way to remove it by side
1605 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1606 changing the value of `foo'.
1607 */
1608       (elt, list))
1609 {
1610         EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1611                                      (HACKEQ_UNSAFE(elt, list_elt)));
1612         return list;
1613 }
1614
1615 /* Like Fdelq, but caller must ensure that LIST is properly
1616    nil-terminated and ebola-free. */
1617
1618 Lisp_Object delq_no_quit(Lisp_Object elt, Lisp_Object list)
1619 {
1620         LIST_LOOP_DELETE_IF(list_elt, list,
1621                             (EQ_WITH_EBOLA_NOTICE(elt, list_elt)));
1622         return list;
1623 }
1624
1625 /* Be VERY careful with this.  This is like delq_no_quit() but
1626    also calls free_cons() on the removed conses.  You must be SURE
1627    that no pointers to the freed conses remain around (e.g.
1628    someone else is pointing to part of the list).  This function
1629    is useful on internal lists that are used frequently and where
1630    the actual list doesn't escape beyond known code bounds. */
1631
1632 Lisp_Object delq_no_quit_and_free_cons(Lisp_Object elt, Lisp_Object list)
1633 {
1634         REGISTER Lisp_Object tail = list;
1635         REGISTER Lisp_Object prev = Qnil;
1636
1637         while (!NILP(tail)) {
1638                 REGISTER Lisp_Object tem = XCAR(tail);
1639                 if (EQ(elt, tem)) {
1640                         Lisp_Object cons_to_free = tail;
1641                         if (NILP(prev))
1642                                 list = XCDR(tail);
1643                         else
1644                                 XCDR(prev) = XCDR(tail);
1645                         tail = XCDR(tail);
1646                         free_cons(XCONS(cons_to_free));
1647                 } else {
1648                         prev = tail;
1649                         tail = XCDR(tail);
1650                 }
1651         }
1652         return list;
1653 }
1654
1655 DEFUN("remassoc", Fremassoc, 2, 2, 0,   /*
1656 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
1657 The modified ALIST is returned.  If the first member of ALIST has a car
1658 that is `equal' to KEY, there is no way to remove it by side effect;
1659 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1660 the value of `foo'.
1661 */
1662       (key, alist))
1663 {
1664         EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1665                                      (CONSP(elt) &&
1666                                       internal_equal(key, XCAR(elt), 0)));
1667         return alist;
1668 }
1669
1670 Lisp_Object remassoc_no_quit(Lisp_Object key, Lisp_Object alist)
1671 {
1672         int speccount = specpdl_depth();
1673         specbind(Qinhibit_quit, Qt);
1674         return unbind_to(speccount, Fremassoc(key, alist));
1675 }
1676
1677 DEFUN("remassq", Fremassq, 2, 2, 0,     /*
1678 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
1679 The modified ALIST is returned.  If the first member of ALIST has a car
1680 that is `eq' to KEY, there is no way to remove it by side effect;
1681 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1682 the value of `foo'.
1683 */
1684       (key, alist))
1685 {
1686         EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1687                                      (CONSP(elt) &&
1688                                       EQ_WITH_EBOLA_NOTICE(key, XCAR(elt))));
1689         return alist;
1690 }
1691
1692 /* no quit, no errors; be careful */
1693
1694 Lisp_Object remassq_no_quit(Lisp_Object key, Lisp_Object alist)
1695 {
1696         LIST_LOOP_DELETE_IF(elt, alist,
1697                             (CONSP(elt) &&
1698                              EQ_WITH_EBOLA_NOTICE(key, XCAR(elt))));
1699         return alist;
1700 }
1701
1702 DEFUN("remrassoc", Fremrassoc, 2, 2, 0, /*
1703 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
1704 The modified ALIST is returned.  If the first member of ALIST has a car
1705 that is `equal' to VALUE, there is no way to remove it by side effect;
1706 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1707 the value of `foo'.
1708 */
1709       (value, alist))
1710 {
1711         EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1712                                      (CONSP(elt) &&
1713                                       internal_equal(value, XCDR(elt), 0)));
1714         return alist;
1715 }
1716
1717 DEFUN("remrassq", Fremrassq, 2, 2, 0,   /*
1718 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
1719 The modified ALIST is returned.  If the first member of ALIST has a car
1720 that is `eq' to VALUE, there is no way to remove it by side effect;
1721 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1722 the value of `foo'.
1723 */
1724       (value, alist))
1725 {
1726         EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1727                                      (CONSP(elt) &&
1728                                       EQ_WITH_EBOLA_NOTICE(value, XCDR(elt))));
1729         return alist;
1730 }
1731
1732 /* Like Fremrassq, fast and unsafe; be careful */
1733 Lisp_Object remrassq_no_quit(Lisp_Object value, Lisp_Object alist)
1734 {
1735         LIST_LOOP_DELETE_IF(elt, alist,
1736                             (CONSP(elt) &&
1737                              EQ_WITH_EBOLA_NOTICE(value, XCDR(elt))));
1738         return alist;
1739 }
1740
1741 DEFUN("nreverse", Fnreverse, 1, 1, 0,   /*
1742 Reverse LIST by destructively modifying cdr pointers.
1743 Return the beginning of the reversed list.
1744 Also see: `reverse'.
1745 */
1746       (list))
1747 {
1748         struct gcpro gcpro1, gcpro2;
1749         REGISTER Lisp_Object prev = Qnil;
1750         REGISTER Lisp_Object tail = list;
1751
1752         /* We gcpro our args; see `nconc' */
1753         GCPRO2(prev, tail);
1754         while (!NILP(tail)) {
1755                 REGISTER Lisp_Object next;
1756                 CONCHECK_CONS(tail);
1757                 next = XCDR(tail);
1758                 XCDR(tail) = prev;
1759                 prev = tail;
1760                 tail = next;
1761         }
1762         UNGCPRO;
1763         return prev;
1764 }
1765
1766 DEFUN("reverse", Freverse, 1, 1, 0,     /*
1767 Reverse LIST, copying.  Return the beginning of the reversed list.
1768 See also the function `nreverse', which is used more often.
1769 */
1770       (list))
1771 {
1772         Lisp_Object reversed_list = Qnil;
1773         EXTERNAL_LIST_LOOP_2(elt, list) {
1774                 reversed_list = Fcons(elt, reversed_list);
1775         }
1776         return reversed_list;
1777 }
1778 \f
1779 static Lisp_Object list_merge(Lisp_Object org_l1, Lisp_Object org_l2,
1780                               Lisp_Object lisp_arg,
1781                               int (*pred_fn) (Lisp_Object, Lisp_Object,
1782                                               Lisp_Object lisp_arg));
1783
1784 Lisp_Object
1785 list_sort(Lisp_Object list,
1786           Lisp_Object lisp_arg,
1787           int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1788 {
1789         struct gcpro gcpro1, gcpro2, gcpro3;
1790         Lisp_Object back, tem;
1791         Lisp_Object front = list;
1792         Lisp_Object len = Flength(list);
1793
1794         if (XINT(len) < 2)
1795                 return list;
1796
1797         len = make_int(XINT(len) / 2 - 1);
1798         tem = Fnthcdr(len, list);
1799         back = Fcdr(tem);
1800         Fsetcdr(tem, Qnil);
1801
1802         GCPRO3(front, back, lisp_arg);
1803         front = list_sort(front, lisp_arg, pred_fn);
1804         back = list_sort(back, lisp_arg, pred_fn);
1805         UNGCPRO;
1806         return list_merge(front, back, lisp_arg, pred_fn);
1807 }
1808 \f
1809 static int
1810 merge_pred_function(Lisp_Object obj1, Lisp_Object obj2, Lisp_Object pred)
1811 {
1812         Lisp_Object tmp;
1813
1814         /* prevents the GC from happening in call2 */
1815         int speccount = specpdl_depth();
1816 /* Emacs' GC doesn't actually relocate pointers, so this probably
1817    isn't strictly necessary */
1818         record_unwind_protect(restore_gc_inhibit,
1819                               make_int(gc_currently_forbidden));
1820         gc_currently_forbidden = 1;
1821         tmp = call2(pred, obj1, obj2);
1822         unbind_to(speccount, Qnil);
1823
1824         if (NILP(tmp))
1825                 return -1;
1826         else
1827                 return 1;
1828 }
1829
1830 DEFUN("sort", Fsort, 2, 2, 0,   /*
1831 Sort LIST, stably, comparing elements using PREDICATE.
1832 Returns the sorted list.  LIST is modified by side effects.
1833 PREDICATE is called with two elements of LIST, and should return T
1834 if the first element is "less" than the second.
1835 */
1836       (list, predicate))
1837 {
1838         return list_sort(list, predicate, merge_pred_function);
1839 }
1840
1841 Lisp_Object merge(Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1842 {
1843         return list_merge(org_l1, org_l2, pred, merge_pred_function);
1844 }
1845
1846 static Lisp_Object
1847 list_merge(Lisp_Object org_l1, Lisp_Object org_l2,
1848            Lisp_Object lisp_arg,
1849            int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1850 {
1851         Lisp_Object value;
1852         Lisp_Object tail;
1853         Lisp_Object tem;
1854         Lisp_Object l1, l2;
1855         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1856
1857         l1 = org_l1;
1858         l2 = org_l2;
1859         tail = Qnil;
1860         value = Qnil;
1861
1862         /* It is sufficient to protect org_l1 and org_l2.
1863            When l1 and l2 are updated, we copy the new values
1864            back into the org_ vars.  */
1865
1866         GCPRO4(org_l1, org_l2, lisp_arg, value);
1867
1868         while (1) {
1869                 if (NILP(l1)) {
1870                         UNGCPRO;
1871                         if (NILP(tail))
1872                                 return l2;
1873                         Fsetcdr(tail, l2);
1874                         return value;
1875                 }
1876                 if (NILP(l2)) {
1877                         UNGCPRO;
1878                         if (NILP(tail))
1879                                 return l1;
1880                         Fsetcdr(tail, l1);
1881                         return value;
1882                 }
1883
1884                 if (((*pred_fn) (Fcar(l2), Fcar(l1), lisp_arg)) < 0) {
1885                         tem = l1;
1886                         l1 = Fcdr(l1);
1887                         org_l1 = l1;
1888                 } else {
1889                         tem = l2;
1890                         l2 = Fcdr(l2);
1891                         org_l2 = l2;
1892                 }
1893                 if (NILP(tail))
1894                         value = tem;
1895                 else
1896                         Fsetcdr(tail, tem);
1897                 tail = tem;
1898         }
1899 }
1900 \f
1901 /************************************************************************/
1902 /*                      property-list functions                         */
1903 /************************************************************************/
1904
1905 /* For properties of text, we need to do order-insensitive comparison of
1906    plists.  That is, we need to compare two plists such that they are the
1907    same if they have the same set of keys, and equivalent values.
1908    So (a 1 b 2) would be equal to (b 2 a 1).
1909
1910    NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1911    LAXP means use `equal' for comparisons.
1912  */
1913 int
1914 plists_differ(Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1915               int laxp, int depth)
1916 {
1917         int eqp = (depth == -1);        /* -1 as depth means use eq, not equal. */
1918         int la, lb, m, i, fill;
1919         Lisp_Object *keys, *vals;
1920         char *flags;
1921         Lisp_Object rest;
1922         int speccount = specpdl_depth();
1923
1924         if (NILP(a) && NILP(b))
1925                 return 0;
1926
1927         Fcheck_valid_plist(a);
1928         Fcheck_valid_plist(b);
1929
1930         la = XINT(Flength(a));
1931         lb = XINT(Flength(b));
1932         m = (la > lb ? la : lb);
1933         fill = 0;
1934         XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
1935         XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
1936         XMALLOC_ATOMIC_OR_ALLOCA(flags, m, char);
1937
1938         /* First extract the pairs from A. */
1939         for (rest = a; !NILP(rest); rest = XCDR(XCDR(rest))) {
1940                 Lisp_Object k = XCAR(rest);
1941                 Lisp_Object v = XCAR(XCDR(rest));
1942                 /* Maybe be Ebolified. */
1943                 if (nil_means_not_present && NILP(v))
1944                         continue;
1945                 keys[fill] = k;
1946                 vals[fill] = v;
1947                 flags[fill] = 0;
1948                 fill++;
1949         }
1950         /* Now iterate over B, and stop if we find something that's not in A,
1951            or that doesn't match.  As we match, mark them. */
1952         for (rest = b; !NILP(rest); rest = XCDR(XCDR(rest))) {
1953                 Lisp_Object k = XCAR(rest);
1954                 Lisp_Object v = XCAR(XCDR(rest));
1955                 /* Maybe be Ebolified. */
1956                 if (nil_means_not_present && NILP(v))
1957                         continue;
1958                 for (i = 0; i < fill; i++) {
1959                         if (!laxp ? EQ(k, keys[i]) :
1960                             internal_equal(k, keys[i], depth)) {
1961                                 if (eqp
1962                                     /* We narrowly escaped being Ebolified
1963                                        here. */
1964                                     ? !EQ_WITH_EBOLA_NOTICE(v, vals[i])
1965                                     : !internal_equal(v, vals[i], depth))
1966                                         /* a property in B has a different value
1967                                            than in A */
1968                                         goto MISMATCH;
1969                                 flags[i] = 1;
1970                                 break;
1971                         }
1972                 }
1973                 if (i == fill)
1974                         /* there are some properties in B that are not in A */
1975                         goto MISMATCH;
1976         }
1977         /* Now check to see that all the properties in A were also in B */
1978         for (i = 0; i < fill; i++)
1979                 if (flags[i] == 0)
1980                         goto MISMATCH;
1981
1982         XMALLOC_UNBIND(flags, m, speccount);
1983         XMALLOC_UNBIND(vals, m, speccount);
1984         XMALLOC_UNBIND(keys, m, speccount);
1985         /* Ok. */
1986         return 0;
1987
1988 MISMATCH:
1989         XMALLOC_UNBIND(flags, m, speccount);
1990         XMALLOC_UNBIND(vals, m, speccount);
1991         XMALLOC_UNBIND(keys, m, speccount);
1992         return 1;
1993 }
1994
1995 DEFUN("plists-eq", Fplists_eq, 2, 3, 0, /*
1996 Return non-nil if property lists A and B are `eq'.
1997 A property list is an alternating list of keywords and values.
1998 This function does order-insensitive comparisons of the property lists:
1999 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2000 Comparison between values is done using `eq'.  See also `plists-equal'.
2001 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2002 a nil value is ignored.  This feature is a virus that has infected
2003 old Lisp implementations, but should not be used except for backward
2004 compatibility.
2005 */
2006       (a, b, nil_means_not_present))
2007 {
2008         return (plists_differ(a, b, !NILP(nil_means_not_present), 0, -1)
2009                 ? Qnil : Qt);
2010 }
2011
2012 DEFUN("plists-equal", Fplists_equal, 2, 3, 0,   /*
2013 Return non-nil if property lists A and B are `equal'.
2014 A property list is an alternating list of keywords and values.  This
2015 function does order-insensitive comparisons of the property lists: For
2016 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2017 Comparison between values is done using `equal'.  See also `plists-eq'.
2018 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2019 a nil value is ignored.  This feature is a virus that has infected
2020 old Lisp implementations, but should not be used except for backward
2021 compatibility.
2022 */
2023       (a, b, nil_means_not_present))
2024 {
2025         return (plists_differ(a, b, !NILP(nil_means_not_present), 0, 1)
2026                 ? Qnil : Qt);
2027 }
2028
2029 DEFUN("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
2030 Return non-nil if lax property lists A and B are `eq'.
2031 A property list is an alternating list of keywords and values.
2032 This function does order-insensitive comparisons of the property lists:
2033 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2034 Comparison between values is done using `eq'.  See also `plists-equal'.
2035 A lax property list is like a regular one except that comparisons between
2036 keywords is done using `equal' instead of `eq'.
2037 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2038 a nil value is ignored.  This feature is a virus that has infected
2039 old Lisp implementations, but should not be used except for backward
2040 compatibility.
2041 */
2042       (a, b, nil_means_not_present))
2043 {
2044         return (plists_differ(a, b, !NILP(nil_means_not_present), 1, -1)
2045                 ? Qnil : Qt);
2046 }
2047
2048 DEFUN("lax-plists-equal", Flax_plists_equal, 2, 3, 0,   /*
2049 Return non-nil if lax property lists A and B are `equal'.
2050 A property list is an alternating list of keywords and values.  This
2051 function does order-insensitive comparisons of the property lists: For
2052 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2053 Comparison between values is done using `equal'.  See also `plists-eq'.
2054 A lax property list is like a regular one except that comparisons between
2055 keywords is done using `equal' instead of `eq'.
2056 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2057 a nil value is ignored.  This feature is a virus that has infected
2058 old Lisp implementations, but should not be used except for backward
2059 compatibility.
2060 */
2061       (a, b, nil_means_not_present))
2062 {
2063         return (plists_differ(a, b, !NILP(nil_means_not_present), 1, 1)
2064                 ? Qnil : Qt);
2065 }
2066
2067 /* Return the value associated with key PROPERTY in property list PLIST.
2068    Return nil if key not found.  This function is used for internal
2069    property lists that cannot be directly manipulated by the user.
2070    */
2071
2072 Lisp_Object internal_plist_get(Lisp_Object plist, Lisp_Object property)
2073 {
2074         Lisp_Object tail;
2075
2076         for (tail = plist; !NILP(tail); tail = XCDR(XCDR(tail))) {
2077                 if (EQ(XCAR(tail), property))
2078                         return XCAR(XCDR(tail));
2079         }
2080
2081         return Qunbound;
2082 }
2083
2084 /* Set PLIST's value for PROPERTY to VALUE.  Analogous to
2085    internal_plist_get(). */
2086
2087 void
2088 internal_plist_put(Lisp_Object * plist, Lisp_Object property, Lisp_Object value)
2089 {
2090         Lisp_Object tail;
2091
2092         for (tail = *plist; !NILP(tail); tail = XCDR(XCDR(tail))) {
2093                 if (EQ(XCAR(tail), property)) {
2094                         XCAR(XCDR(tail)) = value;
2095                         return;
2096                 }
2097         }
2098
2099         *plist = Fcons(property, Fcons(value, *plist));
2100 }
2101
2102 int internal_remprop(Lisp_Object * plist, Lisp_Object property)
2103 {
2104         Lisp_Object tail, prev;
2105
2106         for (tail = *plist, prev = Qnil; !NILP(tail); tail = XCDR(XCDR(tail))) {
2107                 if (EQ(XCAR(tail), property)) {
2108                         if (NILP(prev))
2109                                 *plist = XCDR(XCDR(tail));
2110                         else
2111                                 XCDR(XCDR(prev)) = XCDR(XCDR(tail));
2112                         return 1;
2113                 } else
2114                         prev = tail;
2115         }
2116
2117         return 0;
2118 }
2119
2120 /* Called on a malformed property list.  BADPLACE should be some
2121    place where truncating will form a good list -- i.e. we shouldn't
2122    result in a list with an odd length. */
2123
2124 static Lisp_Object
2125 bad_bad_bunny(Lisp_Object * plist, Lisp_Object * badplace, Error_behavior errb)
2126 {
2127         if (ERRB_EQ(errb, ERROR_ME))
2128                 return Fsignal(Qmalformed_property_list,
2129                                list2(*plist, *badplace));
2130         else {
2131                 if (ERRB_EQ(errb, ERROR_ME_WARN)) {
2132                         warn_when_safe_lispobj
2133                             (Qlist, Qwarning,
2134                              list2(build_string
2135                                    ("Malformed property list -- list has been truncated"),
2136                                    *plist));
2137                         *badplace = Qnil;
2138                 }
2139                 return Qunbound;
2140         }
2141 }
2142
2143 /* Called on a circular property list.  BADPLACE should be some place
2144    where truncating will result in an even-length list, as above.
2145    If doesn't particularly matter where we truncate -- anywhere we
2146    truncate along the entire list will break the circularity, because
2147    it will create a terminus and the list currently doesn't have one.
2148 */
2149
2150 static Lisp_Object
2151 bad_bad_turtle(Lisp_Object * plist, Lisp_Object * badplace, Error_behavior errb)
2152 {
2153         if (ERRB_EQ(errb, ERROR_ME))
2154                 return Fsignal(Qcircular_property_list, list1(*plist));
2155         else {
2156                 if (ERRB_EQ(errb, ERROR_ME_WARN)) {
2157                         warn_when_safe_lispobj
2158                             (Qlist, Qwarning,
2159                              list2(build_string
2160                                    ("Circular property list -- list has been truncated"),
2161                                    *plist));
2162                         *badplace = Qnil;
2163                 }
2164                 return Qunbound;
2165         }
2166 }
2167
2168 /* Advance the tortoise pointer by two (one iteration of a property-list
2169    loop) and the hare pointer by four and verify that no malformations
2170    or circularities exist.  If so, return zero and store a value into
2171    RETVAL that should be returned by the calling function.  Otherwise,
2172    return 1.  See external_plist_get().
2173  */
2174
2175 static int
2176 advance_plist_pointers(Lisp_Object * plist,
2177                        Lisp_Object ** tortoise, Lisp_Object ** hare,
2178                        Error_behavior errb, Lisp_Object * retval)
2179 {
2180         int i;
2181         Lisp_Object *tortsave = *tortoise;
2182
2183         /* Note that our "fixing" may be more brutal than necessary,
2184            but it's the user's own problem, not ours, if they went in and
2185            manually fucked up a plist. */
2186
2187         for (i = 0; i < 2; i++) {
2188                 /* This is a standard iteration of a defensive-loop-checking
2189                    loop.  We just do it twice because we want to advance past
2190                    both the property and its value.
2191
2192                    If the pointer indirection is confusing you, remember that
2193                    one level of indirection on the hare and tortoise pointers
2194                    is only due to pass-by-reference for this function.  The other
2195                    level is so that the plist can be fixed in place. */
2196
2197                 /* When we reach the end of a well-formed plist, **HARE is
2198                    nil.  In that case, we don't do anything at all except
2199                    advance TORTOISE by one.  Otherwise, we advance HARE
2200                    by two (making sure it's OK to do so), then advance
2201                    TORTOISE by one (it will always be OK to do so because
2202                    the HARE is always ahead of the TORTOISE and will have
2203                    already verified the path), then make sure TORTOISE and
2204                    HARE don't contain the same non-nil object -- if the
2205                    TORTOISE and the HARE ever meet, then obviously we're
2206                    in a circularity, and if we're in a circularity, then
2207                    the TORTOISE and the HARE can't cross paths without
2208                    meeting, since the HARE only gains one step over the
2209                    TORTOISE per iteration. */
2210
2211                 if (!NILP(**hare)) {
2212                         Lisp_Object *haresave = *hare;
2213                         if (!CONSP(**hare)) {
2214                                 *retval = bad_bad_bunny(plist, haresave, errb);
2215                                 return 0;
2216                         }
2217                         *hare = &XCDR(**hare);
2218                         /* In a non-plist, we'd check here for a nil value for
2219                          **HARE, which is OK (it just means the list has an
2220                          odd number of elements).  In a plist, it's not OK
2221                          for the list to have an odd number of elements. */
2222                         if (!CONSP(**hare)) {
2223                                 *retval = bad_bad_bunny(plist, haresave, errb);
2224                                 return 0;
2225                         }
2226                         *hare = &XCDR(**hare);
2227                 }
2228
2229                 *tortoise = &XCDR(**tortoise);
2230                 if (!NILP(**hare) && EQ(**tortoise, **hare)) {
2231                         *retval = bad_bad_turtle(plist, tortsave, errb);
2232                         return 0;
2233                 }
2234         }
2235
2236         return 1;
2237 }
2238
2239 /* Return the value of PROPERTY from PLIST, or Qunbound if
2240    property is not on the list.
2241
2242    PLIST is a Lisp-accessible property list, meaning that it
2243    has to be checked for malformations and circularities.
2244
2245    If ERRB is ERROR_ME, an error will be signalled.  Otherwise, the
2246    function will never signal an error; and if ERRB is ERROR_ME_WARN,
2247    on finding a malformation or a circularity, it issues a warning and
2248    attempts to silently fix the problem.
2249
2250    A pointer to PLIST is passed in so that PLIST can be successfully
2251    "fixed" even if the error is at the beginning of the plist. */
2252
2253 Lisp_Object
2254 external_plist_get(Lisp_Object * plist, Lisp_Object property,
2255                    int laxp, Error_behavior errb)
2256 {
2257         Lisp_Object *tortoise = plist;
2258         Lisp_Object *hare = plist;
2259
2260         while (!NILP(*tortoise)) {
2261                 Lisp_Object *tortsave = tortoise;
2262                 Lisp_Object retval;
2263
2264                 /* We do the standard tortoise/hare march.  We isolate the
2265                    grungy stuff to do this in advance_plist_pointers(), though.
2266                    To us, all this function does is advance the tortoise
2267                    pointer by two and the hare pointer by four and make sure
2268                    everything's OK.  We first advance the pointers and then
2269                    check if a property matched; this ensures that our
2270                    check for a matching property is safe. */
2271
2272                 if (!advance_plist_pointers
2273                     (plist, &tortoise, &hare, errb, &retval))
2274                         return retval;
2275
2276                 if (!laxp ? EQ(XCAR(*tortsave), property)
2277                     : internal_equal(XCAR(*tortsave), property, 0))
2278                         return XCAR(XCDR(*tortsave));
2279         }
2280
2281         return Qunbound;
2282 }
2283
2284 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2285    malformed or circular plist.  Analogous to external_plist_get(). */
2286
2287 void
2288 external_plist_put(Lisp_Object * plist, Lisp_Object property,
2289                    Lisp_Object value, int laxp, Error_behavior errb)
2290 {
2291         Lisp_Object *tortoise = plist;
2292         Lisp_Object *hare = plist;
2293
2294         while (!NILP(*tortoise)) {
2295                 Lisp_Object *tortsave = tortoise;
2296                 Lisp_Object retval;
2297
2298                 /* See above */
2299                 if (!advance_plist_pointers
2300                     (plist, &tortoise, &hare, errb, &retval))
2301                         return;
2302
2303                 if (!laxp ? EQ(XCAR(*tortsave), property)
2304                     : internal_equal(XCAR(*tortsave), property, 0)) {
2305                         XCAR(XCDR(*tortsave)) = value;
2306                         return;
2307                 }
2308         }
2309
2310         *plist = Fcons(property, Fcons(value, *plist));
2311 }
2312
2313 int
2314 external_remprop(Lisp_Object * plist, Lisp_Object property,
2315                  int laxp, Error_behavior errb)
2316 {
2317         Lisp_Object *tortoise = plist;
2318         Lisp_Object *hare = plist;
2319
2320         while (!NILP(*tortoise)) {
2321                 Lisp_Object *tortsave = tortoise;
2322                 Lisp_Object retval;
2323
2324                 /* See above */
2325                 if (!advance_plist_pointers
2326                     (plist, &tortoise, &hare, errb, &retval))
2327                         return 0;
2328
2329                 if (!laxp ? EQ(XCAR(*tortsave), property)
2330                     : internal_equal(XCAR(*tortsave), property, 0)) {
2331                         /* Now you see why it's so convenient to have that level
2332                            of indirection. */
2333                         *tortsave = XCDR(XCDR(*tortsave));
2334                         return 1;
2335                 }
2336         }
2337
2338         return 0;
2339 }
2340
2341 DEFUN("plist-get", Fplist_get, 2, 3, 0, /*
2342 Extract a value from a property list.
2343 PLIST is a property list, which is a list of the form
2344 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
2345 PROPERTY is usually a symbol.
2346 This function returns the value corresponding to the PROPERTY,
2347 or DEFAULT if PROPERTY is not one of the properties on the list.
2348 */
2349       (plist, property, default_))
2350 {
2351         Lisp_Object value = external_plist_get(&plist, property, 0, ERROR_ME);
2352         return UNBOUNDP(value) ? default_ : value;
2353 }
2354
2355 DEFUN("plist-put", Fplist_put, 3, 3, 0, /*
2356 Change value in PLIST of PROPERTY to VALUE.
2357 PLIST is a property list, which is a list of the form
2358 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2359 PROPERTY is usually a symbol and VALUE is any object.
2360 If PROPERTY is already a property on the list, its value is set to VALUE,
2361 otherwise the new PROPERTY VALUE pair is added.
2362 The new plist is returned; use `(setq x (plist-put x property value))'
2363 to be sure to use the new value.  PLIST is modified by side effect.
2364 */
2365       (plist, property, value))
2366 {
2367         external_plist_put(&plist, property, value, 0, ERROR_ME);
2368         return plist;
2369 }
2370
2371 DEFUN("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2372 Remove from PLIST the property PROPERTY and its value.
2373 PLIST is a property list, which is a list of the form
2374 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2375 PROPERTY is usually a symbol.
2376 The new plist is returned; use `(setq x (plist-remprop x property))'
2377 to be sure to use the new value.  PLIST is modified by side effect.
2378 */
2379       (plist, property))
2380 {
2381         external_remprop(&plist, property, 0, ERROR_ME);
2382         return plist;
2383 }
2384
2385 DEFUN("plist-member", Fplist_member, 2, 2, 0,   /*
2386 Return t if PROPERTY has a value specified in PLIST.
2387 */
2388       (plist, property))
2389 {
2390         Lisp_Object value = Fplist_get(plist, property, Qunbound);
2391         return UNBOUNDP(value) ? Qnil : Qt;
2392 }
2393
2394 DEFUN("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2395 Given a plist, signal an error if there is anything wrong with it.
2396 This means that it's a malformed or circular plist.
2397 */
2398       (plist))
2399 {
2400         Lisp_Object *tortoise;
2401         Lisp_Object *hare;
2402
2403       start_over:
2404         tortoise = &plist;
2405         hare = &plist;
2406         while (!NILP(*tortoise)) {
2407                 Lisp_Object retval;
2408
2409                 /* See above */
2410                 if (!advance_plist_pointers(&plist, &tortoise, &hare, ERROR_ME,
2411                                             &retval))
2412                         goto start_over;
2413         }
2414
2415         return Qnil;
2416 }
2417
2418 DEFUN("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2419 Given a plist, return non-nil if its format is correct.
2420 If it returns nil, `check-valid-plist' will signal an error when given
2421 the plist; that means it's a malformed or circular plist.
2422 */
2423       (plist))
2424 {
2425         Lisp_Object *tortoise;
2426         Lisp_Object *hare;
2427
2428         tortoise = &plist;
2429         hare = &plist;
2430         while (!NILP(*tortoise)) {
2431                 Lisp_Object retval;
2432
2433                 /* See above */
2434                 if (!advance_plist_pointers
2435                     (&plist, &tortoise, &hare, ERROR_ME_NOT, &retval))
2436                         return Qnil;
2437         }
2438
2439         return Qt;
2440 }
2441
2442 DEFUN("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0,       /*
2443 Destructively remove any duplicate entries from a plist.
2444 In such cases, the first entry applies.
2445
2446 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2447 a nil value is removed.  This feature is a virus that has infected
2448 old Lisp implementations, but should not be used except for backward
2449 compatibility.
2450
2451 The new plist is returned.  If NIL-MEANS-NOT-PRESENT is given, the
2452 return value may not be EQ to the passed-in value, so make sure to
2453 `setq' the value back into where it came from.
2454 */
2455       (plist, nil_means_not_present))
2456 {
2457         Lisp_Object head = plist;
2458
2459         Fcheck_valid_plist(plist);
2460
2461         while (!NILP(plist)) {
2462                 Lisp_Object prop = Fcar(plist);
2463                 Lisp_Object next = Fcdr(plist);
2464
2465                 CHECK_CONS(next);       /* just make doubly sure we catch any errors */
2466                 if (!NILP(nil_means_not_present) && NILP(Fcar(next))) {
2467                         if (EQ(head, plist))
2468                                 head = Fcdr(next);
2469                         plist = Fcdr(next);
2470                         continue;
2471                 }
2472                 /* external_remprop returns 1 if it removed any property.
2473                    We have to loop till it didn't remove anything, in case
2474                    the property occurs many times. */
2475                 while (external_remprop(&XCDR(next), prop, 0, ERROR_ME))
2476                         DO_NOTHING;
2477                 plist = Fcdr(next);
2478         }
2479
2480         return head;
2481 }
2482
2483 DEFUN("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2484 Extract a value from a lax property list.
2485 LAX-PLIST is a lax property list, which is a list of the form
2486 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2487 properties is done using `equal' instead of `eq'.
2488 PROPERTY is usually a symbol.
2489 This function returns the value corresponding to PROPERTY,
2490 or DEFAULT if PROPERTY is not one of the properties on the list.
2491 */
2492       (lax_plist, property, default_))
2493 {
2494         Lisp_Object value =
2495             external_plist_get(&lax_plist, property, 1, ERROR_ME);
2496         return UNBOUNDP(value) ? default_ : value;
2497 }
2498
2499 DEFUN("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2500 Change value in LAX-PLIST of PROPERTY to VALUE.
2501 LAX-PLIST is a lax property list, which is a list of the form
2502 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2503 properties is done using `equal' instead of `eq'.
2504 PROPERTY is usually a symbol and VALUE is any object.
2505 If PROPERTY is already a property on the list, its value is set to
2506 VALUE, otherwise the new PROPERTY VALUE pair is added.
2507 The new plist is returned; use `(setq x (lax-plist-put x property value))'
2508 to be sure to use the new value.  LAX-PLIST is modified by side effect.
2509 */
2510       (lax_plist, property, value))
2511 {
2512         external_plist_put(&lax_plist, property, value, 1, ERROR_ME);
2513         return lax_plist;
2514 }
2515
2516 DEFUN("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2517 Remove from LAX-PLIST the property PROPERTY and its value.
2518 LAX-PLIST is a lax property list, which is a list of the form
2519 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2520 properties is done using `equal' instead of `eq'.
2521 PROPERTY is usually a symbol.
2522 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
2523 to be sure to use the new value.  LAX-PLIST is modified by side effect.
2524 */
2525       (lax_plist, property))
2526 {
2527         external_remprop(&lax_plist, property, 1, ERROR_ME);
2528         return lax_plist;
2529 }
2530
2531 DEFUN("lax-plist-member", Flax_plist_member, 2, 2, 0,   /*
2532 Return t if PROPERTY has a value specified in LAX-PLIST.
2533 LAX-PLIST is a lax property list, which is a list of the form
2534 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2535 properties is done using `equal' instead of `eq'.
2536 */
2537       (lax_plist, property))
2538 {
2539         return UNBOUNDP(Flax_plist_get(lax_plist, property, Qunbound)) ? Qnil :
2540             Qt;
2541 }
2542
2543 DEFUN("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0,       /*
2544 Destructively remove any duplicate entries from a lax plist.
2545 In such cases, the first entry applies.
2546
2547 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2548 a nil value is removed.  This feature is a virus that has infected
2549 old Lisp implementations, but should not be used except for backward
2550 compatibility.
2551
2552 The new plist is returned.  If NIL-MEANS-NOT-PRESENT is given, the
2553 return value may not be EQ to the passed-in value, so make sure to
2554 `setq' the value back into where it came from.
2555 */
2556       (lax_plist, nil_means_not_present))
2557 {
2558         Lisp_Object head = lax_plist;
2559
2560         Fcheck_valid_plist(lax_plist);
2561
2562         while (!NILP(lax_plist)) {
2563                 Lisp_Object prop = Fcar(lax_plist);
2564                 Lisp_Object next = Fcdr(lax_plist);
2565
2566                 CHECK_CONS(next);       /* just make doubly sure we catch any errors */
2567                 if (!NILP(nil_means_not_present) && NILP(Fcar(next))) {
2568                         if (EQ(head, lax_plist))
2569                                 head = Fcdr(next);
2570                         lax_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, 1, ERROR_ME))
2577                         DO_NOTHING;
2578                 lax_plist = Fcdr(next);
2579         }
2580
2581         return head;
2582 }
2583
2584 /* In C because the frame props stuff uses it */
2585
2586 DEFUN("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0,       /*
2587 Convert association list ALIST into the equivalent property-list form.
2588 The plist is returned.  This converts from
2589
2590 \((a . 1) (b . 2) (c . 3))
2591
2592 into
2593
2594 \(a 1 b 2 c 3)
2595
2596 The original alist is destroyed in the process of constructing the plist.
2597 See also `alist-to-plist'.
2598 */
2599       (alist))
2600 {
2601         Lisp_Object head = alist;
2602         while (!NILP(alist)) {
2603                 /* remember the alist element. */
2604                 Lisp_Object el = Fcar(alist);
2605
2606                 Fsetcar(alist, Fcar(el));
2607                 Fsetcar(el, Fcdr(el));
2608                 Fsetcdr(el, Fcdr(alist));
2609                 Fsetcdr(alist, el);
2610                 alist = Fcdr(Fcdr(alist));
2611         }
2612
2613         return head;
2614 }
2615
2616 DEFUN("get", Fget, 2, 3, 0,     /*
2617 Return the value of OBJECT's PROPERTY property.
2618 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2619 If there is no such property, return optional third arg DEFAULT
2620 \(which defaults to `nil').  OBJECT can be a symbol, string, extent,
2621 face, or glyph.  See also `put', `remprop', and `object-plist'.
2622 */
2623       (object, property, default_))
2624 {
2625         /* Various places in emacs call Fget() and expect it not to quit,
2626            so don't quit. */
2627         Lisp_Object val;
2628
2629         if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->getprop)
2630                 val =
2631                     XRECORD_LHEADER_IMPLEMENTATION(object)->getprop(object,
2632                                                                     property);
2633         else
2634                 signal_simple_error("Object type has no properties", object);
2635
2636         return UNBOUNDP(val) ? default_ : val;
2637 }
2638
2639 DEFUN("put", Fput, 3, 3, 0,     /*
2640 Set OBJECT's PROPERTY to VALUE.
2641 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2642 OBJECT can be a symbol, face, extent, or string.
2643 For a string, no properties currently have predefined meanings.
2644 For the predefined properties for extents, see `set-extent-property'.
2645 For the predefined properties for faces, see `set-face-property'.
2646 See also `get', `remprop', and `object-plist'.
2647 */
2648       (object, property, value))
2649 {
2650         CHECK_LISP_WRITEABLE(object);
2651
2652         if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->putprop) {
2653                 if (!XRECORD_LHEADER_IMPLEMENTATION(object)->putprop
2654                     (object, property, value))
2655                         signal_simple_error("Can't set property on object",
2656                                             property);
2657         } else
2658                 signal_simple_error("Object type has no settable properties",
2659                                     object);
2660
2661         return value;
2662 }
2663
2664 DEFUN("remprop", Fremprop, 2, 2, 0,     /*
2665 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2666 OBJECT can be a symbol, string, extent, face, or glyph.  Return non-nil
2667 if the property list was actually modified (i.e. if PROPERTY was present
2668 in the property list).  See also `get', `put', and `object-plist'.
2669 */
2670       (object, property))
2671 {
2672         int ret = 0;
2673
2674         CHECK_LISP_WRITEABLE(object);
2675
2676         if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->remprop) {
2677                 ret =
2678                     XRECORD_LHEADER_IMPLEMENTATION(object)->remprop(object,
2679                                                                     property);
2680                 if (ret == -1)
2681                         signal_simple_error("Can't remove property from object",
2682                                             property);
2683         } else
2684                 signal_simple_error("Object type has no removable properties",
2685                                     object);
2686
2687         return ret ? Qt : Qnil;
2688 }
2689
2690 DEFUN("object-plist", Fobject_plist, 1, 1, 0,   /*
2691 Return a property list of OBJECT's properties.
2692 For a symbol, this is equivalent to `symbol-plist'.
2693 OBJECT can be a symbol, string, extent, face, or glyph.
2694 Do not modify the returned property list directly;
2695 this may or may not have the desired effects.  Use `put' instead.
2696 */
2697       (object))
2698 {
2699         if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->plist)
2700                 return XRECORD_LHEADER_IMPLEMENTATION(object)->plist(object);
2701         else
2702                 signal_simple_error("Object type has no properties", object);
2703
2704         return Qnil;
2705 }
2706 \f
2707 int internal_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2708 {
2709         if (depth > 200)
2710                 error("Stack overflow in equal");
2711         QUIT;
2712         if (EQ_WITH_EBOLA_NOTICE(obj1, obj2))
2713                 return 1;
2714         /* Note that (equal 20 20.0) should be nil */
2715         if (XTYPE(obj1) != XTYPE(obj2))
2716                 return 0;
2717         if (LRECORDP(obj1)) {
2718                 const struct lrecord_implementation
2719                 *imp1 = XRECORD_LHEADER_IMPLEMENTATION(obj1),
2720                     *imp2 = XRECORD_LHEADER_IMPLEMENTATION(obj2);
2721
2722                 return (imp1 == imp2) &&
2723                     /* EQ-ness of the objects was noticed above */
2724                     (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2725         }
2726
2727         return 0;
2728 }
2729
2730 int
2731 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2732 {
2733         if (depth > 200)
2734                 error ("Stack overflow in equalp");
2735         QUIT;
2736         if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2737                 return 1;
2738
2739         if (NUMBERP(obj1) && NUMBERP(obj2)) {
2740                 return ent_binrel(ASE_BINARY_REL_EQUALP, obj1, obj2);
2741         }
2742
2743         if (CHARP(obj1) && CHARP(obj2))
2744                 return XCHAR(obj1) == XCHAR(obj2);
2745         if (XTYPE(obj1) != XTYPE(obj2))
2746                 return 0;
2747         if (LRECORDP(obj1)) {
2748                 const struct lrecord_implementation
2749                         *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2750                         *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2751
2752                 /* #### not yet implemented properly, needs another flag to specify
2753                    equalp-ness */
2754                 return (imp1 == imp2) &&
2755                         /* EQ-ness of the objects was noticed above */
2756                         (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2757         }
2758
2759         return 0;
2760 }
2761
2762
2763 /* Note that we may be calling sub-objects that will use
2764    internal_equal() (instead of internal_old_equal()).  Oh well.
2765    We will get an Ebola note if there's any possibility of confusion,
2766    but that seems unlikely. */
2767
2768 static int internal_old_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2769 {
2770         if (depth > 200)
2771                 error("Stack overflow in equal");
2772         QUIT;
2773         if (HACKEQ_UNSAFE(obj1, obj2))
2774                 return 1;
2775         /* Note that (equal 20 20.0) should be nil */
2776         if (XTYPE(obj1) != XTYPE(obj2))
2777                 return 0;
2778
2779         return internal_equal(obj1, obj2, depth);
2780 }
2781
2782 DEFUN("equal", Fequal, 2, 2, 0, /*
2783 Return t if two Lisp objects have similar structure and contents.
2784 They must have the same data type.
2785 Conses are compared by comparing the cars and the cdrs.
2786 Vectors and strings are compared element by element.
2787 Numbers are compared by value.  Symbols must match exactly.
2788 */
2789       (object1, object2))
2790 {
2791         return internal_equal(object1, object2, 0) ? Qt : Qnil;
2792 }
2793
2794 DEFUN("old-equal", Fold_equal, 2, 2, 0, /*
2795 Return t if two Lisp objects have similar structure and contents.
2796 They must have the same data type.
2797 \(Note, however, that an exception is made for characters and integers;
2798 this is known as the "char-int confoundance disease." See `eq' and
2799 `old-eq'.)
2800 This function is provided only for byte-code compatibility with v19.
2801 Do not use it.
2802 */
2803       (object1, object2))
2804 {
2805         return internal_old_equal(object1, object2, 0) ? Qt : Qnil;
2806 }
2807 \f
2808 DEFUN("fillarray", Ffillarray, 2, 2, 0, /*
2809 Destructively modify ARRAY by replacing each element with ITEM.
2810 ARRAY is a vector, bit vector, or string.
2811 */
2812       (array, item))
2813 {
2814       retry:
2815         if (STRINGP(array)) {
2816                 Lisp_String *s = XSTRING(array);
2817                 Bytecount old_bytecount = string_length(s);
2818                 Bytecount new_bytecount;
2819                 Bytecount item_bytecount;
2820                 Bufbyte item_buf[MAX_EMCHAR_LEN];
2821                 Bufbyte *p;
2822                 Bufbyte *end;
2823
2824                 CHECK_CHAR_COERCE_INT(item);
2825                 CHECK_LISP_WRITEABLE(array);
2826
2827                 item_bytecount = set_charptr_emchar(item_buf, XCHAR(item));
2828                 new_bytecount = item_bytecount * string_char_length(s);
2829
2830                 resize_string(s, -1, new_bytecount - old_bytecount);
2831
2832                 for (p = string_data(s), end = p + new_bytecount;
2833                      p < end; p += item_bytecount)
2834                         memcpy(p, item_buf, item_bytecount);
2835                 *p = '\0';
2836
2837                 bump_string_modiff(array);
2838         } else if (VECTORP(array)) {
2839                 Lisp_Object *p = XVECTOR_DATA(array);
2840                 size_t len = XVECTOR_LENGTH(array);
2841                 CHECK_LISP_WRITEABLE(array);
2842                 while (len--)
2843                         *p++ = item;
2844         } else if (BIT_VECTORP(array)) {
2845                 Lisp_Bit_Vector *v = XBIT_VECTOR(array);
2846                 size_t len = bit_vector_length(v);
2847                 int bit;
2848                 CHECK_BIT(item);
2849                 bit = XINT(item);
2850                 CHECK_LISP_WRITEABLE(array);
2851                 while (len--)
2852                         set_bit_vector_bit(v, len, bit);
2853         } else {
2854                 array = wrong_type_argument(Qarrayp, array);
2855                 goto retry;
2856         }
2857         return array;
2858 }
2859
2860 Lisp_Object nconc2(Lisp_Object arg1, Lisp_Object arg2)
2861 {
2862         Lisp_Object args[2] = {arg1, arg2};
2863         struct gcpro gcpro1;
2864
2865         GCPROn(args, countof(args));
2866         RETURN_UNGCPRO(bytecode_nconc2(args));
2867 }
2868
2869 Lisp_Object bytecode_nconc2(Lisp_Object * args)
2870 {
2871       retry:
2872
2873         if (CONSP(args[0])) {
2874                 /* (setcdr (last args[0]) args[1]) */
2875                 Lisp_Object tortoise, hare;
2876                 size_t count;
2877
2878                 for (hare = tortoise = args[0], count = 0;
2879                      CONSP(XCDR(hare)); hare = XCDR(hare), count++) {
2880                         if (count < CIRCULAR_LIST_SUSPICION_LENGTH)
2881                                 continue;
2882
2883                         if (count & 1)
2884                                 tortoise = XCDR(tortoise);
2885                         if (EQ(hare, tortoise))
2886                                 signal_circular_list_error(args[0]);
2887                 }
2888                 XCDR(hare) = args[1];
2889                 return args[0];
2890         } else if (NILP(args[0])) {
2891                 return args[1];
2892         } else {
2893                 args[0] = wrong_type_argument(args[0], Qlistp);
2894                 goto retry;
2895         }
2896 }
2897
2898 DEFUN("nconc", Fnconc, 0, MANY, 0,      /*
2899 Concatenate any number of lists by altering them.
2900 Only the last argument is not altered, and need not be a list.
2901 Also see: `append'.
2902 If the first argument is nil, there is no way to modify it by side
2903 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2904 changing the value of `foo'.
2905 */
2906       (int nargs, Lisp_Object * args))
2907 {
2908         int argnum = 0;
2909         struct gcpro gcpro1;
2910
2911         /* The modus operandi in Emacs is "caller gc-protects args".
2912            However, nconc (particularly nconc2 ()) is called many times
2913            in Emacs on freshly created stuff (e.g. you see the idiom
2914            nconc2 (Fcopy_sequence (foo), bar) a lot).  So we help those
2915            callers out by protecting the args ourselves to save them
2916            a lot of temporary-variable grief. */
2917
2918         GCPROn(args, nargs);
2919
2920         while (argnum < nargs) {
2921                 Lisp_Object val;
2922         retry:
2923                 val = args[argnum];
2924                 if (CONSP(val)) {
2925                         /* `val' is the first cons, which will be our return
2926                          * value.
2927                          * `last_cons' will be the cons cell to mutate.  */
2928                         Lisp_Object last_cons = val;
2929                         Lisp_Object tortoise = val;
2930
2931                         for (argnum++; argnum < nargs; argnum++) {
2932                                 Lisp_Object next = args[argnum];
2933                               retry_next:
2934                                 if (CONSP(next) || argnum == nargs - 1) {
2935                                         /* (setcdr (last val) next) */
2936                                         size_t count;
2937
2938                                         for (count = 0;
2939                                              CONSP(XCDR(last_cons));
2940                                              last_cons =
2941                                              XCDR(last_cons), count++) {
2942                                                 if (count <
2943                                                     CIRCULAR_LIST_SUSPICION_LENGTH)
2944                                                         continue;
2945
2946                                                 if (count & 1)
2947                                                         tortoise =
2948                                                             XCDR(tortoise);
2949                                                 if (EQ(last_cons, tortoise))
2950                                                         signal_circular_list_error
2951                                                             (args[argnum - 1]);
2952                                         }
2953                                         XCDR(last_cons) = next;
2954                                 } else if (NILP(next)) {
2955                                         continue;
2956                                 } else {
2957                                         next =
2958                                             wrong_type_argument(Qlistp, next);
2959                                         goto retry_next;
2960                                 }
2961                         }
2962                         RETURN_UNGCPRO(val);
2963                 } else if (NILP(val))
2964                         argnum++;
2965                 else if (argnum == nargs - 1)   /* last arg? */
2966                         RETURN_UNGCPRO(val);
2967                 else {
2968                         args[argnum] = wrong_type_argument(Qlistp, val);
2969                         goto retry;
2970                 }
2971         }
2972         RETURN_UNGCPRO(Qnil);   /* No non-nil args provided. */
2973 }
2974
2975 \f
2976 DEFUN("replace-list", Freplace_list, 2, 2, 0,   /*
2977 Destructively replace the list OLD with NEW.
2978 This is like (copy-sequence NEW) except that it reuses the
2979 conses in OLD as much as possible.  If OLD and NEW are the same
2980 length, no consing will take place.
2981 */
2982       (old, new))
2983 {
2984         Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
2985
2986         EXTERNAL_LIST_LOOP(tail, new) {
2987                 if (!NILP(oldtail)) {
2988                         CHECK_CONS(oldtail);
2989                         XCAR(oldtail) = XCAR(tail);
2990                 } else if (!NILP(prevoldtail)) {
2991                         XCDR(prevoldtail) = Fcons(XCAR(tail), Qnil);
2992                         prevoldtail = XCDR(prevoldtail);
2993                 } else
2994                         old = oldtail = Fcons(XCAR(tail), Qnil);
2995
2996                 if (!NILP(oldtail)) {
2997                         prevoldtail = oldtail;
2998                         oldtail = XCDR(oldtail);
2999                 }
3000         }
3001
3002         if (!NILP(prevoldtail))
3003                 XCDR(prevoldtail) = Qnil;
3004         else
3005                 old = Qnil;
3006
3007         return old;
3008 }
3009 \f
3010 /* #### this function doesn't belong in this file! */
3011
3012 #ifdef HAVE_GETLOADAVG
3013 #ifdef HAVE_SYS_LOADAVG_H
3014 #include <sys/loadavg.h>
3015 #endif
3016 #else
3017 int getloadavg(double loadavg[], int nelem);    /* Defined in getloadavg.c */
3018 #endif
3019
3020 DEFUN("load-average", Fload_average, 0, 1, 0,   /*
3021 Return list of 1 minute, 5 minute and 15 minute load averages.
3022 Each of the three load averages is multiplied by 100,
3023 then converted to integer.
3024
3025 When USE-FLOATS is non-nil, floats will be used instead of integers.
3026 These floats are not multiplied by 100.
3027
3028 If the 5-minute or 15-minute load averages are not available, return a
3029 shortened list, containing only those averages which are available.
3030
3031 On some systems, this won't work due to permissions on /dev/kmem,
3032 in which case you can't use this.
3033 */
3034       (use_floats))
3035 {
3036         double load_ave[3];
3037         int loads = getloadavg(load_ave, countof(load_ave));
3038         Lisp_Object ret = Qnil;
3039
3040         if (loads == -2)
3041                 error("load-average not implemented for this operating system");
3042         else if (loads < 0)
3043                 signal_simple_error("Could not get load-average",
3044                                     lisp_strerror(errno));
3045
3046         while (loads-- > 0) {
3047                 Lisp_Object load = (NILP(use_floats) ?
3048                                     make_int((int)(100.0 * load_ave[loads]))
3049                                     : make_float(load_ave[loads]));
3050                 ret = Fcons(load, ret);
3051         }
3052         return ret;
3053 }
3054 \f
3055 Lisp_Object Vfeatures;
3056
3057 DEFUN("featurep", Ffeaturep, 1, 1, 0,   /*
3058 Return non-nil if feature FEXP is present in this Emacs.
3059 Use this to conditionalize execution of lisp code based on the
3060 presence or absence of emacs or environment extensions.
3061 FEXP can be a symbol, a number, or a list.
3062 If it is a symbol, that symbol is looked up in the `features' variable,
3063 and non-nil will be returned if found.
3064 If it is a number, the function will return non-nil if this Emacs
3065 has an equal or greater version number than FEXP.
3066 If it is a list whose car is the symbol `and', it will return
3067 non-nil if all the features in its cdr are non-nil.
3068 If it is a list whose car is the symbol `or', it will return non-nil
3069 if any of the features in its cdr are non-nil.
3070 If it is a list whose car is the symbol `not', it will return
3071 non-nil if the feature is not present.
3072
3073 Examples:
3074
3075 (featurep 'sxemacs)
3076 => ; Non-nil on SXEmacs.
3077
3078 (featurep '(and sxemacs gnus))
3079 => ; Non-nil on SXEmacs with Gnus loaded.
3080
3081 (featurep '(or tty-frames (and emacs 19.30)))
3082 => ; Non-nil if this Emacs supports TTY frames.
3083
3084 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3085 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3086
3087 (featurep '(and xemacs 21.02))
3088 => ; Non-nil on XEmacs 21.2 and later.
3089
3090 NOTE: The advanced arguments of this function (anything other than a
3091 symbol) are not yet supported by FSF Emacs.  If you feel they are useful
3092 for supporting multiple Emacs variants, lobby Richard Stallman at
3093 <bug-gnu-emacs@gnu.org>.
3094 */
3095       (fexp))
3096 {
3097 #ifndef FEATUREP_SYNTAX
3098         CHECK_SYMBOL(fexp);
3099         return NILP(Fmemq(fexp, Vfeatures)) ? Qnil : Qt;
3100 #else                           /* FEATUREP_SYNTAX */
3101         static double featurep_emacs_version;
3102
3103         /* Brute force translation from Erik Naggum's lisp function. */
3104         if (SYMBOLP(fexp)) {
3105                 /* Original definition */
3106                 return NILP(Fmemq(fexp, Vfeatures)) ? Qnil : Qt;
3107         } else if (INTP(fexp) || FLOATP(fexp)) {
3108                 double d = extract_float(fexp);
3109
3110                 if (featurep_emacs_version == 0.0) {
3111                         featurep_emacs_version = XINT(Vemacs_major_version) +
3112                             (XINT(Vemacs_minor_version) / 100.0);
3113                 }
3114                 return featurep_emacs_version >= d ? Qt : Qnil;
3115         } else if (CONSP(fexp)) {
3116                 Lisp_Object tem = XCAR(fexp);
3117                 if (EQ(tem, Qnot)) {
3118                         Lisp_Object negate;
3119
3120                         tem = XCDR(fexp);
3121                         negate = Fcar(tem);
3122                         if (!NILP(tem))
3123                                 return NILP(call1(Qfeaturep, negate)) ? Qt :
3124                                     Qnil;
3125                         else
3126                                 return Fsignal(Qinvalid_read_syntax,
3127                                                list1(tem));
3128                 } else if (EQ(tem, Qand)) {
3129                         tem = XCDR(fexp);
3130                         /* Use Fcar/Fcdr for error-checking. */
3131                         while (!NILP(tem) && !NILP(call1(Qfeaturep, Fcar(tem)))) {
3132                                 tem = Fcdr(tem);
3133                         }
3134                         return NILP(tem) ? Qt : Qnil;
3135                 } else if (EQ(tem, Qor)) {
3136                         tem = XCDR(fexp);
3137                         /* Use Fcar/Fcdr for error-checking. */
3138                         while (!NILP(tem) && NILP(call1(Qfeaturep, Fcar(tem)))) {
3139                                 tem = Fcdr(tem);
3140                         }
3141                         return NILP(tem) ? Qnil : Qt;
3142                 } else {
3143                         return Fsignal(Qinvalid_read_syntax, list1(XCDR(fexp)));
3144                 }
3145         } else {
3146                 return Fsignal(Qinvalid_read_syntax, list1(fexp));
3147         }
3148 }
3149 #endif                          /* FEATUREP_SYNTAX */
3150
3151 DEFUN("provide", Fprovide, 1, 1, 0,     /*
3152 Announce that FEATURE is a feature of the current Emacs.
3153 This function updates the value of the variable `features'.
3154 */
3155       (feature))
3156 {
3157         Lisp_Object tem;
3158         CHECK_SYMBOL(feature);
3159         if (!NILP(Vautoload_queue))
3160                 Vautoload_queue =
3161                     Fcons(Fcons(Vfeatures, Qnil), Vautoload_queue);
3162         tem = Fmemq(feature, Vfeatures);
3163         if (NILP(tem))
3164                 Vfeatures = Fcons(feature, Vfeatures);
3165         LOADHIST_ATTACH(Fcons(Qprovide, feature));
3166         return feature;
3167 }
3168
3169 DEFUN("require", Frequire, 1, 3, 0, /*
3170 Ensure that FEATURE is present in the Lisp environment.
3171 FEATURE is a symbol naming a collection of resources (functions, etc).
3172 Optional FILENAME is a library from which to load resources; it defaults to
3173 the print name of FEATURE.
3174 Optional NOERROR, if non-nil, causes require to return nil rather than signal
3175 an error if loading the library fails.
3176
3177 If feature FEATURE is present in `features', update `load-history' to reflect
3178 the require and return FEATURE.  Otherwise, try to load it from a library.
3179 The normal messages at start and end of loading are suppressed.
3180 If the library is successfully loaded and it calls `(provide FEATURE)', add
3181 FEATURE to `features', update `load-history' and return FEATURE.
3182 If the load succeeds but FEATURE is not provided by the library, signal
3183 `invalid-state'.
3184
3185 The byte-compiler treats top-level calls to `require' specially, by evaluating
3186 them at compile time (and then compiling them normally).  Thus a library may
3187 request that definitions that should be inlined such as macros and defsubsts
3188 be loaded into its compilation environment.  Achieving this in other contexts
3189 requires an explicit \(eval-and-compile ...\) block.
3190                                      */
3191        (feature, filename, noerror))
3192 {
3193         Lisp_Object tem;
3194
3195         CHECK_SYMBOL(feature);
3196         tem = Fmemq(feature, Vfeatures);
3197         LOADHIST_ATTACH(Fcons(Qrequire, feature));
3198
3199         if (!NILP(tem)) {
3200                 return feature;
3201         } else {
3202                 int speccount = specpdl_depth();
3203
3204                 /* Value saved here is to be restored into Vautoload_queue */
3205                 record_unwind_protect(un_autoload, Vautoload_queue);
3206                 Vautoload_queue = Qt;
3207
3208                 tem = call4(Qload, NILP(filename) ? Fsymbol_name(feature) : filename,
3209                              noerror, Qrequire, Qnil);
3210                 /* If load failed entirely, return nil.  */
3211                 if (NILP(tem))
3212                         return unbind_to(speccount, Qnil);
3213
3214                 tem = Fmemq(feature, Vfeatures);
3215                 if (NILP(tem) && NILP(noerror)) {
3216                         signal_type_error(Qinvalid_state,
3217                                           "Required feature was not provided",
3218                                           feature);
3219                 } else if (!NILP(noerror)) {
3220                         return unbind_to(speccount, Qnil);
3221                 }
3222
3223                 /* Once loading finishes, don't undo it.  */
3224                 Vautoload_queue = Qt;
3225                 return unbind_to(speccount, feature);
3226         }
3227 }
3228
3229 DEFUN("revoke", Frevoke, 1, 1, 0,       /*
3230 Announce that FEATURE is no longer a feature of the current Emacs.
3231 */
3232       (feature))
3233 {
3234         CHECK_SYMBOL(feature);
3235         if (!NILP(Vautoload_queue))
3236                 Vautoload_queue =
3237                     Fcons(Fcons(Vfeatures, Qnil), Vautoload_queue);
3238
3239         if (LIKELY(CONSP(Vfeatures) && EQ(XCAR(Vfeatures), feature))) {
3240                 /* special case where feature is the head of 'features */
3241                 Vfeatures = XCDR(Vfeatures);
3242                 return feature;
3243         }
3244         for (Lisp_Object tmp = Vfeatures;
3245              CONSP(tmp) && CONSP(XCDR(tmp));
3246              tmp = XCDR(tmp)) {
3247                 if (EQ(XCAR(XCDR(tmp)), feature)) {
3248                         XCDR(tmp) = XCDR(XCDR(tmp));
3249                 }
3250                 return feature;
3251         }
3252         return Qnil;
3253 }
3254 \f
3255 /* base64 encode/decode functions.
3256
3257    Originally based on code from GNU recode.  Ported to FSF Emacs by
3258    Lars Magne Ingebrigtsen and Karl Heuer.  Ported to XEmacs and
3259    subsequently heavily hacked by Hrvoje Niksic.  */
3260
3261 #define MIME_LINE_LENGTH 72
3262
3263 #define IS_ASCII(Character) \
3264   ((Character) < 128)
3265 #define IS_BASE64(Character) \
3266   (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3267
3268 /* Table of characters coding the 64 values.  */
3269 static char base64_value_to_char[64] = {
3270         'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',       /*  0- 9 */
3271         'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',       /* 10-19 */
3272         'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd',       /* 20-29 */
3273         'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',       /* 30-39 */
3274         'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',       /* 40-49 */
3275         'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7',       /* 50-59 */
3276         '8', '9', '+', '/'      /* 60-63 */
3277 };
3278
3279 /* Table of base64 values for first 128 characters.  */
3280 static short base64_char_to_value[128] = {
3281         -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /*   0-  9 */
3282         -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /*  10- 19 */
3283         -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /*  20- 29 */
3284         -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /*  30- 39 */
3285         -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /*  40- 49 */
3286         54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /*  50- 59 */
3287         -1, -1, -1, -1, -1, 0, 1, 2, 3, 4,      /*  60- 69 */
3288         5, 6, 7, 8, 9, 10, 11, 12, 13, 14,      /*  70- 79 */
3289         15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /*  80- 89 */
3290         25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /*  90- 99 */
3291         29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3292         39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3293         49, 50, 51, -1, -1, -1, -1, -1  /* 120-127 */
3294 };
3295
3296 /* The following diagram shows the logical steps by which three octets
3297    get transformed into four base64 characters.
3298
3299                  .--------.  .--------.  .--------.
3300                  |aaaaaabb|  |bbbbcccc|  |ccdddddd|
3301                  `--------'  `--------'  `--------'
3302                     6   2      4   4       2   6
3303                .--------+--------+--------+--------.
3304                |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3305                `--------+--------+--------+--------'
3306
3307                .--------+--------+--------+--------.
3308                |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3309                `--------+--------+--------+--------'
3310
3311    The octets are divided into 6 bit chunks, which are then encoded into
3312    base64 characters.  */
3313
3314 #define ADVANCE_INPUT(c, stream)                                \
3315  ((ec = Lstream_get_emchar (stream)) == -1 ? 0 :                \
3316   ((ec > 255) ?                                                 \
3317    (signal_simple_error ("Non-ascii character in base64 input", \
3318                          make_char (ec)), 0)                    \
3319    : (c = (Bufbyte)ec), 1))
3320
3321 static Bytind base64_encode_1(Lstream * istream, Bufbyte * to, int line_break)
3322 {
3323         EMACS_INT counter = 0;
3324         Bufbyte *e = to;
3325         Emchar ec;
3326         unsigned int value;
3327
3328         while (1) {
3329                 Bufbyte c;
3330                 if (!ADVANCE_INPUT(c, istream))
3331                         break;
3332
3333                 /* Wrap line every 76 characters.  */
3334                 if (line_break) {
3335                         if (counter < MIME_LINE_LENGTH / 4)
3336                                 counter++;
3337                         else {
3338                                 *e++ = '\n';
3339                                 counter = 1;
3340                         }
3341                 }
3342
3343                 /* Process first byte of a triplet.  */
3344                 *e++ = base64_value_to_char[0x3f & c >> 2];
3345                 value = (0x03 & c) << 4;
3346
3347                 /* Process second byte of a triplet.  */
3348                 if (!ADVANCE_INPUT(c, istream)) {
3349                         *e++ = base64_value_to_char[value];
3350                         *e++ = '=';
3351                         *e++ = '=';
3352                         break;
3353                 }
3354
3355                 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3356                 value = (0x0f & c) << 2;
3357
3358                 /* Process third byte of a triplet.  */
3359                 if (!ADVANCE_INPUT(c, istream)) {
3360                         *e++ = base64_value_to_char[value];
3361                         *e++ = '=';
3362                         break;
3363                 }
3364
3365                 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3366                 *e++ = base64_value_to_char[0x3f & c];
3367         }
3368
3369         return e - to;
3370 }
3371
3372 #undef ADVANCE_INPUT
3373
3374 /* Get next character from the stream, except that non-base64
3375    characters are ignored.  This is in accordance with rfc2045.  EC
3376    should be an Emchar, so that it can hold -1 as the value for EOF.  */
3377 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do {      \
3378   ec = Lstream_get_emchar (stream);                                     \
3379   ++streampos;                                                          \
3380   /* IS_BASE64 may not be called with negative arguments so check for   \
3381      EOF first. */                                                      \
3382   if (ec < 0 || IS_BASE64 (ec) || ec == '=')                            \
3383     break;                                                              \
3384 } while (1)
3385
3386 #define STORE_BYTE(pos, val, ccnt) do {                                 \
3387   pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val)));      \
3388   ++ccnt;                                                               \
3389 } while (0)
3390
3391 static Bytind
3392 base64_decode_1(Lstream * istream, Bufbyte * to, Charcount * ccptr)
3393 {
3394         Charcount ccnt = 0;
3395         Bufbyte *e = to;
3396         EMACS_INT streampos = 0;
3397
3398         while (1) {
3399                 Emchar ec;
3400                 unsigned long value;
3401
3402                 /* Process first byte of a quadruplet.  */
3403                 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3404                 if (ec < 0)
3405                         break;
3406                 if (ec == '=')
3407                         signal_simple_error
3408                             ("Illegal `=' character while decoding base64",
3409                              make_int(streampos));
3410                 value = base64_char_to_value[ec] << 18;
3411
3412                 /* Process second byte of a quadruplet.  */
3413                 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3414                 if (ec < 0)
3415                         error("Premature EOF while decoding base64");
3416                 if (ec == '=')
3417                         signal_simple_error
3418                             ("Illegal `=' character while decoding base64",
3419                              make_int(streampos));
3420                 value |= base64_char_to_value[ec] << 12;
3421                 STORE_BYTE(e, value >> 16, ccnt);
3422
3423                 /* Process third byte of a quadruplet.  */
3424                 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3425                 if (ec < 0)
3426                         error("Premature EOF while decoding base64");
3427
3428                 if (ec == '=') {
3429                         ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3430                         if (ec < 0)
3431                                 error("Premature EOF while decoding base64");
3432                         if (ec != '=')
3433                                 signal_simple_error
3434                                     ("Padding `=' expected but not found while decoding base64",
3435                                      make_int(streampos));
3436                         continue;
3437                 }
3438
3439                 value |= base64_char_to_value[ec] << 6;
3440                 STORE_BYTE(e, 0xff & value >> 8, ccnt);
3441
3442                 /* Process fourth byte of a quadruplet.  */
3443                 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3444                 if (ec < 0)
3445                         error("Premature EOF while decoding base64");
3446                 if (ec == '=')
3447                         continue;
3448
3449                 value |= base64_char_to_value[ec];
3450                 STORE_BYTE(e, 0xff & value, ccnt);
3451         }
3452
3453         *ccptr = ccnt;
3454         return e - to;
3455 }
3456
3457 #undef ADVANCE_INPUT
3458 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3459 #undef STORE_BYTE
3460
3461 DEFUN("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3462 Base64-encode the region between START and END.
3463 Return the length of the encoded text.
3464 Optional third argument NO-LINE-BREAK means do not break long lines
3465 into shorter lines.
3466 */
3467       (start, end, no_line_break))
3468 {
3469         Bufbyte *encoded;
3470         Bytind encoded_length;
3471         Charcount allength, length;
3472         struct buffer *buf = current_buffer;
3473         Bufpos begv, zv, old_pt = BUF_PT(buf);
3474         Lisp_Object input;
3475         int speccount = specpdl_depth();
3476
3477         get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3478         barf_if_buffer_read_only(buf, begv, zv);
3479
3480         /* We need to allocate enough room for encoding the text.
3481            We need 33 1/3% more space, plus a newline every 76
3482            characters, and then we round up. */
3483         length = zv - begv;
3484         allength = length + length / 3 + 1;
3485         allength += allength / MIME_LINE_LENGTH + 1 + 6;
3486
3487         input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3488         /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3489            base64 characters will be single-byte.  */
3490         XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3491         encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3492                                          NILP(no_line_break));
3493         if (encoded_length > allength) {
3494                 abort();
3495         }
3496         Lstream_delete(XLSTREAM(input));
3497
3498         /* Now we have encoded the region, so we insert the new contents
3499            and delete the old.  (Insert first in order to preserve markers.)  */
3500         buffer_insert_raw_string_1(buf, begv, encoded, encoded_length, 0);
3501         XMALLOC_UNBIND(encoded, allength, speccount);
3502         buffer_delete_range(buf, begv + encoded_length, zv + encoded_length, 0);
3503
3504         /* Simulate FSF Emacs implementation of this function: if point was
3505            in the region, place it at the beginning.  */
3506         if (old_pt >= begv && old_pt < zv) {
3507                 BUF_SET_PT(buf, begv);
3508         }
3509
3510         /* We return the length of the encoded text. */
3511         return make_int(encoded_length);
3512 }
3513
3514 DEFUN("base64-encode-string", Fbase64_encode_string, 1, 2, 0,   /*
3515 Base64 encode STRING and return the result.
3516 Optional argument NO-LINE-BREAK means do not break long lines
3517 into shorter lines.
3518 */
3519       (string, no_line_break))
3520 {
3521         Charcount allength, length;
3522         Bytind encoded_length;
3523         Bufbyte *encoded;
3524         Lisp_Object input, result;
3525         int speccount = specpdl_depth();
3526
3527         CHECK_STRING(string);
3528
3529         length = XSTRING_CHAR_LENGTH(string);
3530         allength = length + length / 3 + 1;
3531         allength += allength / MIME_LINE_LENGTH + 1 + 6;
3532
3533         input = make_lisp_string_input_stream(string, 0, -1);
3534         XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3535         encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3536                                          NILP(no_line_break));
3537         if (encoded_length > allength) {
3538                 abort();
3539         }
3540         Lstream_delete(XLSTREAM(input));
3541         result = make_string(encoded, encoded_length);
3542         XMALLOC_UNBIND(encoded, allength, speccount);
3543         return result;
3544 }
3545
3546 DEFUN("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3547 Base64-decode the region between START and END.
3548 Return the length of the decoded text.
3549 If the region can't be decoded, return nil and don't modify the buffer.
3550 Characters out of the base64 alphabet are ignored.
3551 */
3552       (start, end))
3553 {
3554         struct buffer *buf = current_buffer;
3555         Bufpos begv, zv, old_pt = BUF_PT(buf);
3556         Bufbyte *decoded;
3557         Bytind decoded_length;
3558         Charcount length, cc_decoded_length;
3559         Lisp_Object input;
3560         int speccount = specpdl_depth();
3561
3562         get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3563         barf_if_buffer_read_only(buf, begv, zv);
3564
3565         length = zv - begv;
3566
3567         input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3568         /* We need to allocate enough room for decoding the text. */
3569         XMALLOC_ATOMIC_OR_ALLOCA(decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3570         decoded_length =
3571                 base64_decode_1(XLSTREAM(input), decoded, &cc_decoded_length);
3572         if (decoded_length > length * MAX_EMCHAR_LEN) {
3573                 abort();
3574         }
3575         Lstream_delete(XLSTREAM(input));
3576
3577         /* Now we have decoded the region, so we insert the new contents
3578            and delete the old.  (Insert first in order to preserve markers.)  */
3579         BUF_SET_PT(buf, begv);
3580         buffer_insert_raw_string_1(buf, begv, decoded, decoded_length, 0);
3581         XMALLOC_UNBIND(decoded, length * MAX_EMCHAR_LEN, speccount);
3582         buffer_delete_range(buf, begv + cc_decoded_length,
3583                             zv + cc_decoded_length, 0);
3584
3585         /* Simulate FSF Emacs implementation of this function: if point was
3586            in the region, place it at the beginning.  */
3587         if (old_pt >= begv && old_pt < zv) {
3588