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