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