Contents in 1999-06-04-13 of release-21-2.
[chise/xemacs-chise.git.1] / src / fns.c
1 /* Random utility Lisp functions.
2    Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3    Copyright (C) 1995, 1996 Ben Wing.
4
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, blen;
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   blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
893   val = make_string (XSTRING_DATA (string) + bfr, blen);
894   /* Copy any applicable extent information into the new string: */
895   copy_string_extents (val, string, 0, bfr, blen);
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_LISP_WRITEABLE (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_LISP_WRITEABLE (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   QUIT;
2790   if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2791     return 1;
2792   /* Note that (equal 20 20.0) should be nil */
2793   if (XTYPE (obj1) != XTYPE (obj2))
2794     return 0;
2795   if (LRECORDP (obj1))
2796     {
2797       CONST struct lrecord_implementation
2798         *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2799         *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2800
2801       return (imp1 == imp2) &&
2802         /* EQ-ness of the objects was noticed above */
2803         (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2804     }
2805
2806   return 0;
2807 }
2808
2809 /* Note that we may be calling sub-objects that will use
2810    internal_equal() (instead of internal_old_equal()).  Oh well.
2811    We will get an Ebola note if there's any possibility of confusion,
2812    but that seems unlikely. */
2813
2814 static int
2815 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2816 {
2817   if (depth > 200)
2818     error ("Stack overflow in equal");
2819   QUIT;
2820   if (HACKEQ_UNSAFE (obj1, obj2))
2821     return 1;
2822   /* Note that (equal 20 20.0) should be nil */
2823   if (XTYPE (obj1) != XTYPE (obj2))
2824     return 0;
2825
2826   return internal_equal (obj1, obj2, depth);
2827 }
2828
2829 DEFUN ("equal", Fequal, 2, 2, 0, /*
2830 Return t if two Lisp objects have similar structure and contents.
2831 They must have the same data type.
2832 Conses are compared by comparing the cars and the cdrs.
2833 Vectors and strings are compared element by element.
2834 Numbers are compared by value.  Symbols must match exactly.
2835 */
2836        (obj1, obj2))
2837 {
2838   return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2839 }
2840
2841 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2842 Return t if two Lisp objects have similar structure and contents.
2843 They must have the same data type.
2844 \(Note, however, that an exception is made for characters and integers;
2845 this is known as the "char-int confoundance disease." See `eq' and
2846 `old-eq'.)
2847 This function is provided only for byte-code compatibility with v19.
2848 Do not use it.
2849 */
2850        (obj1, obj2))
2851 {
2852   return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2853 }
2854
2855 \f
2856 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2857 Store each element of ARRAY with ITEM.
2858 ARRAY is a vector, bit vector, or string.
2859 */
2860        (array, item))
2861 {
2862  retry:
2863   if (STRINGP (array))
2864     {
2865       Emchar charval;
2866       struct Lisp_String *s = XSTRING (array);
2867       Charcount len = string_char_length (s);
2868       Charcount i;
2869       CHECK_CHAR_COERCE_INT (item);
2870       CHECK_LISP_WRITEABLE (array);
2871       charval = XCHAR (item);
2872       for (i = 0; i < len; i++)
2873         set_string_char (s, i, charval);
2874       bump_string_modiff (array);
2875     }
2876   else if (VECTORP (array))
2877     {
2878       Lisp_Object *p = XVECTOR_DATA (array);
2879       int len = XVECTOR_LENGTH (array);
2880       CHECK_LISP_WRITEABLE (array);
2881       while (len--)
2882         *p++ = item;
2883     }
2884   else if (BIT_VECTORP (array))
2885     {
2886       struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2887       int len = bit_vector_length (v);
2888       int bit;
2889       CHECK_BIT (item);
2890       CHECK_LISP_WRITEABLE (array);
2891       bit = XINT (item);
2892       while (len--)
2893         set_bit_vector_bit (v, len, bit);
2894     }
2895   else
2896     {
2897       array = wrong_type_argument (Qarrayp, array);
2898       goto retry;
2899     }
2900   return array;
2901 }
2902
2903 Lisp_Object
2904 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2905 {
2906   Lisp_Object args[2];
2907   struct gcpro gcpro1;
2908   args[0] = arg1;
2909   args[1] = arg2;
2910
2911   GCPRO1 (args[0]);
2912   gcpro1.nvars = 2;
2913
2914   RETURN_UNGCPRO (bytecode_nconc2 (args));
2915 }
2916
2917 Lisp_Object
2918 bytecode_nconc2 (Lisp_Object *args)
2919 {
2920  retry:
2921
2922   if (CONSP (args[0]))
2923     {
2924       /* (setcdr (last args[0]) args[1]) */
2925       Lisp_Object tortoise, hare;
2926       int count;
2927
2928       for (hare = tortoise = args[0], count = 0;
2929            CONSP (XCDR (hare));
2930            hare = XCDR (hare), count++)
2931         {
2932           if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2933
2934           if (count & 1)
2935             tortoise = XCDR (tortoise);
2936           if (EQ (hare, tortoise))
2937             signal_circular_list_error (args[0]);
2938         }
2939       XCDR (hare) = args[1];
2940       return args[0];
2941     }
2942   else if (NILP (args[0]))
2943     {
2944       return args[1];
2945     }
2946   else
2947     {
2948       args[0] = wrong_type_argument (args[0], Qlistp);
2949       goto retry;
2950     }
2951 }
2952
2953 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2954 Concatenate any number of lists by altering them.
2955 Only the last argument is not altered, and need not be a list.
2956 Also see: `append'.
2957 If the first argument is nil, there is no way to modify it by side
2958 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2959 changing the value of `foo'.
2960 */
2961        (int nargs, Lisp_Object *args))
2962 {
2963   int argnum = 0;
2964   struct gcpro gcpro1;
2965
2966   /* The modus operandi in Emacs is "caller gc-protects args".
2967      However, nconc (particularly nconc2 ()) is called many times
2968      in Emacs on freshly created stuff (e.g. you see the idiom
2969      nconc2 (Fcopy_sequence (foo), bar) a lot).  So we help those
2970      callers out by protecting the args ourselves to save them
2971      a lot of temporary-variable grief. */
2972
2973   GCPRO1 (args[0]);
2974   gcpro1.nvars = nargs;
2975
2976   while (argnum < nargs)
2977     {
2978       Lisp_Object val;
2979     retry:
2980       val = args[argnum];
2981       if (CONSP (val))
2982         {
2983           /* `val' is the first cons, which will be our return value.  */
2984           /* `last_cons' will be the cons cell to mutate.  */
2985           Lisp_Object last_cons = val;
2986           Lisp_Object tortoise = val;
2987
2988           for (argnum++; argnum < nargs; argnum++)
2989             {
2990               Lisp_Object next = args[argnum];
2991             retry_next:
2992               if (CONSP (next) || argnum == nargs -1)
2993                 {
2994                   /* (setcdr (last val) next) */
2995                   int count;
2996
2997                   for (count = 0;
2998                        CONSP (XCDR (last_cons));
2999                        last_cons = XCDR (last_cons), count++)
3000                     {
3001                       if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3002
3003                       if (count & 1)
3004                         tortoise = XCDR (tortoise);
3005                       if (EQ (last_cons, tortoise))
3006                         signal_circular_list_error (args[argnum-1]);
3007                     }
3008                   XCDR (last_cons) = next;
3009                 }
3010               else if (NILP (next))
3011                 {
3012                   continue;
3013                 }
3014               else
3015                 {
3016                   next = wrong_type_argument (Qlistp, next);
3017                   goto retry_next;
3018                 }
3019             }
3020           RETURN_UNGCPRO (val);
3021         }
3022       else if (NILP (val))
3023         argnum++;
3024       else if (argnum == nargs - 1) /* last arg? */
3025         RETURN_UNGCPRO (val);
3026       else
3027         {
3028           args[argnum] = wrong_type_argument (Qlistp, val);
3029           goto retry;
3030         }
3031     }
3032   RETURN_UNGCPRO (Qnil);  /* No non-nil args provided. */
3033 }
3034
3035 \f
3036 /* This is the guts of all mapping functions.
3037    Apply fn to each element of seq, one by one,
3038    storing the results into elements of vals, a C vector of Lisp_Objects.
3039    leni is the length of vals, which should also be the length of seq.
3040
3041    If VALS is a null pointer, do not accumulate the results. */
3042
3043 static void
3044 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3045 {
3046   Lisp_Object result;
3047   Lisp_Object args[2];
3048   int i;
3049   struct gcpro gcpro1;
3050
3051   if (vals)
3052     {
3053       GCPRO1 (vals[0]);
3054       gcpro1.nvars = 0;
3055     }
3056
3057   args[0] = fn;
3058
3059   if (LISTP (seq))
3060     {
3061       for (i = 0; i < leni; i++)
3062         {
3063           args[1] = XCAR (seq);
3064           seq = XCDR (seq);
3065           result = Ffuncall (2, args);
3066           if (vals) vals[gcpro1.nvars++] = result;
3067         }
3068     }
3069   else if (VECTORP (seq))
3070     {
3071       Lisp_Object *objs = XVECTOR_DATA (seq);
3072       for (i = 0; i < leni; i++)
3073         {
3074           args[1] = *objs++;
3075           result = Ffuncall (2, args);
3076           if (vals) vals[gcpro1.nvars++] = result;
3077         }
3078     }
3079   else if (STRINGP (seq))
3080     {
3081       Bufbyte *p = XSTRING_DATA (seq);
3082       for (i = 0; i < leni; i++)
3083         {
3084           args[1] = make_char (charptr_emchar (p));
3085           INC_CHARPTR (p);
3086           result = Ffuncall (2, args);
3087           if (vals) vals[gcpro1.nvars++] = result;
3088         }
3089     }
3090   else if (BIT_VECTORP (seq))
3091     {
3092       struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3093       for (i = 0; i < leni; i++)
3094         {
3095           args[1] = make_int (bit_vector_bit (v, i));
3096           result = Ffuncall (2, args);
3097           if (vals) vals[gcpro1.nvars++] = result;
3098         }
3099     }
3100   else
3101     abort(); /* cannot get here since Flength(seq) did not get an error */
3102
3103   if (vals)
3104     UNGCPRO;
3105 }
3106
3107 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3108 Apply FN to each element of SEQ, and concat the results as strings.
3109 In between each pair of results, stick in SEP.
3110 Thus, " " as SEP results in spaces between the values returned by FN.
3111 */
3112        (fn, seq, sep))
3113 {
3114   size_t len = XINT (Flength (seq));
3115   Lisp_Object *args;
3116   int i;
3117   struct gcpro gcpro1;
3118   int nargs = len + len - 1;
3119
3120   if (nargs < 0) return build_string ("");
3121
3122   args = alloca_array (Lisp_Object, nargs);
3123
3124   GCPRO1 (sep);
3125   mapcar1 (len, args, fn, seq);
3126   UNGCPRO;
3127
3128   for (i = len - 1; i >= 0; i--)
3129     args[i + i] = args[i];
3130
3131   for (i = 1; i < nargs; i += 2)
3132     args[i] = sep;
3133
3134   return Fconcat (nargs, args);
3135 }
3136
3137 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3138 Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3139 The result is a list just as long as SEQUENCE.
3140 SEQUENCE may be a list, a vector, a bit vector, or a string.
3141 */
3142        (fn, seq))
3143 {
3144   size_t len = XINT (Flength (seq));
3145   Lisp_Object *args = alloca_array (Lisp_Object, len);
3146
3147   mapcar1 (len, args, fn, seq);
3148
3149   return Flist (len, args);
3150 }
3151
3152 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3153 Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
3154 The result is a vector of the same length as SEQUENCE.
3155 SEQUENCE may be a list, a vector or a string.
3156 */
3157        (fn, seq))
3158 {
3159   size_t len = XINT (Flength (seq));
3160   Lisp_Object result = make_vector (len, Qnil);
3161   struct gcpro gcpro1;
3162
3163   GCPRO1 (result);
3164   mapcar1 (len, XVECTOR_DATA (result), fn, seq);
3165   UNGCPRO;
3166
3167   return result;
3168 }
3169
3170 DEFUN ("mapc", Fmapc, 2, 2, 0, /*
3171 Apply FUNCTION to each element of SEQUENCE.
3172 SEQUENCE may be a list, a vector, a bit vector, or a string.
3173 This function is like `mapcar' but does not accumulate the results,
3174 which is more efficient if you do not use the results.
3175 */
3176        (fn, seq))
3177 {
3178   mapcar1 (XINT (Flength (seq)), 0, fn, seq);
3179
3180   return seq;
3181 }
3182
3183 \f
3184 /* #### this function doesn't belong in this file! */
3185
3186 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3187 Return list of 1 minute, 5 minute and 15 minute load averages.
3188 Each of the three load averages is multiplied by 100,
3189 then converted to integer.
3190
3191 When USE-FLOATS is non-nil, floats will be used instead of integers.
3192 These floats are not multiplied by 100.
3193
3194 If the 5-minute or 15-minute load averages are not available, return a
3195 shortened list, containing only those averages which are available.
3196
3197 On some systems, this won't work due to permissions on /dev/kmem,
3198 in which case you can't use this.
3199 */
3200        (use_floats))
3201 {
3202   double load_ave[3];
3203   int loads = getloadavg (load_ave, countof (load_ave));
3204   Lisp_Object ret = Qnil;
3205
3206   if (loads == -2)
3207     error ("load-average not implemented for this operating system");
3208   else if (loads < 0)
3209     signal_simple_error ("Could not get load-average",
3210                          lisp_strerror (errno));
3211
3212   while (loads-- > 0)
3213     {
3214       Lisp_Object load = (NILP (use_floats) ?
3215                           make_int ((int) (100.0 * load_ave[loads]))
3216                           : make_float (load_ave[loads]));
3217       ret = Fcons (load, ret);
3218     }
3219   return ret;
3220 }
3221
3222 \f
3223 Lisp_Object Vfeatures;
3224
3225 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3226 Return non-nil if feature FEXP is present in this Emacs.
3227 Use this to conditionalize execution of lisp code based on the
3228  presence or absence of emacs or environment extensions.
3229 FEXP can be a symbol, a number, or a list.
3230 If it is a symbol, that symbol is looked up in the `features' variable,
3231  and non-nil will be returned if found.
3232 If it is a number, the function will return non-nil if this Emacs
3233  has an equal or greater version number than FEXP.
3234 If it is a list whose car is the symbol `and', it will return
3235  non-nil if all the features in its cdr are non-nil.
3236 If it is a list whose car is the symbol `or', it will return non-nil
3237  if any of the features in its cdr are non-nil.
3238 If it is a list whose car is the symbol `not', it will return
3239  non-nil if the feature is not present.
3240
3241 Examples:
3242
3243   (featurep 'xemacs)
3244     => ; Non-nil on XEmacs.
3245
3246   (featurep '(and xemacs gnus))
3247     => ; Non-nil on XEmacs with Gnus loaded.
3248
3249   (featurep '(or tty-frames (and emacs 19.30)))
3250     => ; Non-nil if this Emacs supports TTY frames.
3251
3252   (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3253     => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3254
3255 NOTE: The advanced arguments of this function (anything other than a
3256 symbol) are not yet supported by FSF Emacs.  If you feel they are useful
3257 for supporting multiple Emacs variants, lobby Richard Stallman at
3258 <bug-gnu-emacs@prep.ai.mit.edu>.
3259 */
3260        (fexp))
3261 {
3262 #ifndef FEATUREP_SYNTAX
3263   CHECK_SYMBOL (fexp);
3264   return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3265 #else  /* FEATUREP_SYNTAX */
3266   static double featurep_emacs_version;
3267
3268   /* Brute force translation from Erik Naggum's lisp function. */
3269   if (SYMBOLP (fexp))
3270     {
3271       /* Original definition */
3272       return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3273     }
3274   else if (INTP (fexp) || FLOATP (fexp))
3275     {
3276       double d = extract_float (fexp);
3277
3278       if (featurep_emacs_version == 0.0)
3279         {
3280           featurep_emacs_version = XINT (Vemacs_major_version) +
3281             (XINT (Vemacs_minor_version) / 100.0);
3282         }
3283       return featurep_emacs_version >= d ? Qt : Qnil;
3284     }
3285   else if (CONSP (fexp))
3286     {
3287       Lisp_Object tem = XCAR (fexp);
3288       if (EQ (tem, Qnot))
3289         {
3290           Lisp_Object negate;
3291
3292           tem = XCDR (fexp);
3293           negate = Fcar (tem);
3294           if (!NILP (tem))
3295             return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3296           else
3297             return Fsignal (Qinvalid_read_syntax, list1 (tem));
3298         }
3299       else if (EQ (tem, Qand))
3300         {
3301           tem = XCDR (fexp);
3302           /* Use Fcar/Fcdr for error-checking. */
3303           while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3304             {
3305               tem = Fcdr (tem);
3306             }
3307           return NILP (tem) ? Qt : Qnil;
3308         }
3309       else if (EQ (tem, Qor))
3310         {
3311           tem = XCDR (fexp);
3312           /* Use Fcar/Fcdr for error-checking. */
3313           while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3314             {
3315               tem = Fcdr (tem);
3316             }
3317           return NILP (tem) ? Qnil : Qt;
3318         }
3319       else
3320         {
3321           return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3322         }
3323     }
3324   else
3325     {
3326       return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3327     }
3328 }
3329 #endif /* FEATUREP_SYNTAX */
3330
3331 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3332 Announce that FEATURE is a feature of the current Emacs.
3333 This function updates the value of the variable `features'.
3334 */
3335        (feature))
3336 {
3337   Lisp_Object tem;
3338   CHECK_SYMBOL (feature);
3339   if (!NILP (Vautoload_queue))
3340     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3341   tem = Fmemq (feature, Vfeatures);
3342   if (NILP (tem))
3343     Vfeatures = Fcons (feature, Vfeatures);
3344   LOADHIST_ATTACH (Fcons (Qprovide, feature));
3345   return feature;
3346 }
3347
3348 DEFUN ("require", Frequire, 1, 2, 0, /*
3349 If feature FEATURE is not loaded, load it from FILENAME.
3350 If FEATURE is not a member of the list `features', then the feature
3351 is not loaded; so load the file FILENAME.
3352 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3353 */
3354        (feature, file_name))
3355 {
3356   Lisp_Object tem;
3357   CHECK_SYMBOL (feature);
3358   tem = Fmemq (feature, Vfeatures);
3359   LOADHIST_ATTACH (Fcons (Qrequire, feature));
3360   if (!NILP (tem))
3361     return feature;
3362   else
3363     {
3364       int speccount = specpdl_depth ();
3365
3366       /* Value saved here is to be restored into Vautoload_queue */
3367       record_unwind_protect (un_autoload, Vautoload_queue);
3368       Vautoload_queue = Qt;
3369
3370       call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3371              Qnil, Qt, Qnil);
3372
3373       tem = Fmemq (feature, Vfeatures);
3374       if (NILP (tem))
3375         error ("Required feature %s was not provided",
3376                string_data (XSYMBOL (feature)->name));
3377
3378       /* Once loading finishes, don't undo it.  */
3379       Vautoload_queue = Qt;
3380       return unbind_to (speccount, feature);
3381     }
3382 }
3383 \f
3384 /* base64 encode/decode functions.
3385    Based on code from GNU recode. */
3386
3387 #define MIME_LINE_LENGTH 76
3388
3389 #define IS_ASCII(Character) \
3390   ((Character) < 128)
3391 #define IS_BASE64(Character) \
3392   (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3393
3394 /* Table of characters coding the 64 values.  */
3395 static char base64_value_to_char[64] =
3396 {
3397   'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',     /*  0- 9 */
3398   'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',     /* 10-19 */
3399   'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd',     /* 20-29 */
3400   'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',     /* 30-39 */
3401   'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',     /* 40-49 */
3402   'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7',     /* 50-59 */
3403   '8', '9', '+', '/'                                    /* 60-63 */
3404 };
3405
3406 /* Table of base64 values for first 128 characters.  */
3407 static short base64_char_to_value[128] =
3408 {
3409   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*   0-  9 */
3410   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  10- 19 */
3411   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  20- 29 */
3412   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  30- 39 */
3413   -1,  -1,  -1,  62,  -1,  -1,  -1,  63,  52,  53,      /*  40- 49 */
3414   54,  55,  56,  57,  58,  59,  60,  61,  -1,  -1,      /*  50- 59 */
3415   -1,  -1,  -1,  -1,  -1,  0,   1,   2,   3,   4,       /*  60- 69 */
3416   5,   6,   7,   8,   9,   10,  11,  12,  13,  14,      /*  70- 79 */
3417   15,  16,  17,  18,  19,  20,  21,  22,  23,  24,      /*  80- 89 */
3418   25,  -1,  -1,  -1,  -1,  -1,  -1,  26,  27,  28,      /*  90- 99 */
3419   29,  30,  31,  32,  33,  34,  35,  36,  37,  38,      /* 100-109 */
3420   39,  40,  41,  42,  43,  44,  45,  46,  47,  48,      /* 110-119 */
3421   49,  50,  51,  -1,  -1,  -1,  -1,  -1                 /* 120-127 */
3422 };
3423
3424 /* The following diagram shows the logical steps by which three octets
3425    get transformed into four base64 characters.
3426
3427                  .--------.  .--------.  .--------.
3428                  |aaaaaabb|  |bbbbcccc|  |ccdddddd|
3429                  `--------'  `--------'  `--------'
3430                     6   2      4   4       2   6
3431                .--------+--------+--------+--------.
3432                |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3433                `--------+--------+--------+--------'
3434
3435                .--------+--------+--------+--------.
3436                |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3437                `--------+--------+--------+--------'
3438
3439    The octets are divided into 6 bit chunks, which are then encoded into
3440    base64 characters.  */
3441
3442 #define ADVANCE_INPUT(c, stream)                                \
3443  ((ec = Lstream_get_emchar (stream)) == -1 ? 0 :                \
3444   ((ec > 255) ?                                                 \
3445    (signal_simple_error ("Non-ascii character in base64 input", \
3446                          make_char (ec)), 0)                    \
3447    : (c = (Bufbyte)ec), 1))
3448
3449 static Bytind
3450 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3451 {
3452   EMACS_INT counter = 0;
3453   Bufbyte *e = to;
3454   Emchar ec;
3455   unsigned int value;
3456
3457   while (1)
3458     {
3459       Bufbyte c;
3460       if (!ADVANCE_INPUT (c, istream))
3461         break;
3462
3463       /* Wrap line every 76 characters.  */
3464       if (line_break)
3465         {
3466           if (counter < MIME_LINE_LENGTH / 4)
3467             counter++;
3468           else
3469             {
3470               *e++ = '\n';
3471               counter = 1;
3472             }
3473         }
3474
3475       /* Process first byte of a triplet.  */
3476       *e++ = base64_value_to_char[0x3f & c >> 2];
3477       value = (0x03 & c) << 4;
3478
3479       /* Process second byte of a triplet.  */
3480       if (!ADVANCE_INPUT (c, istream))
3481         {
3482           *e++ = base64_value_to_char[value];
3483           *e++ = '=';
3484           *e++ = '=';
3485           break;
3486         }
3487
3488       *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3489       value = (0x0f & c) << 2;
3490
3491       /* Process third byte of a triplet.  */
3492       if (!ADVANCE_INPUT (c, istream))
3493         {
3494           *e++ = base64_value_to_char[value];
3495           *e++ = '=';
3496           break;
3497         }
3498
3499       *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3500       *e++ = base64_value_to_char[0x3f & c];
3501     }
3502
3503   return e - to;
3504 }
3505 #undef ADVANCE_INPUT
3506
3507 /* Semantically identical to ADVANCE_INPUT above, only no >255
3508    checking is needed for decoding -- checking is covered by IS_BASE64
3509    below.  */
3510 #define ADVANCE_INPUT(c, stream)                \
3511  (ec = Lstream_get_emchar (stream),             \
3512   ec == -1 ? 0 : (c = (Bufbyte)ec, 1))
3513
3514 /* Get next character from the stream, but ignore it if it's
3515    whitespace.  ENDP is set to 1 if EOF is hit.  */
3516 #define ADVANCE_INPUT_IGNORE_WHITESPACE(c, endp, stream) do {           \
3517   endp = 0;                                                             \
3518   do {                                                                  \
3519     if (!ADVANCE_INPUT (c, stream))                                     \
3520       endp = 1;                                                         \
3521   } while (!endp && (c == ' ' || c == '\t' || c == '\r' || c == '\n'    \
3522                      || c == '\f' || c == '\v'));                       \
3523 } while (0)
3524
3525 #define STORE_BYTE(pos, val) do {                                       \
3526   pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val)));      \
3527   ++*ccptr;                                                             \
3528 } while (0)
3529
3530 static Bytind
3531 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3532 {
3533   Bufbyte *e = to;
3534   unsigned long value;
3535
3536   *ccptr = 0;
3537   while (1)
3538     {
3539       Bufbyte c;
3540       Emchar ec;
3541       int endp;
3542
3543       ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3544       if (endp)
3545         break;
3546
3547       /* Process first byte of a quadruplet.  */
3548       if (!IS_BASE64 (c))
3549         return -1;
3550       value = base64_char_to_value[c] << 18;
3551
3552       /* Process second byte of a quadruplet.  */
3553       ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3554       if (endp)
3555         return -1;
3556
3557       if (!IS_BASE64 (c))
3558         return -1;
3559       value |= base64_char_to_value[c] << 12;
3560
3561       STORE_BYTE (e, value >> 16);
3562
3563       /* Process third byte of a quadruplet.  */
3564       ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3565       if (endp)
3566         return -1;
3567
3568       if (c == '=')
3569         {
3570           ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3571           if (endp)
3572             return -1;
3573           if (c != '=')
3574             return -1;
3575           continue;
3576         }
3577
3578       if (!IS_BASE64 (c))
3579         return -1;
3580       value |= base64_char_to_value[c] << 6;
3581
3582       STORE_BYTE (e, 0xff & value >> 8);
3583
3584       /* Process fourth byte of a quadruplet.  */
3585       ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3586       if (endp)
3587         return -1;
3588
3589       if (c == '=')
3590         continue;
3591
3592       if (!IS_BASE64 (c))
3593         return -1;
3594       value |= base64_char_to_value[c];
3595
3596       STORE_BYTE (e, 0xff & value);
3597     }
3598
3599   return e - to;
3600 }
3601 #undef ADVANCE_INPUT
3602 #undef ADVANCE_INPUT_IGNORE_WHITESPACE
3603 #undef STORE_BYTE
3604
3605 static Lisp_Object
3606 free_malloced_ptr (Lisp_Object unwind_obj)
3607 {
3608   void *ptr = (void *)get_opaque_ptr (unwind_obj);
3609   xfree (ptr);
3610   free_opaque_ptr (unwind_obj);
3611   return Qnil;
3612 }
3613
3614 /* Don't use alloca for regions larger than this, lest we overflow
3615    the stack.  */
3616 #define MAX_ALLOCA 65536
3617
3618 /* We need to setup proper unwinding, because there is a number of
3619    ways these functions can blow up, and we don't want to have memory
3620    leaks in those cases.  */
3621 #define XMALLOC_OR_ALLOCA(ptr, len, type) do {                  \
3622   size_t XOA_len = (len);                                       \
3623   if (XOA_len > MAX_ALLOCA)                                     \
3624     {                                                           \
3625       ptr = xnew_array (type, XOA_len);                         \
3626       record_unwind_protect (free_malloced_ptr,                 \
3627                              make_opaque_ptr ((void *)ptr));    \
3628     }                                                           \
3629   else                                                          \
3630     ptr = alloca_array (type, XOA_len);                         \
3631 } while (0)
3632
3633 #define XMALLOC_UNBIND(ptr, len, speccount) do {                \
3634   if ((len) > MAX_ALLOCA)                                       \
3635     unbind_to (speccount, Qnil);                                \
3636 } while (0)
3637
3638 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3639 Base64-encode the region between BEG and END.
3640 Return the length of the encoded text.
3641 Optional third argument NO-LINE-BREAK means do not break long lines
3642 into shorter lines.
3643 */
3644        (beg, end, no_line_break))
3645 {
3646   Bufbyte *encoded;
3647   Bytind encoded_length;
3648   Charcount allength, length;
3649   struct buffer *buf = current_buffer;
3650   Bufpos begv, zv, old_pt = BUF_PT (buf);
3651   Lisp_Object input;
3652   int speccount = specpdl_depth();
3653
3654   get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3655   barf_if_buffer_read_only (buf, begv, zv);
3656
3657   /* We need to allocate enough room for encoding the text.
3658      We need 33 1/3% more space, plus a newline every 76
3659      characters, and then we round up. */
3660   length = zv - begv;
3661   allength = length + length/3 + 1;
3662   allength += allength / MIME_LINE_LENGTH + 1 + 6;
3663
3664   input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3665   /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3666      base64 characters will be single-byte.  */
3667   XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3668   encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3669                                     NILP (no_line_break));
3670   if (encoded_length > allength)
3671     abort ();
3672   Lstream_delete (XLSTREAM (input));
3673
3674   /* Now we have encoded the region, so we insert the new contents
3675      and delete the old.  (Insert first in order to preserve markers.)  */
3676   buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3677   XMALLOC_UNBIND (encoded, allength, speccount);
3678   buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3679
3680   /* Simulate FSF Emacs: if point was in the region, place it at the
3681      beginning.  */
3682   if (old_pt >= begv && old_pt < zv)
3683     BUF_SET_PT (buf, begv);
3684
3685   /* We return the length of the encoded text. */
3686   return make_int (encoded_length);
3687 }
3688
3689 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3690 Base64 encode STRING and return the result.
3691 */
3692        (string, no_line_break))
3693 {
3694   Charcount allength, length;
3695   Bytind encoded_length;
3696   Bufbyte *encoded;
3697   Lisp_Object input, result;
3698   int speccount = specpdl_depth();
3699
3700   CHECK_STRING (string);
3701
3702   length = XSTRING_CHAR_LENGTH (string);
3703   allength = length + length/3 + 1;
3704   allength += allength / MIME_LINE_LENGTH + 1 + 6;
3705
3706   input = make_lisp_string_input_stream (string, 0, -1);
3707   XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3708   encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3709                                     NILP (no_line_break));
3710   if (encoded_length > allength)
3711     abort ();
3712   Lstream_delete (XLSTREAM (input));
3713   result = make_string (encoded, encoded_length);
3714   XMAL