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.
5 This file is part of XEmacs.
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
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
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. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
54 static Lisp_Object free_malloced_ptr(Lisp_Object unwind_obj)
56 void *ptr = (void *)get_opaque_ptr(unwind_obj);
58 free_opaque_ptr(unwind_obj);
62 /* Don't use alloca for regions larger than this, lest we overflow
64 #define MAX_ALLOCA 65536
66 /* We need to setup proper unwinding, because there is a number of
67 ways these functions can blow up, and we don't want to have memory
68 leaks in those cases. */
69 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
70 size_t XOA_len = (len); \
71 if (XOA_len > MAX_ALLOCA ) { \
72 ptr = xnew_array (type, XOA_len); \
73 record_unwind_protect (free_malloced_ptr, \
74 make_opaque_ptr ((void *)ptr)); \
77 ptr = alloca_array (type, XOA_len); \
80 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
81 if ((len) > MAX_ALLOCA) \
82 unbind_to (speccount, Qnil); \
88 /* NOTE: This symbol is also used in lread.c */
89 #define FEATUREP_SYNTAX
91 Lisp_Object Qstring_lessp;
92 Lisp_Object Qidentity;
94 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
95 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
98 mark_bit_vector (Lisp_Object obj)
104 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
107 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 size_t len = bit_vector_length (v);
111 if (INTP (Vprint_length))
112 last = min ((EMACS_INT) len, XINT (Vprint_length));
113 write_c_string ("#*", printcharfun);
114 for (i = 0; i < last; i++)
116 if (bit_vector_bit (v, i))
117 write_c_string ("1", printcharfun);
119 write_c_string ("0", printcharfun);
123 write_c_string ("...", printcharfun);
127 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
129 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
130 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
132 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
133 !memcmp (v1->bits, v2->bits,
134 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
139 bit_vector_hash (Lisp_Object obj, int depth)
141 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
142 return HASH2 (bit_vector_length (v),
143 memory_hash (v->bits,
144 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
149 size_bit_vector (const void *lheader)
151 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
152 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits,
153 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
156 static const struct lrecord_description bit_vector_description[] = {
157 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
162 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
163 mark_bit_vector, print_bit_vector, 0,
164 bit_vector_equal, bit_vector_hash,
165 bit_vector_description, size_bit_vector,
168 DEFUN ("identity", Fidentity, 1, 1, 0, /*
169 Return the argument unchanged.
176 extern long get_random (void);
177 extern void seed_random (long arg);
179 DEFUN ("random", Frandom, 0, 1, 0, /*
180 Return a pseudo-random number.
181 All integers representable in Lisp are equally likely.
182 On most systems, this is 31 bits' worth.
183 With positive integer argument N, return random number in interval [0,N).
184 With argument t, set the random number seed from the current time and pid.
189 unsigned long denominator;
192 seed_random (getpid () + time (NULL));
193 if (NATNUMP (limit) && !ZEROP (limit))
195 /* Try to take our random number from the higher bits of VAL,
196 not the lower, since (says Gentzel) the low bits of `random'
197 are less random than the higher ones. We do this by using the
198 quotient rather than the remainder. At the high end of the RNG
199 it's possible to get a quotient larger than limit; discarding
200 these values eliminates the bias that would otherwise appear
201 when using a large limit. */
202 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
204 val = get_random () / denominator;
205 while (val >= XINT (limit));
210 return make_int (val);
213 /* Random data-structure functions */
215 #ifdef LOSING_BYTECODE
217 /* #### Delete this shit */
219 /* Charcount is a misnomer here as we might be dealing with the
220 length of a vector or list, but emphasizes that we're not dealing
221 with Bytecounts in strings */
223 length_with_bytecode_hack (Lisp_Object seq)
225 if (!COMPILED_FUNCTIONP (seq))
226 return XINT (Flength (seq));
229 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
231 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
232 f->flags.domainp ? COMPILED_DOMAIN :
238 #endif /* LOSING_BYTECODE */
241 check_losing_bytecode (const char *function, Lisp_Object seq)
243 if (COMPILED_FUNCTIONP (seq))
246 "As of 20.3, `%s' no longer works with compiled-function objects",
250 DEFUN ("length", Flength, 1, 1, 0, /*
251 Return the length of vector, bit vector, list or string SEQUENCE.
256 if (STRINGP (sequence))
257 return make_int (XSTRING_CHAR_LENGTH (sequence));
258 else if (CONSP (sequence))
261 GET_EXTERNAL_LIST_LENGTH (sequence, len);
262 return make_int (len);
264 else if (VECTORP (sequence))
265 return make_int (XVECTOR_LENGTH (sequence));
266 else if (NILP (sequence))
268 else if (BIT_VECTORP (sequence))
269 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
272 check_losing_bytecode ("length", sequence);
273 sequence = wrong_type_argument (Qsequencep, sequence);
278 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
279 Return the length of a list, but avoid error or infinite loop.
280 This function never gets an error. If LIST is not really a list,
281 it returns 0. If LIST is circular, it returns a finite value
282 which is at least the number of distinct elements.
286 Lisp_Object hare, tortoise;
289 for (hare = tortoise = list, len = 0;
290 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
291 hare = XCDR (hare), len++)
294 tortoise = XCDR (tortoise);
297 return make_int (len);
300 /*** string functions. ***/
302 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
303 Return t if two strings have identical contents.
304 Case is significant. Text properties are ignored.
305 \(Under XEmacs, `equal' also ignores text properties and extents in
306 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
307 `equal' is the same as in XEmacs, in that respect.)
308 Symbols are also allowed; their print names are used instead.
313 Lisp_String *p1, *p2;
315 if (SYMBOLP (string1))
316 p1 = XSYMBOL (string1)->name;
319 CHECK_STRING (string1);
320 p1 = XSTRING (string1);
323 if (SYMBOLP (string2))
324 p2 = XSYMBOL (string2)->name;
327 CHECK_STRING (string2);
328 p2 = XSTRING (string2);
331 return (((len = string_length (p1)) == string_length (p2)) &&
332 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
336 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
337 Return t if first arg string is less than second in lexicographic order.
338 If I18N2 support (but not Mule support) was compiled in, ordering is
339 determined by the locale. (Case is significant for the default C locale.)
340 In all other cases, comparison is simply done on a character-by-
341 character basis using the numeric value of a character. (Note that
342 this may not produce particularly meaningful results under Mule if
343 characters from different charsets are being compared.)
345 Symbols are also allowed; their print names are used instead.
347 The reason that the I18N2 locale-specific collation is not used under
348 Mule is that the locale model of internationalization does not handle
349 multiple charsets and thus has no hope of working properly under Mule.
350 What we really should do is create a collation table over all built-in
351 charsets. This is extremely difficult to do from scratch, however.
353 Unicode is a good first step towards solving this problem. In fact,
354 it is quite likely that a collation table exists (or will exist) for
355 Unicode. When Unicode support is added to XEmacs/Mule, this problem
360 Lisp_String *p1, *p2;
364 if (SYMBOLP (string1))
365 p1 = XSYMBOL (string1)->name;
368 CHECK_STRING (string1);
369 p1 = XSTRING (string1);
372 if (SYMBOLP (string2))
373 p2 = XSYMBOL (string2)->name;
376 CHECK_STRING (string2);
377 p2 = XSTRING (string2);
380 end = string_char_length (p1);
381 len2 = string_char_length (p2);
385 #if defined (I18N2) && !defined (MULE)
386 /* There is no hope of this working under Mule. Even if we converted
387 the data into an external format so that strcoll() processed it
388 properly, it would still not work because strcoll() does not
389 handle multiple locales. This is the fundamental flaw in the
392 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
393 /* Compare strings using collation order of locale. */
394 /* Need to be tricky to handle embedded nulls. */
396 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
398 int val = strcoll ((char *) string_data (p1) + i,
399 (char *) string_data (p2) + i);
406 #else /* not I18N2, or MULE */
408 Bufbyte *ptr1 = string_data (p1);
409 Bufbyte *ptr2 = string_data (p2);
411 /* #### It is not really necessary to do this: We could compare
412 byte-by-byte and still get a reasonable comparison, since this
413 would compare characters with a charset in the same way. With
414 a little rearrangement of the leading bytes, we could make most
415 inter-charset comparisons work out the same, too; even if some
416 don't, this is not a big deal because inter-charset comparisons
417 aren't really well-defined anyway. */
418 for (i = 0; i < end; i++)
420 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
421 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
426 #endif /* not I18N2, or MULE */
427 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
428 won't work right in I18N2 case */
429 return end < len2 ? Qt : Qnil;
432 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
433 Return STRING's tick counter, incremented for each change to the string.
434 Each string has a tick counter which is incremented each time the contents
435 of the string are changed (e.g. with `aset'). It wraps around occasionally.
441 CHECK_STRING (string);
442 s = XSTRING (string);
443 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
444 return XCAR (s->plist);
450 bump_string_modiff (Lisp_Object str)
452 Lisp_String *s = XSTRING (str);
453 Lisp_Object *ptr = &s->plist;
456 /* #### remove the `string-translatable' property from the string,
459 /* skip over extent info if it's there */
460 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
462 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
463 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
465 *ptr = Fcons (make_int (1), *ptr);
469 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
470 static Lisp_Object concat (int nargs, Lisp_Object *args,
471 enum concat_target_type target_type,
475 concat2 (Lisp_Object string1, Lisp_Object string2)
480 return concat (2, args, c_string, 0);
484 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
490 return concat (3, args, c_string, 0);
494 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
499 return concat (2, args, c_vector, 0);
503 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
509 return concat (3, args, c_vector, 0);
512 DEFUN ("append", Fappend, 0, MANY, 0, /*
513 Concatenate all the arguments and make the result a list.
514 The result is a list whose elements are the elements of all the arguments.
515 Each argument may be a list, vector, bit vector, or string.
516 The last argument is not copied, just used as the tail of the new list.
519 (int nargs, Lisp_Object *args))
521 return concat (nargs, args, c_cons, 1);
524 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
525 Concatenate all the arguments and make the result a string.
526 The result is a string whose elements are the elements of all the arguments.
527 Each argument may be a string or a list or vector of characters.
529 As of XEmacs 21.0, this function does NOT accept individual integers
530 as arguments. Old code that relies on, for example, (concat "foo" 50)
531 returning "foo50" will fail. To fix such code, either apply
532 `int-to-string' to the integer argument, or use `format'.
534 (int nargs, Lisp_Object *args))
536 return concat (nargs, args, c_string, 0);
539 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
540 Concatenate all the arguments and make the result a vector.
541 The result is a vector whose elements are the elements of all the arguments.
542 Each argument may be a list, vector, bit vector, or string.
544 (int nargs, Lisp_Object *args))
546 return concat (nargs, args, c_vector, 0);
549 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
550 Concatenate all the arguments and make the result a bit vector.
551 The result is a bit vector whose elements are the elements of all the
552 arguments. Each argument may be a list, vector, bit vector, or string.
554 (int nargs, Lisp_Object *args))
556 return concat (nargs, args, c_bit_vector, 0);
559 /* Copy a (possibly dotted) list. LIST must be a cons.
560 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
562 copy_list (Lisp_Object list)
564 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
565 Lisp_Object last = list_copy;
566 Lisp_Object hare, tortoise;
569 for (tortoise = hare = XCDR (list), len = 1;
571 hare = XCDR (hare), len++)
573 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
576 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
579 tortoise = XCDR (tortoise);
580 if (EQ (tortoise, hare))
581 signal_circular_list_error (list);
587 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
588 Return a copy of list LIST, which may be a dotted list.
589 The elements of LIST are not copied; they are shared
595 if (NILP (list)) return list;
596 if (CONSP (list)) return copy_list (list);
598 list = wrong_type_argument (Qlistp, list);
602 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
603 Return a copy of list, vector, bit vector or string SEQUENCE.
604 The elements of a list or vector are not copied; they are shared
605 with the original. SEQUENCE may be a dotted list.
610 if (NILP (sequence)) return sequence;
611 if (CONSP (sequence)) return copy_list (sequence);
612 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
613 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
614 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
616 check_losing_bytecode ("copy-sequence", sequence);
617 sequence = wrong_type_argument (Qsequencep, sequence);
621 struct merge_string_extents_struct
624 Bytecount entry_offset;
625 Bytecount entry_length;
629 concat (int nargs, Lisp_Object *args,
630 enum concat_target_type target_type,
634 Lisp_Object tail = Qnil;
637 Lisp_Object last_tail;
639 struct merge_string_extents_struct *args_mse = 0;
640 Bufbyte *string_result = 0;
641 Bufbyte *string_result_ptr = 0;
643 int speccount = specpdl_depth();
644 Charcount total_length;
646 /* The modus operandi in Emacs is "caller gc-protects args".
647 However, concat is called many times in Emacs on freshly
648 created stuff. So we help those callers out by protecting
649 the args ourselves to save them a lot of temporary-variable
653 gcpro1.nvars = nargs;
656 /* #### if the result is a string and any of the strings have a string
657 for the `string-translatable' property, then concat should also
658 concat the args but use the `string-translatable' strings, and store
659 the result in the returned string's `string-translatable' property. */
661 if (target_type == c_string)
662 XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
664 /* In append, the last arg isn't treated like the others */
665 if (last_special && nargs > 0)
668 last_tail = args[nargs];
673 /* Check and coerce the arguments. */
674 for (argnum = 0; argnum < nargs; argnum++)
676 Lisp_Object seq = args[argnum];
679 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
681 #ifdef LOSING_BYTECODE
682 else if (COMPILED_FUNCTIONP (seq))
683 /* Urk! We allow this, for "compatibility"... */
686 #if 0 /* removed for XEmacs 21 */
688 /* This is too revolting to think about but maintains
689 compatibility with FSF (and lots and lots of old code). */
690 args[argnum] = Fnumber_to_string (seq);
694 check_losing_bytecode ("concat", seq);
695 args[argnum] = wrong_type_argument (Qsequencep, seq);
701 args_mse[argnum].string = seq;
703 args_mse[argnum].string = Qnil;
708 /* Charcount is a misnomer here as we might be dealing with the
709 length of a vector or list, but emphasizes that we're not dealing
710 with Bytecounts in strings */
711 /* Charcount total_length; */
713 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
715 #ifdef LOSING_BYTECODE
716 Charcount thislen = length_with_bytecode_hack (args[argnum]);
718 Charcount thislen = XINT (Flength (args[argnum]));
720 total_length += thislen;
726 if (total_length == 0)
728 /* In append, if all but last arg are nil, return last arg */
729 XMALLOC_UNBIND(args_mse, nargs, speccount);
730 RETURN_UNGCPRO (last_tail);
732 val = Fmake_list (make_int (total_length), Qnil);
735 val = make_vector (total_length, Qnil);
738 val = make_bit_vector (total_length, Qzero);
741 /* We don't make the string yet because we don't know the
742 actual number of bytes. This loop was formerly written
743 to call Fmake_string() here and then call set_string_char()
744 for each char. This seems logical enough but is waaaaaaaay
745 slow -- set_string_char() has to scan the whole string up
746 to the place where the substitution is called for in order
747 to find the place to change, and may have to do some
748 realloc()ing in order to make the char fit properly.
751 XMALLOC_OR_ALLOCA( string_result,
752 total_length * MAX_EMCHAR_LEN,
754 string_result_ptr = string_result;
764 tail = val, toindex = -1; /* -1 in toindex is flag we are
771 for (argnum = 0; argnum < nargs; argnum++)
773 Charcount thisleni = 0;
774 Charcount thisindex = 0;
775 Lisp_Object seq = args[argnum];
776 Bufbyte *string_source_ptr = 0;
777 Bufbyte *string_prev_result_ptr = string_result_ptr;
781 #ifdef LOSING_BYTECODE
782 thisleni = length_with_bytecode_hack (seq);
784 thisleni = XINT (Flength (seq));
788 string_source_ptr = XSTRING_DATA (seq);
794 /* We've come to the end of this arg, so exit. */
798 /* Fetch next element of `seq' arg into `elt' */
806 if (thisindex >= thisleni)
811 elt = make_char (charptr_emchar (string_source_ptr));
812 INC_CHARPTR (string_source_ptr);
814 else if (VECTORP (seq))
815 elt = XVECTOR_DATA (seq)[thisindex];
816 else if (BIT_VECTORP (seq))
817 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
820 elt = Felt (seq, make_int (thisindex));
824 /* Store into result */
827 /* toindex negative means we are making a list */
832 else if (VECTORP (val))
833 XVECTOR_DATA (val)[toindex++] = elt;
834 else if (BIT_VECTORP (val))
837 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
841 CHECK_CHAR_COERCE_INT (elt);
842 string_result_ptr += set_charptr_emchar (string_result_ptr,
848 args_mse[argnum].entry_offset =
849 string_prev_result_ptr - string_result;
850 args_mse[argnum].entry_length =
851 string_result_ptr - string_prev_result_ptr;
855 /* Now we finally make the string. */
856 if (target_type == c_string)
858 val = make_string (string_result, string_result_ptr - string_result);
859 for (argnum = 0; argnum < nargs; argnum++)
861 if (STRINGP (args_mse[argnum].string))
862 copy_string_extents (val, args_mse[argnum].string,
863 args_mse[argnum].entry_offset, 0,
864 args_mse[argnum].entry_length);
866 XMALLOC_UNBIND(string_result, total_length * MAX_EMCHAR_LEN, speccount);
867 XMALLOC_UNBIND(args_mse, nargs, speccount);
871 XCDR (prev) = last_tail;
873 RETURN_UNGCPRO (val);
876 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
877 Return a copy of ALIST.
878 This is an alist which represents the same mapping from objects to objects,
879 but does not share the alist structure with ALIST.
880 The objects mapped (cars and cdrs of elements of the alist)
882 Elements of ALIST that are not conses are also shared.
892 alist = concat (1, &alist, c_cons, 0);
893 for (tail = alist; CONSP (tail); tail = XCDR (tail))
895 Lisp_Object car = XCAR (tail);
898 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
903 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
904 Return a copy of a list and substructures.
905 The argument is copied, and any lists contained within it are copied
906 recursively. Circularities and shared substructures are not preserved.
907 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
912 return safe_copy_tree (arg, vecp, 0);
916 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
919 signal_simple_error ("Stack overflow in copy-tree", arg);
924 rest = arg = Fcopy_sequence (arg);
927 Lisp_Object elt = XCAR (rest);
929 if (CONSP (elt) || VECTORP (elt))
930 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
931 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
932 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
936 else if (VECTORP (arg) && ! NILP (vecp))
938 int i = XVECTOR_LENGTH (arg);
940 arg = Fcopy_sequence (arg);
941 for (j = 0; j < i; j++)
943 Lisp_Object elt = XVECTOR_DATA (arg) [j];
945 if (CONSP (elt) || VECTORP (elt))
946 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
952 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
953 Return the substring of STRING starting at START and ending before END.
954 END may be nil or omitted; then the substring runs to the end of STRING.
955 If START or END is negative, it counts from the end.
956 Relevant parts of the string-extent-data are copied to the new string.
958 (string, start, end))
960 Charcount ccstart, ccend;
961 Bytecount bstart, blen;
964 CHECK_STRING (string);
966 get_string_range_char (string, start, end, &ccstart, &ccend,
967 GB_HISTORICAL_STRING_BEHAVIOR);
968 bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart);
969 blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart);
970 val = make_string (XSTRING_DATA (string) + bstart, blen);
971 /* Copy any applicable extent information into the new string. */
972 copy_string_extents (val, string, 0, bstart, blen);
976 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
977 Return the subsequence of SEQUENCE starting at START and ending before END.
978 END may be omitted; then the subsequence runs to the end of SEQUENCE.
979 If START or END is negative, it counts from the end.
980 The returned subsequence is always of the same type as SEQUENCE.
981 If SEQUENCE is a string, relevant parts of the string-extent-data
982 are copied to the new string.
984 (sequence, start, end))
988 if (STRINGP (sequence))
989 return Fsubstring (sequence, start, end);
991 len = XINT (Flength (sequence));
1008 if (!(0 <= s && s <= e && e <= len))
1009 args_out_of_range_3 (sequence, make_int (s), make_int (e));
1011 if (VECTORP (sequence))
1013 Lisp_Object result = make_vector (e - s, Qnil);
1015 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
1016 Lisp_Object *out_elts = XVECTOR_DATA (result);
1018 for (i = s; i < e; i++)
1019 out_elts[i - s] = in_elts[i];
1022 else if (LISTP (sequence))
1024 Lisp_Object result = Qnil;
1027 sequence = Fnthcdr (make_int (s), sequence);
1029 for (i = s; i < e; i++)
1031 result = Fcons (Fcar (sequence), result);
1032 sequence = Fcdr (sequence);
1035 return Fnreverse (result);
1037 else if (BIT_VECTORP (sequence))
1039 Lisp_Object result = make_bit_vector (e - s, Qzero);
1042 for (i = s; i < e; i++)
1043 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
1044 bit_vector_bit (XBIT_VECTOR (sequence), i));
1049 ABORT (); /* unreachable, since Flength (sequence) did not get
1056 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1057 Take cdr N times on LIST, and return the result.
1062 REGISTER Lisp_Object tail = list;
1064 for (i = XINT (n); i; i--)
1068 else if (NILP (tail))
1072 tail = wrong_type_argument (Qlistp, tail);
1079 DEFUN ("nth", Fnth, 2, 2, 0, /*
1080 Return the Nth element of LIST.
1081 N counts from zero. If LIST is not that long, nil is returned.
1085 return Fcar (Fnthcdr (n, list));
1088 DEFUN ("elt", Felt, 2, 2, 0, /*
1089 Return element of SEQUENCE at index N.
1094 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1095 if (LISTP (sequence))
1097 Lisp_Object tem = Fnthcdr (n, sequence);
1098 /* #### Utterly, completely, fucking disgusting.
1099 * #### The whole point of "elt" is that it operates on
1100 * #### sequences, and does error- (bounds-) checking.
1106 /* This is The Way It Has Always Been. */
1109 /* This is The Way Mly and Cltl2 say It Should Be. */
1110 args_out_of_range (sequence, n);
1113 else if (STRINGP (sequence) ||
1114 VECTORP (sequence) ||
1115 BIT_VECTORP (sequence))
1116 return Faref (sequence, n);
1117 #ifdef LOSING_BYTECODE
1118 else if (COMPILED_FUNCTIONP (sequence))
1120 EMACS_INT idx = XINT (n);
1124 args_out_of_range (sequence, n);
1126 /* Utter perversity */
1128 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1131 case COMPILED_ARGLIST:
1132 return compiled_function_arglist (f);
1133 case COMPILED_INSTRUCTIONS:
1134 return compiled_function_instructions (f);
1135 case COMPILED_CONSTANTS:
1136 return compiled_function_constants (f);
1137 case COMPILED_STACK_DEPTH:
1138 return compiled_function_stack_depth (f);
1139 case COMPILED_DOC_STRING:
1140 return compiled_function_documentation (f);
1141 case COMPILED_DOMAIN:
1142 return compiled_function_domain (f);
1143 case COMPILED_INTERACTIVE:
1144 if (f->flags.interactivep)
1145 return compiled_function_interactive (f);
1146 /* if we return nil, can't tell interactive with no args
1147 from noninteractive. */
1154 #endif /* LOSING_BYTECODE */
1157 check_losing_bytecode ("elt", sequence);
1158 sequence = wrong_type_argument (Qsequencep, sequence);
1163 DEFUN ("last", Flast, 1, 2, 0, /*
1164 Return the tail of list LIST, of length N (default 1).
1165 LIST may be a dotted list, but not a circular list.
1166 Optional argument N must be a non-negative integer.
1167 If N is zero, then the atom that terminates the list is returned.
1168 If N is greater than the length of LIST, then LIST itself is returned.
1172 EMACS_INT int_n, count;
1173 Lisp_Object retval, tortoise, hare;
1185 for (retval = tortoise = hare = list, count = 0;
1188 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1191 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1194 tortoise = XCDR (tortoise);
1195 if (EQ (hare, tortoise))
1196 signal_circular_list_error (list);
1202 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1203 Modify LIST to remove the last N (default 1) elements.
1204 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1221 Lisp_Object last_cons = list;
1223 EXTERNAL_LIST_LOOP_1 (list)
1226 last_cons = XCDR (last_cons);
1232 XCDR (last_cons) = Qnil;
1237 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1238 Return a copy of LIST with the last N (default 1) elements removed.
1239 If LIST has N or fewer elements, nil is returned.
1256 Lisp_Object retval = Qnil;
1257 Lisp_Object tail = list;
1259 EXTERNAL_LIST_LOOP_1 (list)
1263 retval = Fcons (XCAR (tail), retval);
1268 return Fnreverse (retval);
1272 DEFUN ("member", Fmember, 2, 2, 0, /*
1273 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1274 The value is actually the tail of LIST whose car is ELT.
1278 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1280 if (internal_equal (elt, list_elt, 0))
1286 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1287 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1288 The value is actually the tail of LIST whose car is ELT.
1289 This function is provided only for byte-code compatibility with v19.
1294 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1296 if (internal_old_equal (elt, list_elt, 0))
1302 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1303 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1304 The value is actually the tail of LIST whose car is ELT.
1308 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1310 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1316 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1317 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1318 The value is actually the tail of LIST whose car is ELT.
1319 This function is provided only for byte-code compatibility with v19.
1324 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1326 if (HACKEQ_UNSAFE (elt, list_elt))
1333 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1335 LIST_LOOP_3 (list_elt, list, tail)
1337 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1343 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1344 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1345 The value is actually the element of ALIST whose car equals KEY.
1349 /* This function can GC. */
1350 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1352 if (internal_equal (key, elt_car, 0))
1358 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1359 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
1360 The value is actually the element of ALIST whose car equals KEY.
1364 /* This function can GC. */
1365 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1367 if (internal_old_equal (key, elt_car, 0))
1374 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
1376 int speccount = specpdl_depth ();
1377 specbind (Qinhibit_quit, Qt);
1378 return unbind_to (speccount, Fassoc (key, alist));
1381 DEFUN ("assq", Fassq, 2, 2, 0, /*
1382 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1383 The value is actually the element of ALIST whose car is KEY.
1384 Elements of ALIST that are not conses are ignored.
1388 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1390 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1396 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1397 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
1398 The value is actually the element of ALIST whose car is KEY.
1399 Elements of ALIST that are not conses are ignored.
1400 This function is provided only for byte-code compatibility with v19.
1405 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1407 if (HACKEQ_UNSAFE (key, elt_car))
1413 /* Like Fassq but never report an error and do not allow quits.
1414 Use only on lists known never to be circular. */
1417 assq_no_quit (Lisp_Object key, Lisp_Object alist)
1419 /* This cannot GC. */
1420 LIST_LOOP_2 (elt, alist)
1422 Lisp_Object elt_car = XCAR (elt);
1423 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1429 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1430 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1431 The value is actually the element of ALIST whose cdr equals VALUE.
1435 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1437 if (internal_equal (value, elt_cdr, 0))
1443 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1444 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
1445 The value is actually the element of ALIST whose cdr equals VALUE.
1449 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1451 if (internal_old_equal (value, elt_cdr, 0))
1457 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1458 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1459 The value is actually the element of ALIST whose cdr is VALUE.
1463 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1465 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1471 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1472 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
1473 The value is actually the element of ALIST whose cdr is VALUE.
1477 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1479 if (HACKEQ_UNSAFE (value, elt_cdr))
1485 /* Like Frassq, but caller must ensure that ALIST is properly
1486 nil-terminated and ebola-free. */
1488 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
1490 LIST_LOOP_2 (elt, alist)
1492 Lisp_Object elt_cdr = XCDR (elt);
1493 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1500 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1501 Delete by side effect any occurrences of ELT as a member of LIST.
1502 The modified LIST is returned. Comparison is done with `equal'.
1503 If the first member of LIST is ELT, there is no way to remove it by side
1504 effect; therefore, write `(setq foo (delete element foo))' to be sure
1505 of changing the value of `foo'.
1510 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1511 (internal_equal (elt, list_elt, 0)));
1515 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1516 Delete by side effect any occurrences of ELT as a member of LIST.
1517 The modified LIST is returned. Comparison is done with `old-equal'.
1518 If the first member of LIST is ELT, there is no way to remove it by side
1519 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1520 of changing the value of `foo'.
1524 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1525 (internal_old_equal (elt, list_elt, 0)));
1529 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1530 Delete by side effect any occurrences of ELT as a member of LIST.
1531 The modified LIST is returned. Comparison is done with `eq'.
1532 If the first member of LIST is ELT, there is no way to remove it by side
1533 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1534 changing the value of `foo'.
1538 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1539 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1543 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1544 Delete by side effect any occurrences of ELT as a member of LIST.
1545 The modified LIST is returned. Comparison is done with `old-eq'.
1546 If the first member of LIST is ELT, there is no way to remove it by side
1547 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1548 changing the value of `foo'.
1552 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1553 (HACKEQ_UNSAFE (elt, list_elt)));
1557 /* Like Fdelq, but caller must ensure that LIST is properly
1558 nil-terminated and ebola-free. */
1561 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1563 LIST_LOOP_DELETE_IF (list_elt, list,
1564 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1568 /* Be VERY careful with this. This is like delq_no_quit() but
1569 also calls free_cons() on the removed conses. You must be SURE
1570 that no pointers to the freed conses remain around (e.g.
1571 someone else is pointing to part of the list). This function
1572 is useful on internal lists that are used frequently and where
1573 the actual list doesn't escape beyond known code bounds. */
1576 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1578 REGISTER Lisp_Object tail = list;
1579 REGISTER Lisp_Object prev = Qnil;
1581 while (!NILP (tail))
1583 REGISTER Lisp_Object tem = XCAR (tail);
1586 Lisp_Object cons_to_free = tail;
1590 XCDR (prev) = XCDR (tail);
1592 free_cons (XCONS (cons_to_free));
1603 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1604 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
1605 The modified ALIST is returned. If the first member of ALIST has a car
1606 that is `equal' to KEY, there is no way to remove it by side effect;
1607 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1612 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1614 internal_equal (key, XCAR (elt), 0)));
1619 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
1621 int speccount = specpdl_depth ();
1622 specbind (Qinhibit_quit, Qt);
1623 return unbind_to (speccount, Fremassoc (key, alist));
1626 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1627 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
1628 The modified ALIST is returned. If the first member of ALIST has a car
1629 that is `eq' to KEY, there is no way to remove it by side effect;
1630 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1635 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1637 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1641 /* no quit, no errors; be careful */
1644 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
1646 LIST_LOOP_DELETE_IF (elt, alist,
1648 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1652 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1653 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
1654 The modified ALIST is returned. If the first member of ALIST has a car
1655 that is `equal' to VALUE, there is no way to remove it by side effect;
1656 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1661 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1663 internal_equal (value, XCDR (elt), 0)));
1667 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1668 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
1669 The modified ALIST is returned. If the first member of ALIST has a car
1670 that is `eq' to VALUE, there is no way to remove it by side effect;
1671 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1676 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1678 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1682 /* Like Fremrassq, fast and unsafe; be careful */
1684 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
1686 LIST_LOOP_DELETE_IF (elt, alist,
1688 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1692 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1693 Reverse LIST by destructively modifying cdr pointers.
1694 Return the beginning of the reversed list.
1695 Also see: `reverse'.
1699 struct gcpro gcpro1, gcpro2;
1700 REGISTER Lisp_Object prev = Qnil;
1701 REGISTER Lisp_Object tail = list;
1703 /* We gcpro our args; see `nconc' */
1704 GCPRO2 (prev, tail);
1705 while (!NILP (tail))
1707 REGISTER Lisp_Object next;
1708 CONCHECK_CONS (tail);
1718 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1719 Reverse LIST, copying. Return the beginning of the reversed list.
1720 See also the function `nreverse', which is used more often.
1724 Lisp_Object reversed_list = Qnil;
1725 EXTERNAL_LIST_LOOP_2 (elt, list)
1727 reversed_list = Fcons (elt, reversed_list);
1729 return reversed_list;
1732 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1733 Lisp_Object lisp_arg,
1734 int (*pred_fn) (Lisp_Object, Lisp_Object,
1735 Lisp_Object lisp_arg));
1738 list_sort (Lisp_Object list,
1739 Lisp_Object lisp_arg,
1740 int (*pred_fn) (Lisp_Object, Lisp_Object,
1741 Lisp_Object lisp_arg))
1743 struct gcpro gcpro1, gcpro2, gcpro3;
1744 Lisp_Object back, tem;
1745 Lisp_Object front = list;
1746 Lisp_Object len = Flength (list);
1751 len = make_int (XINT (len) / 2 - 1);
1752 tem = Fnthcdr (len, list);
1754 Fsetcdr (tem, Qnil);
1756 GCPRO3 (front, back, lisp_arg);
1757 front = list_sort (front, lisp_arg, pred_fn);
1758 back = list_sort (back, lisp_arg, pred_fn);
1760 return list_merge (front, back, lisp_arg, pred_fn);
1765 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1770 /* prevents the GC from happening in call2 */
1771 int speccount = specpdl_depth ();
1772 /* Emacs' GC doesn't actually relocate pointers, so this probably
1773 isn't strictly necessary */
1774 record_unwind_protect (restore_gc_inhibit,
1775 make_int (gc_currently_forbidden));
1776 gc_currently_forbidden = 1;
1777 tmp = call2 (pred, obj1, obj2);
1778 unbind_to (speccount, Qnil);
1786 DEFUN ("sort", Fsort, 2, 2, 0, /*
1787 Sort LIST, stably, comparing elements using PREDICATE.
1788 Returns the sorted list. LIST is modified by side effects.
1789 PREDICATE is called with two elements of LIST, and should return T
1790 if the first element is "less" than the second.
1794 return list_sort (list, predicate, merge_pred_function);
1798 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1801 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1806 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1807 Lisp_Object lisp_arg,
1808 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1814 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1821 /* It is sufficient to protect org_l1 and org_l2.
1822 When l1 and l2 are updated, we copy the new values
1823 back into the org_ vars. */
1825 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1846 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1861 Fsetcdr (tail, tem);
1867 /************************************************************************/
1868 /* property-list functions */
1869 /************************************************************************/
1871 /* For properties of text, we need to do order-insensitive comparison of
1872 plists. That is, we need to compare two plists such that they are the
1873 same if they have the same set of keys, and equivalent values.
1874 So (a 1 b 2) would be equal to (b 2 a 1).
1876 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1877 LAXP means use `equal' for comparisons.
1880 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1881 int laxp, int depth)
1883 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1884 int la, lb, m, i, fill;
1885 Lisp_Object *keys, *vals;
1888 int speccount = specpdl_depth();
1890 if (NILP (a) && NILP (b))
1893 Fcheck_valid_plist (a);
1894 Fcheck_valid_plist (b);
1896 la = XINT (Flength (a));
1897 lb = XINT (Flength (b));
1898 m = (la > lb ? la : lb);
1900 XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
1901 XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
1902 XMALLOC_OR_ALLOCA(flags, m, char);
1904 /* First extract the pairs from A. */
1905 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1907 Lisp_Object k = XCAR (rest);
1908 Lisp_Object v = XCAR (XCDR (rest));
1909 /* Maybe be Ebolified. */
1910 if (nil_means_not_present && NILP (v)) continue;
1916 /* Now iterate over B, and stop if we find something that's not in A,
1917 or that doesn't match. As we match, mark them. */
1918 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1920 Lisp_Object k = XCAR (rest);
1921 Lisp_Object v = XCAR (XCDR (rest));
1922 /* Maybe be Ebolified. */
1923 if (nil_means_not_present && NILP (v)) continue;
1924 for (i = 0; i < fill; i++)
1926 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1929 /* We narrowly escaped being Ebolified here. */
1930 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1931 : !internal_equal (v, vals [i], depth))
1932 /* a property in B has a different value than in A */
1939 /* there are some properties in B that are not in A */
1942 /* Now check to see that all the properties in A were also in B */
1943 for (i = 0; i < fill; i++)
1948 XMALLOC_UNBIND(flags, m, speccount);
1949 XMALLOC_UNBIND(vals, m, speccount);
1950 XMALLOC_UNBIND(keys, m, speccount);
1955 XMALLOC_UNBIND(flags, m, speccount);
1956 XMALLOC_UNBIND(vals, m, speccount);
1957 XMALLOC_UNBIND(keys, m, speccount);
1961 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1962 Return non-nil if property lists A and B are `eq'.
1963 A property list is an alternating list of keywords and values.
1964 This function does order-insensitive comparisons of the property lists:
1965 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1966 Comparison between values is done using `eq'. See also `plists-equal'.
1967 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1968 a nil value is ignored. This feature is a virus that has infected
1969 old Lisp implementations, but should not be used except for backward
1972 (a, b, nil_means_not_present))
1974 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1978 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1979 Return non-nil if property lists A and B are `equal'.
1980 A property list is an alternating list of keywords and values. This
1981 function does order-insensitive comparisons of the property lists: For
1982 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1983 Comparison between values is done using `equal'. See also `plists-eq'.
1984 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1985 a nil value is ignored. This feature is a virus that has infected
1986 old Lisp implementations, but should not be used except for backward
1989 (a, b, nil_means_not_present))
1991 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1996 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1997 Return non-nil if lax property lists A and B are `eq'.
1998 A property list is an alternating list of keywords and values.
1999 This function does order-insensitive comparisons of the property lists:
2000 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2001 Comparison between values is done using `eq'. See also `plists-equal'.
2002 A lax property list is like a regular one except that comparisons between
2003 keywords is done using `equal' instead of `eq'.
2004 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2005 a nil value is ignored. This feature is a virus that has infected
2006 old Lisp implementations, but should not be used except for backward
2009 (a, b, nil_means_not_present))
2011 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
2015 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2016 Return non-nil if lax property lists A and B are `equal'.
2017 A property list is an alternating list of keywords and values. This
2018 function does order-insensitive comparisons of the property lists: For
2019 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2020 Comparison between values is done using `equal'. See also `plists-eq'.
2021 A lax property list is like a regular one except that comparisons between
2022 keywords is done using `equal' instead of `eq'.
2023 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2024 a nil value is ignored. This feature is a virus that has infected
2025 old Lisp implementations, but should not be used except for backward
2028 (a, b, nil_means_not_present))
2030 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
2034 /* Return the value associated with key PROPERTY in property list PLIST.
2035 Return nil if key not found. This function is used for internal
2036 property lists that cannot be directly manipulated by the user.
2040 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2044 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2046 if (EQ (XCAR (tail), property))
2047 return XCAR (XCDR (tail));
2053 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2054 internal_plist_get(). */
2057 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2062 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2064 if (EQ (XCAR (tail), property))
2066 XCAR (XCDR (tail)) = value;
2071 *plist = Fcons (property, Fcons (value, *plist));
2075 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2077 Lisp_Object tail, prev;
2079 for (tail = *plist, prev = Qnil;
2081 tail = XCDR (XCDR (tail)))
2083 if (EQ (XCAR (tail), property))
2086 *plist = XCDR (XCDR (tail));
2088 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2098 /* Called on a malformed property list. BADPLACE should be some
2099 place where truncating will form a good list -- i.e. we shouldn't
2100 result in a list with an odd length. */
2103 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2105 if (ERRB_EQ (errb, ERROR_ME))
2106 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2109 if (ERRB_EQ (errb, ERROR_ME_WARN))
2111 warn_when_safe_lispobj
2114 ("Malformed property list -- list has been truncated"),
2122 /* Called on a circular property list. BADPLACE should be some place
2123 where truncating will result in an even-length list, as above.
2124 If doesn't particularly matter where we truncate -- anywhere we
2125 truncate along the entire list will break the circularity, because
2126 it will create a terminus and the list currently doesn't have one.
2130 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2132 if (ERRB_EQ (errb, ERROR_ME))
2133 return Fsignal (Qcircular_property_list, list1 (*plist));
2136 if (ERRB_EQ (errb, ERROR_ME_WARN))
2138 warn_when_safe_lispobj
2141 ("Circular property list -- list has been truncated"),
2149 /* Advance the tortoise pointer by two (one iteration of a property-list
2150 loop) and the hare pointer by four and verify that no malformations
2151 or circularities exist. If so, return zero and store a value into
2152 RETVAL that should be returned by the calling function. Otherwise,
2153 return 1. See external_plist_get().
2157 advance_plist_pointers (Lisp_Object *plist,
2158 Lisp_Object **tortoise, Lisp_Object **hare,
2159 Error_behavior errb, Lisp_Object *retval)
2162 Lisp_Object *tortsave = *tortoise;
2164 /* Note that our "fixing" may be more brutal than necessary,
2165 but it's the user's own problem, not ours, if they went in and
2166 manually fucked up a plist. */
2168 for (i = 0; i < 2; i++)
2170 /* This is a standard iteration of a defensive-loop-checking
2171 loop. We just do it twice because we want to advance past
2172 both the property and its value.
2174 If the pointer indirection is confusing you, remember that
2175 one level of indirection on the hare and tortoise pointers
2176 is only due to pass-by-reference for this function. The other
2177 level is so that the plist can be fixed in place. */
2179 /* When we reach the end of a well-formed plist, **HARE is
2180 nil. In that case, we don't do anything at all except
2181 advance TORTOISE by one. Otherwise, we advance HARE
2182 by two (making sure it's OK to do so), then advance
2183 TORTOISE by one (it will always be OK to do so because
2184 the HARE is always ahead of the TORTOISE and will have
2185 already verified the path), then make sure TORTOISE and
2186 HARE don't contain the same non-nil object -- if the
2187 TORTOISE and the HARE ever meet, then obviously we're
2188 in a circularity, and if we're in a circularity, then
2189 the TORTOISE and the HARE can't cross paths without
2190 meeting, since the HARE only gains one step over the
2191 TORTOISE per iteration. */
2195 Lisp_Object *haresave = *hare;
2196 if (!CONSP (**hare))
2198 *retval = bad_bad_bunny (plist, haresave, errb);
2201 *hare = &XCDR (**hare);
2202 /* In a non-plist, we'd check here for a nil value for
2203 **HARE, which is OK (it just means the list has an
2204 odd number of elements). In a plist, it's not OK
2205 for the list to have an odd number of elements. */
2206 if (!CONSP (**hare))
2208 *retval = bad_bad_bunny (plist, haresave, errb);
2211 *hare = &XCDR (**hare);
2214 *tortoise = &XCDR (**tortoise);
2215 if (!NILP (**hare) && EQ (**tortoise, **hare))
2217 *retval = bad_bad_turtle (plist, tortsave, errb);
2225 /* Return the value of PROPERTY from PLIST, or Qunbound if
2226 property is not on the list.
2228 PLIST is a Lisp-accessible property list, meaning that it
2229 has to be checked for malformations and circularities.
2231 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2232 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2233 on finding a malformation or a circularity, it issues a warning and
2234 attempts to silently fix the problem.
2236 A pointer to PLIST is passed in so that PLIST can be successfully
2237 "fixed" even if the error is at the beginning of the plist. */
2240 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2241 int laxp, Error_behavior errb)
2243 Lisp_Object *tortoise = plist;
2244 Lisp_Object *hare = plist;
2246 while (!NILP (*tortoise))
2248 Lisp_Object *tortsave = tortoise;
2251 /* We do the standard tortoise/hare march. We isolate the
2252 grungy stuff to do this in advance_plist_pointers(), though.
2253 To us, all this function does is advance the tortoise
2254 pointer by two and the hare pointer by four and make sure
2255 everything's OK. We first advance the pointers and then
2256 check if a property matched; this ensures that our
2257 check for a matching property is safe. */
2259 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2262 if (!laxp ? EQ (XCAR (*tortsave), property)
2263 : internal_equal (XCAR (*tortsave), property, 0))
2264 return XCAR (XCDR (*tortsave));
2270 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2271 malformed or circular plist. Analogous to external_plist_get(). */
2274 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2275 Lisp_Object value, int laxp, Error_behavior errb)
2277 Lisp_Object *tortoise = plist;
2278 Lisp_Object *hare = plist;
2280 while (!NILP (*tortoise))
2282 Lisp_Object *tortsave = tortoise;
2286 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2289 if (!laxp ? EQ (XCAR (*tortsave), property)
2290 : internal_equal (XCAR (*tortsave), property, 0))
2292 XCAR (XCDR (*tortsave)) = value;
2297 *plist = Fcons (property, Fcons (value, *plist));
2301 external_remprop (Lisp_Object *plist, Lisp_Object property,
2302 int laxp, Error_behavior errb)
2304 Lisp_Object *tortoise = plist;
2305 Lisp_Object *hare = plist;
2307 while (!NILP (*tortoise))
2309 Lisp_Object *tortsave = tortoise;
2313 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2316 if (!laxp ? EQ (XCAR (*tortsave), property)
2317 : internal_equal (XCAR (*tortsave), property, 0))
2319 /* Now you see why it's so convenient to have that level
2321 *tortsave = XCDR (XCDR (*tortsave));
2329 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2330 Extract a value from a property list.
2331 PLIST is a property list, which is a list of the form
2332 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
2333 PROPERTY is usually a symbol.
2334 This function returns the value corresponding to the PROPERTY,
2335 or DEFAULT if PROPERTY is not one of the properties on the list.
2337 (plist, property, default_))
2339 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
2340 return UNBOUNDP (value) ? default_ : value;
2343 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2344 Change value in PLIST of PROPERTY to VALUE.
2345 PLIST is a property list, which is a list of the form
2346 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2347 PROPERTY is usually a symbol and VALUE is any object.
2348 If PROPERTY is already a property on the list, its value is set to VALUE,
2349 otherwise the new PROPERTY VALUE pair is added.
2350 The new plist is returned; use `(setq x (plist-put x property value))'
2351 to be sure to use the new value. PLIST is modified by side effect.
2353 (plist, property, value))
2355 external_plist_put (&plist, property, value, 0, ERROR_ME);
2359 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2360 Remove from PLIST the property PROPERTY and its value.
2361 PLIST is a property list, which is a list of the form
2362 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2363 PROPERTY is usually a symbol.
2364 The new plist is returned; use `(setq x (plist-remprop x property))'
2365 to be sure to use the new value. PLIST is modified by side effect.
2369 external_remprop (&plist, property, 0, ERROR_ME);
2373 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2374 Return t if PROPERTY has a value specified in PLIST.
2378 Lisp_Object value = Fplist_get (plist, property, Qunbound);
2379 return UNBOUNDP (value) ? Qnil : Qt;
2382 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2383 Given a plist, signal an error if there is anything wrong with it.
2384 This means that it's a malformed or circular plist.
2388 Lisp_Object *tortoise;
2394 while (!NILP (*tortoise))
2399 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2407 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2408 Given a plist, return non-nil if its format is correct.
2409 If it returns nil, `check-valid-plist' will signal an error when given
2410 the plist; that means it's a malformed or circular plist.
2414 Lisp_Object *tortoise;
2419 while (!NILP (*tortoise))
2424 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2432 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2433 Destructively remove any duplicate entries from a plist.
2434 In such cases, the first entry applies.
2436 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2437 a nil value is removed. This feature is a virus that has infected
2438 old Lisp implementations, but should not be used except for backward
2441 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2442 return value may not be EQ to the passed-in value, so make sure to
2443 `setq' the value back into where it came from.
2445 (plist, nil_means_not_present))
2447 Lisp_Object head = plist;
2449 Fcheck_valid_plist (plist);
2451 while (!NILP (plist))
2453 Lisp_Object prop = Fcar (plist);
2454 Lisp_Object next = Fcdr (plist);
2456 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2457 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2459 if (EQ (head, plist))
2461 plist = Fcdr (next);
2464 /* external_remprop returns 1 if it removed any property.
2465 We have to loop till it didn't remove anything, in case
2466 the property occurs many times. */
2467 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2469 plist = Fcdr (next);
2475 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2476 Extract a value from a lax property list.
2477 LAX-PLIST is a lax property list, which is a list of the form
2478 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2479 properties is done using `equal' instead of `eq'.
2480 PROPERTY is usually a symbol.
2481 This function returns the value corresponding to PROPERTY,
2482 or DEFAULT if PROPERTY is not one of the properties on the list.
2484 (lax_plist, property, default_))
2486 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
2487 return UNBOUNDP (value) ? default_ : value;
2490 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2491 Change value in LAX-PLIST of PROPERTY to VALUE.
2492 LAX-PLIST is a lax property list, which is a list of the form
2493 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2494 properties is done using `equal' instead of `eq'.
2495 PROPERTY is usually a symbol and VALUE is any object.
2496 If PROPERTY is already a property on the list, its value is set to
2497 VALUE, otherwise the new PROPERTY VALUE pair is added.
2498 The new plist is returned; use `(setq x (lax-plist-put x property value))'
2499 to be sure to use the new value. LAX-PLIST is modified by side effect.
2501 (lax_plist, property, value))
2503 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
2507 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2508 Remove from LAX-PLIST the property PROPERTY and its value.
2509 LAX-PLIST is a lax property list, which is a list of the form
2510 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2511 properties is done using `equal' instead of `eq'.
2512 PROPERTY is usually a symbol.
2513 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
2514 to be sure to use the new value. LAX-PLIST is modified by side effect.
2516 (lax_plist, property))
2518 external_remprop (&lax_plist, property, 1, ERROR_ME);
2522 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2523 Return t if PROPERTY has a value specified in LAX-PLIST.
2524 LAX-PLIST is a lax property list, which is a list of the form
2525 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2526 properties is done using `equal' instead of `eq'.
2528 (lax_plist, property))
2530 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
2533 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2534 Destructively remove any duplicate entries from a lax plist.
2535 In such cases, the first entry applies.
2537 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2538 a nil value is removed. This feature is a virus that has infected
2539 old Lisp implementations, but should not be used except for backward
2542 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2543 return value may not be EQ to the passed-in value, so make sure to
2544 `setq' the value back into where it came from.
2546 (lax_plist, nil_means_not_present))
2548 Lisp_Object head = lax_plist;
2550 Fcheck_valid_plist (lax_plist);
2552 while (!NILP (lax_plist))
2554 Lisp_Object prop = Fcar (lax_plist);
2555 Lisp_Object next = Fcdr (lax_plist);
2557 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2558 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2560 if (EQ (head, lax_plist))
2562 lax_plist = Fcdr (next);
2565 /* external_remprop returns 1 if it removed any property.
2566 We have to loop till it didn't remove anything, in case
2567 the property occurs many times. */
2568 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2570 lax_plist = Fcdr (next);
2576 /* In C because the frame props stuff uses it */
2578 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2579 Convert association list ALIST into the equivalent property-list form.
2580 The plist is returned. This converts from
2582 \((a . 1) (b . 2) (c . 3))
2588 The original alist is destroyed in the process of constructing the plist.
2589 See also `alist-to-plist'.
2593 Lisp_Object head = alist;
2594 while (!NILP (alist))
2596 /* remember the alist element. */
2597 Lisp_Object el = Fcar (alist);
2599 Fsetcar (alist, Fcar (el));
2600 Fsetcar (el, Fcdr (el));
2601 Fsetcdr (el, Fcdr (alist));
2602 Fsetcdr (alist, el);
2603 alist = Fcdr (Fcdr (alist));
2609 DEFUN ("get", Fget, 2, 3, 0, /*
2610 Return the value of OBJECT's PROPERTY property.
2611 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2612 If there is no such property, return optional third arg DEFAULT
2613 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2614 face, or glyph. See also `put', `remprop', and `object-plist'.
2616 (object, property, default_))
2618 /* Various places in emacs call Fget() and expect it not to quit,
2622 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2623 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2625 signal_simple_error ("Object type has no properties", object);
2627 return UNBOUNDP (val) ? default_ : val;
2630 DEFUN ("put", Fput, 3, 3, 0, /*
2631 Set OBJECT's PROPERTY to VALUE.
2632 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2633 OBJECT can be a symbol, face, extent, or string.
2634 For a string, no properties currently have predefined meanings.
2635 For the predefined properties for extents, see `set-extent-property'.
2636 For the predefined properties for faces, see `set-face-property'.
2637 See also `get', `remprop', and `object-plist'.
2639 (object, property, value))
2641 CHECK_LISP_WRITEABLE (object);
2643 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2645 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2646 (object, property, value))
2647 signal_simple_error ("Can't set property on object", property);
2650 signal_simple_error ("Object type has no settable properties", object);
2655 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2656 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2657 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2658 if the property list was actually modified (i.e. if PROPERTY was present
2659 in the property list). See also `get', `put', and `object-plist'.
2665 CHECK_LISP_WRITEABLE (object);
2667 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2669 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2671 signal_simple_error ("Can't remove property from object", property);
2674 signal_simple_error ("Object type has no removable properties", object);
2676 return ret ? Qt : Qnil;
2679 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2680 Return a property list of OBJECT's properties.
2681 For a symbol, this is equivalent to `symbol-plist'.
2682 OBJECT can be a symbol, string, extent, face, or glyph.
2683 Do not modify the returned property list directly;
2684 this may or may not have the desired effects. Use `put' instead.
2688 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2689 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2691 signal_simple_error ("Object type has no properties", object);
2698 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2701 error ("Stack overflow in equal");
2703 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2705 /* Note that (equal 20 20.0) should be nil */
2706 if (XTYPE (obj1) != XTYPE (obj2))
2708 if (LRECORDP (obj1))
2710 const struct lrecord_implementation
2711 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2712 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2714 return (imp1 == imp2) &&
2715 /* EQ-ness of the objects was noticed above */
2716 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2722 /* Note that we may be calling sub-objects that will use
2723 internal_equal() (instead of internal_old_equal()). Oh well.
2724 We will get an Ebola note if there's any possibility of confusion,
2725 but that seems unlikely. */
2728 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2731 error ("Stack overflow in equal");
2733 if (HACKEQ_UNSAFE (obj1, obj2))
2735 /* Note that (equal 20 20.0) should be nil */
2736 if (XTYPE (obj1) != XTYPE (obj2))
2739 return internal_equal (obj1, obj2, depth);
2742 DEFUN ("equal", Fequal, 2, 2, 0, /*
2743 Return t if two Lisp objects have similar structure and contents.
2744 They must have the same data type.
2745 Conses are compared by comparing the cars and the cdrs.
2746 Vectors and strings are compared element by element.
2747 Numbers are compared by value. Symbols must match exactly.
2751 return internal_equal (object1, object2, 0) ? Qt : Qnil;
2754 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2755 Return t if two Lisp objects have similar structure and contents.
2756 They must have the same data type.
2757 \(Note, however, that an exception is made for characters and integers;
2758 this is known as the "char-int confoundance disease." See `eq' and
2760 This function is provided only for byte-code compatibility with v19.
2765 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
2769 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2770 Destructively modify ARRAY by replacing each element with ITEM.
2771 ARRAY is a vector, bit vector, or string.
2776 if (STRINGP (array))
2778 Lisp_String *s = XSTRING (array);
2779 Bytecount old_bytecount = string_length (s);
2780 Bytecount new_bytecount;
2781 Bytecount item_bytecount;
2782 Bufbyte item_buf[MAX_EMCHAR_LEN];
2786 CHECK_CHAR_COERCE_INT (item);
2787 CHECK_LISP_WRITEABLE (array);
2789 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2790 new_bytecount = item_bytecount * string_char_length (s);
2792 resize_string (s, -1, new_bytecount - old_bytecount);
2794 for (p = string_data (s), end = p + new_bytecount;
2796 p += item_bytecount)
2797 memcpy (p, item_buf, item_bytecount);
2800 bump_string_modiff (array);
2802 else if (VECTORP (array))
2804 Lisp_Object *p = XVECTOR_DATA (array);
2805 size_t len = XVECTOR_LENGTH (array);
2806 CHECK_LISP_WRITEABLE (array);
2810 else if (BIT_VECTORP (array))
2812 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2813 size_t len = bit_vector_length (v);
2817 CHECK_LISP_WRITEABLE (array);
2819 set_bit_vector_bit (v, len, bit);
2823 array = wrong_type_argument (Qarrayp, array);
2830 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2832 Lisp_Object args[2];
2833 struct gcpro gcpro1;
2840 RETURN_UNGCPRO (bytecode_nconc2 (args));
2844 bytecode_nconc2 (Lisp_Object *args)
2848 if (CONSP (args[0]))
2850 /* (setcdr (last args[0]) args[1]) */
2851 Lisp_Object tortoise, hare;
2854 for (hare = tortoise = args[0], count = 0;
2855 CONSP (XCDR (hare));
2856 hare = XCDR (hare), count++)
2858 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2861 tortoise = XCDR (tortoise);
2862 if (EQ (hare, tortoise))
2863 signal_circular_list_error (args[0]);
2865 XCDR (hare) = args[1];
2868 else if (NILP (args[0]))
2874 args[0] = wrong_type_argument (args[0], Qlistp);
2879 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2880 Concatenate any number of lists by altering them.
2881 Only the last argument is not altered, and need not be a list.
2883 If the first argument is nil, there is no way to modify it by side
2884 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2885 changing the value of `foo'.
2887 (int nargs, Lisp_Object *args))
2890 struct gcpro gcpro1;
2892 /* The modus operandi in Emacs is "caller gc-protects args".
2893 However, nconc (particularly nconc2 ()) is called many times
2894 in Emacs on freshly created stuff (e.g. you see the idiom
2895 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2896 callers out by protecting the args ourselves to save them
2897 a lot of temporary-variable grief. */
2900 gcpro1.nvars = nargs;
2902 while (argnum < nargs)
2909 /* `val' is the first cons, which will be our return value. */
2910 /* `last_cons' will be the cons cell to mutate. */
2911 Lisp_Object last_cons = val;
2912 Lisp_Object tortoise = val;
2914 for (argnum++; argnum < nargs; argnum++)
2916 Lisp_Object next = args[argnum];
2918 if (CONSP (next) || argnum == nargs -1)
2920 /* (setcdr (last val) next) */
2924 CONSP (XCDR (last_cons));
2925 last_cons = XCDR (last_cons), count++)
2927 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2930 tortoise = XCDR (tortoise);
2931 if (EQ (last_cons, tortoise))
2932 signal_circular_list_error (args[argnum-1]);
2934 XCDR (last_cons) = next;
2936 else if (NILP (next))
2942 next = wrong_type_argument (Qlistp, next);
2946 RETURN_UNGCPRO (val);
2948 else if (NILP (val))
2950 else if (argnum == nargs - 1) /* last arg? */
2951 RETURN_UNGCPRO (val);
2954 args[argnum] = wrong_type_argument (Qlistp, val);
2958 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2962 /* This is the guts of several mapping functions.
2963 Apply FUNCTION to each element of SEQUENCE, one by one,
2964 storing the results into elements of VALS, a C vector of Lisp_Objects.
2965 LENI is the length of VALS, which should also be the length of SEQUENCE.
2967 If VALS is a null pointer, do not accumulate the results. */
2970 mapcar1 (size_t leni, Lisp_Object *vals,
2971 Lisp_Object function, Lisp_Object sequence)
2974 Lisp_Object args[2];
2975 struct gcpro gcpro1;
2985 if (LISTP (sequence))
2987 /* A devious `function' could either:
2988 - insert garbage into the list in front of us, causing XCDR to crash
2989 - amputate the list behind us using (setcdr), causing the remaining
2990 elts to lose their GCPRO status.
2992 if (vals != 0) we avoid this by copying the elts into the
2993 `vals' array. By a stroke of luck, `vals' is exactly large
2994 enough to hold the elts left to be traversed as well as the
2995 results computed so far.
2997 if (vals == 0) we don't have any free space available and
2998 don't want to eat up any more stack with alloca().
2999 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
3003 Lisp_Object *val = vals;
3006 LIST_LOOP_2 (elt, sequence)
3009 gcpro1.nvars = leni;
3011 for (i = 0; i < leni; i++)
3014 vals[i] = Ffuncall (2, args);
3019 Lisp_Object elt, tail;
3020 EMACS_INT len_unused;
3021 struct gcpro ngcpro1;
3026 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
3036 else if (VECTORP (sequence))
3038 Lisp_Object *objs = XVECTOR_DATA (sequence);
3040 for (i = 0; i < leni; i++)
3043 result = Ffuncall (2, args);
3044 if (vals) vals[gcpro1.nvars++] = result;
3047 else if (STRINGP (sequence))
3049 /* The string data of `sequence' might be relocated during GC. */
3050 Bytecount slen = XSTRING_LENGTH (sequence);
3052 Bufbyte *end = NULL;
3053 int speccount = specpdl_depth();
3055 XMALLOC_OR_ALLOCA(p, slen, Bufbyte);
3058 memcpy (p, XSTRING_DATA (sequence), slen);
3062 args[1] = make_char (charptr_emchar (p));
3064 result = Ffuncall (2, args);
3065 if (vals) vals[gcpro1.nvars++] = result;
3067 XMALLOC_UNBIND(p, slen, speccount);
3069 else if (BIT_VECTORP (sequence))
3071 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3073 for (i = 0; i < leni; i++)
3075 args[1] = make_int (bit_vector_bit (v, i));
3076 result = Ffuncall (2, args);
3077 if (vals) vals[gcpro1.nvars++] = result;
3081 ABORT (); /* unreachable, since Flength (sequence) did not get an error */
3087 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3088 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
3089 Between each pair of results, insert SEPARATOR.
3091 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
3092 results in spaces between the values returned by FUNCTION. SEQUENCE itself
3093 may be a list, a vector, a bit vector, or a string.
3095 (function, sequence, separator))
3097 EMACS_INT len = XINT (Flength (sequence));
3101 EMACS_INT nargs = len + len - 1;
3102 int speccount = specpdl_depth();
3104 if (len == 0) return build_string ("");
3106 XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
3108 mapcar1 (len, args, function, sequence);
3110 for (i = len - 1; i >= 0; i--)
3111 args[i + i] = args[i];
3113 for (i = 1; i < nargs; i += 2)
3114 args[i] = separator;
3116 result = Fconcat(nargs, args);
3117 XMALLOC_UNBIND(args, nargs, speccount);
3121 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3122 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3123 The result is a list of the same length as SEQUENCE.
3124 SEQUENCE may be a list, a vector, a bit vector, or a string.
3126 (function, sequence))
3128 size_t len = XINT (Flength (sequence));
3129 Lisp_Object *args = NULL;
3131 int speccount = specpdl_depth();
3133 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
3135 mapcar1 (len, args, function, sequence);
3137 result = Flist(len, args);
3138 XMALLOC_UNBIND(args, len, speccount);
3142 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3143 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3144 The result is a vector of the same length as SEQUENCE.
3145 SEQUENCE may be a list, a vector, a bit vector, or a string.
3147 (function, sequence))
3149 size_t len = XINT (Flength (sequence));
3150 Lisp_Object result = make_vector (len, Qnil);
3151 struct gcpro gcpro1;
3154 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3160 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3161 Apply FUNCTION to each element of SEQUENCE.
3162 SEQUENCE may be a list, a vector, a bit vector, or a string.
3163 This function is like `mapcar' but does not accumulate the results,
3164 which is more efficient if you do not use the results.
3166 The difference between this and `mapc' is that `mapc' supports all
3167 the spiffy Common Lisp arguments. You should normally use `mapc'.
3169 (function, sequence))
3171 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3179 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3180 Destructively replace the list OLD with NEW.
3181 This is like (copy-sequence NEW) except that it reuses the
3182 conses in OLD as much as possible. If OLD and NEW are the same
3183 length, no consing will take place.
3187 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
3189 EXTERNAL_LIST_LOOP (tail, new)
3191 if (!NILP (oldtail))
3193 CHECK_CONS (oldtail);
3194 XCAR (oldtail) = XCAR (tail);
3196 else if (!NILP (prevoldtail))
3198 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
3199 prevoldtail = XCDR (prevoldtail);
3202 old = oldtail = Fcons (XCAR (tail), Qnil);
3204 if (!NILP (oldtail))
3206 prevoldtail = oldtail;
3207 oldtail = XCDR (oldtail);
3211 if (!NILP (prevoldtail))
3212 XCDR (prevoldtail) = Qnil;
3220 /* #### this function doesn't belong in this file! */
3222 #ifdef HAVE_GETLOADAVG
3223 #ifdef HAVE_SYS_LOADAVG_H
3224 #include <sys/loadavg.h>
3227 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
3230 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3231 Return list of 1 minute, 5 minute and 15 minute load averages.
3232 Each of the three load averages is multiplied by 100,
3233 then converted to integer.
3235 When USE-FLOATS is non-nil, floats will be used instead of integers.
3236 These floats are not multiplied by 100.
3238 If the 5-minute or 15-minute load averages are not available, return a
3239 shortened list, containing only those averages which are available.
3241 On some systems, this won't work due to permissions on /dev/kmem,
3242 in which case you can't use this.
3247 int loads = getloadavg (load_ave, countof (load_ave));
3248 Lisp_Object ret = Qnil;
3251 error ("load-average not implemented for this operating system");
3253 signal_simple_error ("Could not get load-average",
3254 lisp_strerror (errno));
3258 Lisp_Object load = (NILP (use_floats) ?
3259 make_int ((int) (100.0 * load_ave[loads]))
3260 : make_float (load_ave[loads]));
3261 ret = Fcons (load, ret);
3267 Lisp_Object Vfeatures;
3269 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3270 Return non-nil if feature FEXP is present in this Emacs.
3271 Use this to conditionalize execution of lisp code based on the
3272 presence or absence of emacs or environment extensions.
3273 FEXP can be a symbol, a number, or a list.
3274 If it is a symbol, that symbol is looked up in the `features' variable,
3275 and non-nil will be returned if found.
3276 If it is a number, the function will return non-nil if this Emacs
3277 has an equal or greater version number than FEXP.
3278 If it is a list whose car is the symbol `and', it will return
3279 non-nil if all the features in its cdr are non-nil.
3280 If it is a list whose car is the symbol `or', it will return non-nil
3281 if any of the features in its cdr are non-nil.
3282 If it is a list whose car is the symbol `not', it will return
3283 non-nil if the feature is not present.
3288 => ; Non-nil on XEmacs.
3290 (featurep '(and xemacs gnus))
3291 => ; Non-nil on XEmacs with Gnus loaded.
3293 (featurep '(or tty-frames (and emacs 19.30)))
3294 => ; Non-nil if this Emacs supports TTY frames.
3296 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3297 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3299 (featurep '(and xemacs 21.02))
3300 => ; Non-nil on XEmacs 21.2 and later.
3302 NOTE: The advanced arguments of this function (anything other than a
3303 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3304 for supporting multiple Emacs variants, lobby Richard Stallman at
3305 <bug-gnu-emacs@gnu.org>.
3309 #ifndef FEATUREP_SYNTAX
3310 CHECK_SYMBOL (fexp);
3311 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3312 #else /* FEATUREP_SYNTAX */
3313 static double featurep_emacs_version;
3315 /* Brute force translation from Erik Naggum's lisp function. */
3318 /* Original definition */
3319 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3321 else if (INTP (fexp) || FLOATP (fexp))
3323 double d = extract_float (fexp);
3325 if (featurep_emacs_version == 0.0)
3327 featurep_emacs_version = XINT (Vemacs_major_version) +
3328 (XINT (Vemacs_minor_version) / 100.0);
3330 return featurep_emacs_version >= d ? Qt : Qnil;
3332 else if (CONSP (fexp))
3334 Lisp_Object tem = XCAR (fexp);
3340 negate = Fcar (tem);
3342 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3344 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3346 else if (EQ (tem, Qand))
3349 /* Use Fcar/Fcdr for error-checking. */
3350 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3354 return NILP (tem) ? Qt : Qnil;
3356 else if (EQ (tem, Qor))
3359 /* Use Fcar/Fcdr for error-checking. */
3360 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3364 return NILP (tem) ? Qnil : Qt;
3368 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3373 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3376 #endif /* FEATUREP_SYNTAX */
3378 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3379 Announce that FEATURE is a feature of the current Emacs.
3380 This function updates the value of the variable `features'.
3385 CHECK_SYMBOL (feature);
3386 if (!NILP (Vautoload_queue))
3387 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3388 tem = Fmemq (feature, Vfeatures);
3390 Vfeatures = Fcons (feature, Vfeatures);
3391 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3395 DEFUN ("require", Frequire, 1, 2, 0, /*
3396 If feature FEATURE is not loaded, load it from FILENAME.
3397 If FEATURE is not a member of the list `features', then the feature
3398 is not loaded; so load the file FILENAME.
3399 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3401 (feature, filename))
3404 CHECK_SYMBOL (feature);
3405 tem = Fmemq (feature, Vfeatures);
3406 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3411 int speccount = specpdl_depth ();
3413 /* Value saved here is to be restored into Vautoload_queue */
3414 record_unwind_protect (un_autoload, Vautoload_queue);
3415 Vautoload_queue = Qt;
3417 call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
3420 tem = Fmemq (feature, Vfeatures);
3422 error ("Required feature %s was not provided",
3423 string_data (XSYMBOL (feature)->name));
3425 /* Once loading finishes, don't undo it. */
3426 Vautoload_queue = Qt;
3427 return unbind_to (speccount, feature);
3431 /* base64 encode/decode functions.
3433 Originally based on code from GNU recode. Ported to FSF Emacs by
3434 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3435 subsequently heavily hacked by Hrvoje Niksic. */
3437 #define MIME_LINE_LENGTH 72
3439 #define IS_ASCII(Character) \
3441 #define IS_BASE64(Character) \
3442 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3444 /* Table of characters coding the 64 values. */
3445 static char base64_value_to_char[64] =
3447 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3448 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3449 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3450 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3451 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3452 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3453 '8', '9', '+', '/' /* 60-63 */
3456 /* Table of base64 values for first 128 characters. */
3457 static short base64_char_to_value[128] =
3459 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3460 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3461 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3462 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3463 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3464 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3465 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3466 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3467 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3468 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3469 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3470 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3471 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3474 /* The following diagram shows the logical steps by which three octets
3475 get transformed into four base64 characters.
3477 .--------. .--------. .--------.
3478 |aaaaaabb| |bbbbcccc| |ccdddddd|
3479 `--------' `--------' `--------'
3481 .--------+--------+--------+--------.
3482 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3483 `--------+--------+--------+--------'
3485 .--------+--------+--------+--------.
3486 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3487 `--------+--------+--------+--------'
3489 The octets are divided into 6 bit chunks, which are then encoded into
3490 base64 characters. */
3492 #define ADVANCE_INPUT(c, stream) \
3493 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3495 (signal_simple_error ("Non-ascii character in base64 input", \
3496 make_char (ec)), 0) \
3497 : (c = (Bufbyte)ec), 1))
3500 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3502 EMACS_INT counter = 0;
3510 if (!ADVANCE_INPUT (c, istream))
3513 /* Wrap line every 76 characters. */
3516 if (counter < MIME_LINE_LENGTH / 4)
3525 /* Process first byte of a triplet. */
3526 *e++ = base64_value_to_char[0x3f & c >> 2];
3527 value = (0x03 & c) << 4;
3529 /* Process second byte of a triplet. */
3530 if (!ADVANCE_INPUT (c, istream))
3532 *e++ = base64_value_to_char[value];
3538 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3539 value = (0x0f & c) << 2;
3541 /* Process third byte of a triplet. */
3542 if (!ADVANCE_INPUT (c, istream))
3544 *e++ = base64_value_to_char[value];
3549 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3550 *e++ = base64_value_to_char[0x3f & c];
3555 #undef ADVANCE_INPUT
3557 /* Get next character from the stream, except that non-base64
3558 characters are ignored. This is in accordance with rfc2045. EC
3559 should be an Emchar, so that it can hold -1 as the value for EOF. */
3560 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3561 ec = Lstream_get_emchar (stream); \
3563 /* IS_BASE64 may not be called with negative arguments so check for \
3565 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3569 #define STORE_BYTE(pos, val, ccnt) do { \
3570 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3575 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3579 EMACS_INT streampos = 0;
3584 unsigned long value;
3586 /* Process first byte of a quadruplet. */
3587 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3591 signal_simple_error ("Illegal `=' character while decoding base64",
3592 make_int (streampos));
3593 value = base64_char_to_value[ec] << 18;
3595 /* Process second byte of a quadruplet. */
3596 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3598 error ("Premature EOF while decoding base64");
3600 signal_simple_error ("Illegal `=' character while decoding base64",
3601 make_int (streampos));
3602 value |= base64_char_to_value[ec] << 12;
3603 STORE_BYTE (e, value >> 16, ccnt);
3605 /* Process third byte of a quadruplet. */
3606 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3608 error ("Premature EOF while decoding base64");
3612 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3614 error ("Premature EOF while decoding base64");
3616 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3617 make_int (streampos));
3621 value |= base64_char_to_value[ec] << 6;
3622 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3624 /* Process fourth byte of a quadruplet. */
3625 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3627 error ("Premature EOF while decoding base64");
3631 value |= base64_char_to_value[ec];
3632 STORE_BYTE (e, 0xff & value, ccnt);
3638 #undef ADVANCE_INPUT
3639 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3643 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3644 Base64-encode the region between START and END.
3645 Return the length of the encoded text.
3646 Optional third argument NO-LINE-BREAK means do not break long lines
3649 (start, end, no_line_break))
3652 Bytind encoded_length;
3653 Charcount allength, length;
3654 struct buffer *buf = current_buffer;
3655 Bufpos begv, zv, old_pt = BUF_PT (buf);
3657 int speccount = specpdl_depth();
3659 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3660 barf_if_buffer_read_only (buf, begv, zv);
3662 /* We need to allocate enough room for encoding the text.
3663 We need 33 1/3% more space, plus a newline every 76
3664 characters, and then we round up. */
3666 allength = length + length/3 + 1;
3667 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3669 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3670 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3671 base64 characters will be single-byte. */
3672 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3673 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3674 NILP (no_line_break));
3675 if (encoded_length > allength)
3677 Lstream_delete (XLSTREAM (input));
3679 /* Now we have encoded the region, so we insert the new contents
3680 and delete the old. (Insert first in order to preserve markers.) */
3681 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3682 XMALLOC_UNBIND (encoded, allength, speccount);
3683 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3685 /* Simulate FSF Emacs implementation of this function: if point was
3686 in the region, place it at the beginning. */
3687 if (old_pt >= begv && old_pt < zv)
3688 BUF_SET_PT (buf, begv);
3690 /* We return the length of the encoded text. */
3691 return make_int (encoded_length);
3694 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3695 Base64 encode STRING and return the result.
3696 Optional argument NO-LINE-BREAK means do not break long lines
3699 (string, no_line_break))
3701 Charcount allength, length;
3702 Bytind encoded_length;
3704 Lisp_Object input, result;
3705 int speccount = specpdl_depth();
3707 CHECK_STRING (string);
3709 length = XSTRING_CHAR_LENGTH (string);
3710 allength = length + length/3 + 1;
3711 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3713 input = make_lisp_string_input_stream (string, 0, -1);
3714 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3715 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3716 NILP (no_line_break));
3717 if (encoded_length > allength)
3719 Lstream_delete (XLSTREAM (input));
3720 result = make_string (encoded, encoded_length);
3721 XMALLOC_UNBIND (encoded, allength, speccount);
3725 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3726 Base64-decode the region between START and END.
3727 Return the length of the decoded text.
3728 If the region can't be decoded, return nil and don't modify the buffer.
3729 Characters out of the base64 alphabet are ignored.
3733 struct buffer *buf = current_buffer;
3734 Bufpos begv, zv, old_pt = BUF_PT (buf);
3736 Bytind decoded_length;
3737 Charcount length, cc_decoded_length;
3739 int speccount = specpdl_depth();
3741 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3742 barf_if_buffer_read_only (buf, begv, zv);
3746 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3747 /* We need to allocate enough room for decoding the text. */
3748 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3749 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3750 if (decoded_length > length * MAX_EMCHAR_LEN)
3752 Lstream_delete (XLSTREAM (input));
3754 /* Now we have decoded the region, so we insert the new contents
3755 and delete the old. (Insert first in order to preserve markers.) */
3756 BUF_SET_PT (buf, begv);
3757 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3758 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3759 buffer_delete_range (buf, begv + cc_decoded_length,
3760 zv + cc_decoded_length, 0);
3762 /* Simulate FSF Emacs implementation of this function: if point was
3763 in the region, place it at the beginning. */
3764 if (old_pt >= begv && old_pt < zv)
3765 BUF_SET_PT (buf, begv);
3767 return make_int (cc_decoded_length);
3770 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3771 Base64-decode STRING and return the result.
3772 Characters out of the base64 alphabet are ignored.
3777 Bytind decoded_length;
3778 Charcount length, cc_decoded_length;
3779 Lisp_Object input, result;
3780 int speccount = specpdl_depth();
3782 CHECK_STRING (string);
3784 length = XSTRING_CHAR_LENGTH (string);
3785 /* We need to allocate enough room for decoding the text. */
3786 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3788 input = make_lisp_string_input_stream (string, 0, -1);
3789 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3790 &cc_decoded_length);
3791 if (decoded_length > length * MAX_EMCHAR_LEN)
3793 Lstream_delete (XLSTREAM (input));
3795 result = make_string (decoded, decoded_length);
3796 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3800 Lisp_Object Qyes_or_no_p;
3805 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3807 defsymbol (&Qstring_lessp, "string-lessp");
3808 defsymbol (&Qidentity, "identity");
3809 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3811 DEFSUBR (Fidentity);
3814 DEFSUBR (Fsafe_length);
3815 DEFSUBR (Fstring_equal);
3816 DEFSUBR (Fstring_lessp);
3817 DEFSUBR (Fstring_modified_tick);
3821 DEFSUBR (Fbvconcat);
3822 DEFSUBR (Fcopy_list);
3823 DEFSUBR (Fcopy_sequence);
3824 DEFSUBR (Fcopy_alist);
3825 DEFSUBR (Fcopy_tree);
3826 DEFSUBR (Fsubstring);
3833 DEFSUBR (Fnbutlast);
3835 DEFSUBR (Fold_member);
3837 DEFSUBR (Fold_memq);
3839 DEFSUBR (Fold_assoc);
3841 DEFSUBR (Fold_assq);
3843 DEFSUBR (Fold_rassoc);
3845 DEFSUBR (Fold_rassq);
3847 DEFSUBR (Fold_delete);
3849 DEFSUBR (Fold_delq);
3850 DEFSUBR (Fremassoc);
3852 DEFSUBR (Fremrassoc);
3853 DEFSUBR (Fremrassq);
3854 DEFSUBR (Fnreverse);
3857 DEFSUBR (Fplists_eq);
3858 DEFSUBR (Fplists_equal);
3859 DEFSUBR (Flax_plists_eq);
3860 DEFSUBR (Flax_plists_equal);
3861 DEFSUBR (Fplist_get);
3862 DEFSUBR (Fplist_put);
3863 DEFSUBR (Fplist_remprop);
3864 DEFSUBR (Fplist_member);
3865 DEFSUBR (Fcheck_valid_plist);
3866 DEFSUBR (Fvalid_plist_p);
3867 DEFSUBR (Fcanonicalize_plist);
3868 DEFSUBR (Flax_plist_get);
3869 DEFSUBR (Flax_plist_put);
3870 DEFSUBR (Flax_plist_remprop);
3871 DEFSUBR (Flax_plist_member);
3872 DEFSUBR (Fcanonicalize_lax_plist);
3873 DEFSUBR (Fdestructive_alist_to_plist);
3877 DEFSUBR (Fobject_plist);
3879 DEFSUBR (Fold_equal);
3880 DEFSUBR (Ffillarray);
3883 DEFSUBR (Fmapvector);
3884 DEFSUBR (Fmapc_internal);
3885 DEFSUBR (Fmapconcat);
3886 DEFSUBR (Freplace_list);
3887 DEFSUBR (Fload_average);
3888 DEFSUBR (Ffeaturep);
3891 DEFSUBR (Fbase64_encode_region);
3892 DEFSUBR (Fbase64_encode_string);
3893 DEFSUBR (Fbase64_decode_region);
3894 DEFSUBR (Fbase64_decode_string);
3898 init_provide_once (void)
3900 DEFVAR_LISP ("features", &Vfeatures /*
3901 A list of symbols which are the features of the executing emacs.
3902 Used by `featurep' and `require', and altered by `provide'.
3906 Fprovide (intern ("base64"));