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