1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 2002, 2003, 2004, 2008 MORIOKA Tomohiko
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Mule 2.0, FSF 19.30. */
25 /* This file has been Mule-ized. */
27 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
29 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
55 static Lisp_Object free_malloced_ptr(Lisp_Object unwind_obj)
57 void *ptr = (void *)get_opaque_ptr(unwind_obj);
59 free_opaque_ptr(unwind_obj);
63 /* Don't use alloca for regions larger than this, lest we overflow
65 #define MAX_ALLOCA 65536
67 /* We need to setup proper unwinding, because there is a number of
68 ways these functions can blow up, and we don't want to have memory
69 leaks in those cases. */
70 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
71 size_t XOA_len = (len); \
72 if (XOA_len > MAX_ALLOCA ) { \
73 ptr = xnew_array (type, XOA_len); \
74 record_unwind_protect (free_malloced_ptr, \
75 make_opaque_ptr ((void *)ptr)); \
78 ptr = alloca_array (type, XOA_len); \
81 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
82 if ((len) > MAX_ALLOCA) \
83 unbind_to (speccount, Qnil); \
89 /* NOTE: This symbol is also used in lread.c */
90 #define FEATUREP_SYNTAX
92 Lisp_Object Qstring_lessp;
93 Lisp_Object Qidentity;
95 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
96 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
99 mark_bit_vector (Lisp_Object obj)
105 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
108 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
109 size_t len = bit_vector_length (v);
112 if (INTP (Vprint_length))
113 last = min ((EMACS_INT) len, XINT (Vprint_length));
114 write_c_string ("#*", printcharfun);
115 for (i = 0; i < last; i++)
117 if (bit_vector_bit (v, i))
118 write_c_string ("1", printcharfun);
120 write_c_string ("0", printcharfun);
124 write_c_string ("...", printcharfun);
128 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
130 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
131 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
133 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
134 !memcmp (v1->bits, v2->bits,
135 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
140 bit_vector_hash (Lisp_Object obj, int depth)
142 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
143 return HASH2 (bit_vector_length (v),
144 memory_hash (v->bits,
145 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
150 size_bit_vector (const void *lheader)
152 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
153 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits,
154 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
157 static const struct lrecord_description bit_vector_description[] = {
158 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
163 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
164 mark_bit_vector, print_bit_vector, 0,
165 bit_vector_equal, bit_vector_hash,
166 bit_vector_description, size_bit_vector,
169 DEFUN ("identity", Fidentity, 1, 1, 0, /*
170 Return the argument unchanged.
177 extern long get_random (void);
178 extern void seed_random (long arg);
180 DEFUN ("random", Frandom, 0, 1, 0, /*
181 Return a pseudo-random number.
182 All integers representable in Lisp are equally likely.
183 On most systems, this is 31 bits' worth.
184 With positive integer argument N, return random number in interval [0,N).
185 With argument t, set the random number seed from the current time and pid.
190 unsigned long denominator;
193 seed_random (getpid () + time (NULL));
194 if (NATNUMP (limit) && !ZEROP (limit))
196 /* Try to take our random number from the higher bits of VAL,
197 not the lower, since (says Gentzel) the low bits of `random'
198 are less random than the higher ones. We do this by using the
199 quotient rather than the remainder. At the high end of the RNG
200 it's possible to get a quotient larger than limit; discarding
201 these values eliminates the bias that would otherwise appear
202 when using a large limit. */
203 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
205 val = get_random () / denominator;
206 while (val >= XINT (limit));
211 return make_int (val);
214 /* Random data-structure functions */
216 #ifdef LOSING_BYTECODE
218 /* #### Delete this shit */
220 /* Charcount is a misnomer here as we might be dealing with the
221 length of a vector or list, but emphasizes that we're not dealing
222 with Bytecounts in strings */
224 length_with_bytecode_hack (Lisp_Object seq)
226 if (!COMPILED_FUNCTIONP (seq))
227 return XINT (Flength (seq));
230 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
232 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
233 f->flags.domainp ? COMPILED_DOMAIN :
239 #endif /* LOSING_BYTECODE */
242 check_losing_bytecode (const char *function, Lisp_Object seq)
244 if (COMPILED_FUNCTIONP (seq))
247 "As of 20.3, `%s' no longer works with compiled-function objects",
251 DEFUN ("length", Flength, 1, 1, 0, /*
252 Return the length of vector, bit vector, list or string SEQUENCE.
257 if (STRINGP (sequence))
258 return make_int (XSTRING_CHAR_LENGTH (sequence));
259 else if (CONSP (sequence))
262 GET_EXTERNAL_LIST_LENGTH (sequence, len);
263 return make_int (len);
265 else if (VECTORP (sequence))
266 return make_int (XVECTOR_LENGTH (sequence));
267 else if (NILP (sequence))
269 else if (BIT_VECTORP (sequence))
270 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
273 check_losing_bytecode ("length", sequence);
274 sequence = wrong_type_argument (Qsequencep, sequence);
279 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
280 Return the length of a list, but avoid error or infinite loop.
281 This function never gets an error. If LIST is not really a list,
282 it returns 0. If LIST is circular, it returns a finite value
283 which is at least the number of distinct elements.
287 Lisp_Object hare, tortoise;
290 for (hare = tortoise = list, len = 0;
291 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
292 hare = XCDR (hare), len++)
295 tortoise = XCDR (tortoise);
298 return make_int (len);
301 /*** string functions. ***/
303 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
304 Return t if two strings have identical contents.
305 Case is significant. Text properties are ignored.
306 \(Under XEmacs, `equal' also ignores text properties and extents in
307 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
308 `equal' is the same as in XEmacs, in that respect.)
309 Symbols are also allowed; their print names are used instead.
314 Lisp_String *p1, *p2;
316 if (SYMBOLP (string1))
317 p1 = XSYMBOL (string1)->name;
320 CHECK_STRING (string1);
321 p1 = XSTRING (string1);
324 if (SYMBOLP (string2))
325 p2 = XSYMBOL (string2)->name;
328 CHECK_STRING (string2);
329 p2 = XSTRING (string2);
332 return (((len = string_length (p1)) == string_length (p2)) &&
333 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
337 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
338 Return t if first arg string is less than second in lexicographic order.
339 If I18N2 support (but not Mule support) was compiled in, ordering is
340 determined by the locale. (Case is significant for the default C locale.)
341 In all other cases, comparison is simply done on a character-by-
342 character basis using the numeric value of a character. (Note that
343 this may not produce particularly meaningful results under Mule if
344 characters from different charsets are being compared.)
346 Symbols are also allowed; their print names are used instead.
348 The reason that the I18N2 locale-specific collation is not used under
349 Mule is that the locale model of internationalization does not handle
350 multiple charsets and thus has no hope of working properly under Mule.
351 What we really should do is create a collation table over all built-in
352 charsets. This is extremely difficult to do from scratch, however.
354 Unicode is a good first step towards solving this problem. In fact,
355 it is quite likely that a collation table exists (or will exist) for
356 Unicode. When Unicode support is added to XEmacs/Mule, this problem
361 Lisp_String *p1, *p2;
365 if (SYMBOLP (string1))
366 p1 = XSYMBOL (string1)->name;
369 CHECK_STRING (string1);
370 p1 = XSTRING (string1);
373 if (SYMBOLP (string2))
374 p2 = XSYMBOL (string2)->name;
377 CHECK_STRING (string2);
378 p2 = XSTRING (string2);
381 end = string_char_length (p1);
382 len2 = string_char_length (p2);
386 #if defined (I18N2) && !defined (MULE)
387 /* There is no hope of this working under Mule. Even if we converted
388 the data into an external format so that strcoll() processed it
389 properly, it would still not work because strcoll() does not
390 handle multiple locales. This is the fundamental flaw in the
393 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
394 /* Compare strings using collation order of locale. */
395 /* Need to be tricky to handle embedded nulls. */
397 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
399 int val = strcoll ((char *) string_data (p1) + i,
400 (char *) string_data (p2) + i);
407 #else /* not I18N2, or MULE */
409 Bufbyte *ptr1 = string_data (p1);
410 Bufbyte *ptr2 = string_data (p2);
412 /* #### It is not really necessary to do this: We could compare
413 byte-by-byte and still get a reasonable comparison, since this
414 would compare characters with a charset in the same way. With
415 a little rearrangement of the leading bytes, we could make most
416 inter-charset comparisons work out the same, too; even if some
417 don't, this is not a big deal because inter-charset comparisons
418 aren't really well-defined anyway. */
419 for (i = 0; i < end; i++)
421 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
422 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
427 #endif /* not I18N2, or MULE */
428 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
429 won't work right in I18N2 case */
430 return end < len2 ? Qt : Qnil;
433 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
434 Return STRING's tick counter, incremented for each change to the string.
435 Each string has a tick counter which is incremented each time the contents
436 of the string are changed (e.g. with `aset'). It wraps around occasionally.
442 CHECK_STRING (string);
443 s = XSTRING (string);
444 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
445 return XCAR (s->plist);
451 bump_string_modiff (Lisp_Object str)
453 Lisp_String *s = XSTRING (str);
454 Lisp_Object *ptr = &s->plist;
457 /* #### remove the `string-translatable' property from the string,
460 /* skip over extent info if it's there */
461 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
463 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
464 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
466 *ptr = Fcons (make_int (1), *ptr);
470 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
471 static Lisp_Object concat (int nargs, Lisp_Object *args,
472 enum concat_target_type target_type,
476 concat2 (Lisp_Object string1, Lisp_Object string2)
481 return concat (2, args, c_string, 0);
485 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
491 return concat (3, args, c_string, 0);
495 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
500 return concat (2, args, c_vector, 0);
504 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
510 return concat (3, args, c_vector, 0);
513 DEFUN ("append", Fappend, 0, MANY, 0, /*
514 Concatenate all the arguments and make the result a list.
515 The result is a list whose elements are the elements of all the arguments.
516 Each argument may be a list, vector, bit vector, or string.
517 The last argument is not copied, just used as the tail of the new list.
520 (int nargs, Lisp_Object *args))
522 return concat (nargs, args, c_cons, 1);
525 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
526 Concatenate all the arguments and make the result a string.
527 The result is a string whose elements are the elements of all the arguments.
528 Each argument may be a string or a list or vector of characters.
530 As of XEmacs 21.0, this function does NOT accept individual integers
531 as arguments. Old code that relies on, for example, (concat "foo" 50)
532 returning "foo50" will fail. To fix such code, either apply
533 `int-to-string' to the integer argument, or use `format'.
535 (int nargs, Lisp_Object *args))
537 return concat (nargs, args, c_string, 0);
540 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
541 Concatenate all the arguments and make the result a vector.
542 The result is a vector whose elements are the elements of all the arguments.
543 Each argument may be a list, vector, bit vector, or string.
545 (int nargs, Lisp_Object *args))
547 return concat (nargs, args, c_vector, 0);
550 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
551 Concatenate all the arguments and make the result a bit vector.
552 The result is a bit vector whose elements are the elements of all the
553 arguments. Each argument may be a list, vector, bit vector, or string.
555 (int nargs, Lisp_Object *args))
557 return concat (nargs, args, c_bit_vector, 0);
560 /* Copy a (possibly dotted) list. LIST must be a cons.
561 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
563 copy_list (Lisp_Object list)
565 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
566 Lisp_Object last = list_copy;
567 Lisp_Object hare, tortoise;
570 for (tortoise = hare = XCDR (list), len = 1;
572 hare = XCDR (hare), len++)
574 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
577 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
580 tortoise = XCDR (tortoise);
581 if (EQ (tortoise, hare))
582 signal_circular_list_error (list);
588 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
589 Return a copy of list LIST, which may be a dotted list.
590 The elements of LIST are not copied; they are shared
596 if (NILP (list)) return list;
597 if (CONSP (list)) return copy_list (list);
599 list = wrong_type_argument (Qlistp, list);
603 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
604 Return a copy of list, vector, bit vector or string SEQUENCE.
605 The elements of a list or vector are not copied; they are shared
606 with the original. SEQUENCE may be a dotted list.
611 if (NILP (sequence)) return sequence;
612 if (CONSP (sequence)) return copy_list (sequence);
613 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
614 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
615 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
617 check_losing_bytecode ("copy-sequence", sequence);
618 sequence = wrong_type_argument (Qsequencep, sequence);
622 struct merge_string_extents_struct
625 Bytecount entry_offset;
626 Bytecount entry_length;
630 concat (int nargs, Lisp_Object *args,
631 enum concat_target_type target_type,
635 Lisp_Object tail = Qnil;
638 Lisp_Object last_tail;
640 struct merge_string_extents_struct *args_mse = 0;
641 Bufbyte *string_result = 0;
642 Bufbyte *string_result_ptr = 0;
644 int speccount = specpdl_depth();
645 Charcount total_length;
647 /* The modus operandi in Emacs is "caller gc-protects args".
648 However, concat is called many times in Emacs on freshly
649 created stuff. So we help those callers out by protecting
650 the args ourselves to save them a lot of temporary-variable
654 gcpro1.nvars = nargs;
657 /* #### if the result is a string and any of the strings have a string
658 for the `string-translatable' property, then concat should also
659 concat the args but use the `string-translatable' strings, and store
660 the result in the returned string's `string-translatable' property. */
662 if (target_type == c_string)
663 XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
665 /* In append, the last arg isn't treated like the others */
666 if (last_special && nargs > 0)
669 last_tail = args[nargs];
674 /* Check and coerce the arguments. */
675 for (argnum = 0; argnum < nargs; argnum++)
677 Lisp_Object seq = args[argnum];
680 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
682 #ifdef LOSING_BYTECODE
683 else if (COMPILED_FUNCTIONP (seq))
684 /* Urk! We allow this, for "compatibility"... */
687 #if 0 /* removed for XEmacs 21 */
689 /* This is too revolting to think about but maintains
690 compatibility with FSF (and lots and lots of old code). */
691 args[argnum] = Fnumber_to_string (seq);
695 check_losing_bytecode ("concat", seq);
696 args[argnum] = wrong_type_argument (Qsequencep, seq);
702 args_mse[argnum].string = seq;
704 args_mse[argnum].string = Qnil;
709 /* Charcount is a misnomer here as we might be dealing with the
710 length of a vector or list, but emphasizes that we're not dealing
711 with Bytecounts in strings */
712 /* Charcount total_length; */
714 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
716 #ifdef LOSING_BYTECODE
717 Charcount thislen = length_with_bytecode_hack (args[argnum]);
719 Charcount thislen = XINT (Flength (args[argnum]));
721 total_length += thislen;
727 if (total_length == 0)
729 /* In append, if all but last arg are nil, return last arg */
730 XMALLOC_UNBIND(args_mse, nargs, speccount);
731 RETURN_UNGCPRO (last_tail);
733 val = Fmake_list (make_int (total_length), Qnil);
736 val = make_vector (total_length, Qnil);
739 val = make_bit_vector (total_length, Qzero);
742 /* We don't make the string yet because we don't know the
743 actual number of bytes. This loop was formerly written
744 to call Fmake_string() here and then call set_string_char()
745 for each char. This seems logical enough but is waaaaaaaay
746 slow -- set_string_char() has to scan the whole string up
747 to the place where the substitution is called for in order
748 to find the place to change, and may have to do some
749 realloc()ing in order to make the char fit properly.
752 XMALLOC_OR_ALLOCA( string_result,
753 total_length * MAX_EMCHAR_LEN,
755 string_result_ptr = string_result;
765 tail = val, toindex = -1; /* -1 in toindex is flag we are
772 for (argnum = 0; argnum < nargs; argnum++)
774 Charcount thisleni = 0;
775 Charcount thisindex = 0;
776 Lisp_Object seq = args[argnum];
777 Bufbyte *string_source_ptr = 0;
778 Bufbyte *string_prev_result_ptr = string_result_ptr;
782 #ifdef LOSING_BYTECODE
783 thisleni = length_with_bytecode_hack (seq);
785 thisleni = XINT (Flength (seq));
789 string_source_ptr = XSTRING_DATA (seq);
795 /* We've come to the end of this arg, so exit. */
799 /* Fetch next element of `seq' arg into `elt' */
807 if (thisindex >= thisleni)
812 elt = make_char (charptr_emchar (string_source_ptr));
813 INC_CHARPTR (string_source_ptr);
815 else if (VECTORP (seq))
816 elt = XVECTOR_DATA (seq)[thisindex];
817 else if (BIT_VECTORP (seq))
818 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
821 elt = Felt (seq, make_int (thisindex));
825 /* Store into result */
828 /* toindex negative means we are making a list */
833 else if (VECTORP (val))
834 XVECTOR_DATA (val)[toindex++] = elt;
835 else if (BIT_VECTORP (val))
838 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
842 CHECK_CHAR_COERCE_INT (elt);
843 string_result_ptr += set_charptr_emchar (string_result_ptr,
849 args_mse[argnum].entry_offset =
850 string_prev_result_ptr - string_result;
851 args_mse[argnum].entry_length =
852 string_result_ptr - string_prev_result_ptr;
856 /* Now we finally make the string. */
857 if (target_type == c_string)
859 val = make_string (string_result, string_result_ptr - string_result);
860 for (argnum = 0; argnum < nargs; argnum++)
862 if (STRINGP (args_mse[argnum].string))
863 copy_string_extents (val, args_mse[argnum].string,
864 args_mse[argnum].entry_offset, 0,
865 args_mse[argnum].entry_length);
867 XMALLOC_UNBIND(string_result, total_length * MAX_EMCHAR_LEN, speccount);
868 XMALLOC_UNBIND(args_mse, nargs, speccount);
872 XCDR (prev) = last_tail;
874 RETURN_UNGCPRO (val);
877 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
878 Return a copy of ALIST.
879 This is an alist which represents the same mapping from objects to objects,
880 but does not share the alist structure with ALIST.
881 The objects mapped (cars and cdrs of elements of the alist)
883 Elements of ALIST that are not conses are also shared.
893 alist = concat (1, &alist, c_cons, 0);
894 for (tail = alist; CONSP (tail); tail = XCDR (tail))
896 Lisp_Object car = XCAR (tail);
899 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
904 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
905 Return a copy of a list and substructures.
906 The argument is copied, and any lists contained within it are copied
907 recursively. Circularities and shared substructures are not preserved.
908 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
913 return safe_copy_tree (arg, vecp, 0);
917 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
920 signal_simple_error ("Stack overflow in copy-tree", arg);
925 rest = arg = Fcopy_sequence (arg);
928 Lisp_Object elt = XCAR (rest);
930 if (CONSP (elt) || VECTORP (elt))
931 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
932 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
933 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
937 else if (VECTORP (arg) && ! NILP (vecp))
939 int i = XVECTOR_LENGTH (arg);
941 arg = Fcopy_sequence (arg);
942 for (j = 0; j < i; j++)
944 Lisp_Object elt = XVECTOR_DATA (arg) [j];
946 if (CONSP (elt) || VECTORP (elt))
947 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
953 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
954 Return the substring of STRING starting at START and ending before END.
955 END may be nil or omitted; then the substring runs to the end of STRING.
956 If START or END is negative, it counts from the end.
957 Relevant parts of the string-extent-data are copied to the new string.
959 (string, start, end))
961 Charcount ccstart, ccend;
962 Bytecount bstart, blen;
965 CHECK_STRING (string);
967 get_string_range_char (string, start, end, &ccstart, &ccend,
968 GB_HISTORICAL_STRING_BEHAVIOR);
969 bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart);
970 blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart);
971 val = make_string (XSTRING_DATA (string) + bstart, blen);
972 /* Copy any applicable extent information into the new string. */
973 copy_string_extents (val, string, 0, bstart, blen);
977 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
978 Return the subsequence of SEQUENCE starting at START and ending before END.
979 END may be omitted; then the subsequence runs to the end of SEQUENCE.
980 If START or END is negative, it counts from the end.
981 The returned subsequence is always of the same type as SEQUENCE.
982 If SEQUENCE is a string, relevant parts of the string-extent-data
983 are copied to the new string.
985 (sequence, start, end))
989 if (STRINGP (sequence))
990 return Fsubstring (sequence, start, end);
992 len = XINT (Flength (sequence));
1009 if (!(0 <= s && s <= e && e <= len))
1010 args_out_of_range_3 (sequence, make_int (s), make_int (e));
1012 if (VECTORP (sequence))
1014 Lisp_Object result = make_vector (e - s, Qnil);
1016 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
1017 Lisp_Object *out_elts = XVECTOR_DATA (result);
1019 for (i = s; i < e; i++)
1020 out_elts[i - s] = in_elts[i];
1023 else if (LISTP (sequence))
1025 Lisp_Object result = Qnil;
1028 sequence = Fnthcdr (make_int (s), sequence);
1030 for (i = s; i < e; i++)
1032 result = Fcons (Fcar (sequence), result);
1033 sequence = Fcdr (sequence);
1036 return Fnreverse (result);
1038 else if (BIT_VECTORP (sequence))
1040 Lisp_Object result = make_bit_vector (e - s, Qzero);
1043 for (i = s; i < e; i++)
1044 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
1045 bit_vector_bit (XBIT_VECTOR (sequence), i));
1050 ABORT (); /* unreachable, since Flength (sequence) did not get
1057 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1058 Take cdr N times on LIST, and return the result.
1063 REGISTER Lisp_Object tail = list;
1065 for (i = XINT (n); i; i--)
1069 else if (NILP (tail))
1073 tail = wrong_type_argument (Qlistp, tail);
1080 DEFUN ("nth", Fnth, 2, 2, 0, /*
1081 Return the Nth element of LIST.
1082 N counts from zero. If LIST is not that long, nil is returned.
1086 return Fcar (Fnthcdr (n, list));
1089 DEFUN ("elt", Felt, 2, 2, 0, /*
1090 Return element of SEQUENCE at index N.
1095 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1096 if (LISTP (sequence))
1098 Lisp_Object tem = Fnthcdr (n, sequence);
1099 /* #### Utterly, completely, fucking disgusting.
1100 * #### The whole point of "elt" is that it operates on
1101 * #### sequences, and does error- (bounds-) checking.
1107 /* This is The Way It Has Always Been. */
1110 /* This is The Way Mly and Cltl2 say It Should Be. */
1111 args_out_of_range (sequence, n);
1114 else if (STRINGP (sequence) ||
1115 VECTORP (sequence) ||
1116 BIT_VECTORP (sequence))
1117 return Faref (sequence, n);
1118 #ifdef LOSING_BYTECODE
1119 else if (COMPILED_FUNCTIONP (sequence))
1121 EMACS_INT idx = XINT (n);
1125 args_out_of_range (sequence, n);
1127 /* Utter perversity */
1129 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1132 case COMPILED_ARGLIST:
1133 return compiled_function_arglist (f);
1134 case COMPILED_INSTRUCTIONS:
1135 return compiled_function_instructions (f);
1136 case COMPILED_CONSTANTS:
1137 return compiled_function_constants (f);
1138 case COMPILED_STACK_DEPTH:
1139 return compiled_function_stack_depth (f);
1140 case COMPILED_DOC_STRING:
1141 return compiled_function_documentation (f);
1142 case COMPILED_DOMAIN:
1143 return compiled_function_domain (f);
1144 case COMPILED_INTERACTIVE:
1145 if (f->flags.interactivep)
1146 return compiled_function_interactive (f);
1147 /* if we return nil, can't tell interactive with no args
1148 from noninteractive. */
1155 #endif /* LOSING_BYTECODE */
1158 check_losing_bytecode ("elt", sequence);
1159 sequence = wrong_type_argument (Qsequencep, sequence);
1164 DEFUN ("last", Flast, 1, 2, 0, /*
1165 Return the tail of list LIST, of length N (default 1).
1166 LIST may be a dotted list, but not a circular list.
1167 Optional argument N must be a non-negative integer.
1168 If N is zero, then the atom that terminates the list is returned.
1169 If N is greater than the length of LIST, then LIST itself is returned.
1173 EMACS_INT int_n, count;
1174 Lisp_Object retval, tortoise, hare;
1186 for (retval = tortoise = hare = list, count = 0;
1189 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1192 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1195 tortoise = XCDR (tortoise);
1196 if (EQ (hare, tortoise))
1197 signal_circular_list_error (list);
1203 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1204 Modify LIST to remove the last N (default 1) elements.
1205 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1222 Lisp_Object last_cons = list;
1224 EXTERNAL_LIST_LOOP_1 (list)
1227 last_cons = XCDR (last_cons);
1233 XCDR (last_cons) = Qnil;
1238 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1239 Return a copy of LIST with the last N (default 1) elements removed.
1240 If LIST has N or fewer elements, nil is returned.
1257 Lisp_Object retval = Qnil;
1258 Lisp_Object tail = list;
1260 EXTERNAL_LIST_LOOP_1 (list)
1264 retval = Fcons (XCAR (tail), retval);
1269 return Fnreverse (retval);
1273 DEFUN ("member", Fmember, 2, 2, 0, /*
1274 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1275 The value is actually the tail of LIST whose car is ELT.
1279 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1281 if (internal_equal (elt, list_elt, 0))
1287 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1288 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1289 The value is actually the tail of LIST whose car is ELT.
1290 This function is provided only for byte-code compatibility with v19.
1295 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1297 if (internal_old_equal (elt, list_elt, 0))
1303 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1304 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1305 The value is actually the tail of LIST whose car is ELT.
1309 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1311 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1317 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1318 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1319 The value is actually the tail of LIST whose car is ELT.
1320 This function is provided only for byte-code compatibility with v19.
1325 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1327 if (HACKEQ_UNSAFE (elt, list_elt))
1334 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1336 LIST_LOOP_3 (list_elt, list, tail)
1338 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1344 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1345 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1346 The value is actually the element of ALIST whose car equals KEY.
1350 /* This function can GC. */
1351 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1353 if (internal_equal (key, elt_car, 0))
1359 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1360 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
1361 The value is actually the element of ALIST whose car equals KEY.
1365 /* This function can GC. */
1366 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1368 if (internal_old_equal (key, elt_car, 0))
1375 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
1377 int speccount = specpdl_depth ();
1378 specbind (Qinhibit_quit, Qt);
1379 return unbind_to (speccount, Fassoc (key, alist));
1382 DEFUN ("assq", Fassq, 2, 2, 0, /*
1383 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1384 The value is actually the element of ALIST whose car is KEY.
1385 Elements of ALIST that are not conses are ignored.
1389 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1391 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1397 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1398 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
1399 The value is actually the element of ALIST whose car is KEY.
1400 Elements of ALIST that are not conses are ignored.
1401 This function is provided only for byte-code compatibility with v19.
1406 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1408 if (HACKEQ_UNSAFE (key, elt_car))
1414 /* Like Fassq but never report an error and do not allow quits.
1415 Use only on lists known never to be circular. */
1418 assq_no_quit (Lisp_Object key, Lisp_Object alist)
1420 /* This cannot GC. */
1421 LIST_LOOP_2 (elt, alist)
1423 Lisp_Object elt_car = XCAR (elt);
1424 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1430 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1431 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1432 The value is actually the element of ALIST whose cdr equals VALUE.
1436 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1438 if (internal_equal (value, elt_cdr, 0))
1444 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1445 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
1446 The value is actually the element of ALIST whose cdr equals VALUE.
1450 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1452 if (internal_old_equal (value, elt_cdr, 0))
1458 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1459 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1460 The value is actually the element of ALIST whose cdr is VALUE.
1464 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1466 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1472 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1473 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
1474 The value is actually the element of ALIST whose cdr is VALUE.
1478 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1480 if (HACKEQ_UNSAFE (value, elt_cdr))
1486 /* Like Frassq, but caller must ensure that ALIST is properly
1487 nil-terminated and ebola-free. */
1489 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
1491 LIST_LOOP_2 (elt, alist)
1493 Lisp_Object elt_cdr = XCDR (elt);
1494 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1501 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1502 Delete by side effect any occurrences of ELT as a member of LIST.
1503 The modified LIST is returned. Comparison is done with `equal'.
1504 If the first member of LIST is ELT, there is no way to remove it by side
1505 effect; therefore, write `(setq foo (delete element foo))' to be sure
1506 of changing the value of `foo'.
1511 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1512 (internal_equal (elt, list_elt, 0)));
1516 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1517 Delete by side effect any occurrences of ELT as a member of LIST.
1518 The modified LIST is returned. Comparison is done with `old-equal'.
1519 If the first member of LIST is ELT, there is no way to remove it by side
1520 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1521 of changing the value of `foo'.
1525 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1526 (internal_old_equal (elt, list_elt, 0)));
1530 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1531 Delete by side effect any occurrences of ELT as a member of LIST.
1532 The modified LIST is returned. Comparison is done with `eq'.
1533 If the first member of LIST is ELT, there is no way to remove it by side
1534 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1535 changing the value of `foo'.
1539 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1540 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1544 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1545 Delete by side effect any occurrences of ELT as a member of LIST.
1546 The modified LIST is returned. Comparison is done with `old-eq'.
1547 If the first member of LIST is ELT, there is no way to remove it by side
1548 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1549 changing the value of `foo'.
1553 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1554 (HACKEQ_UNSAFE (elt, list_elt)));
1558 /* Like Fdelq, but caller must ensure that LIST is properly
1559 nil-terminated and ebola-free. */
1562 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1564 LIST_LOOP_DELETE_IF (list_elt, list,
1565 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1569 /* Be VERY careful with this. This is like delq_no_quit() but
1570 also calls free_cons() on the removed conses. You must be SURE
1571 that no pointers to the freed conses remain around (e.g.
1572 someone else is pointing to part of the list). This function
1573 is useful on internal lists that are used frequently and where
1574 the actual list doesn't escape beyond known code bounds. */
1577 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1579 REGISTER Lisp_Object tail = list;
1580 REGISTER Lisp_Object prev = Qnil;
1582 while (!NILP (tail))
1584 REGISTER Lisp_Object tem = XCAR (tail);
1587 Lisp_Object cons_to_free = tail;
1591 XCDR (prev) = XCDR (tail);
1593 free_cons (XCONS (cons_to_free));
1604 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1605 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
1606 The modified ALIST is returned. If the first member of ALIST has a car
1607 that is `equal' to KEY, there is no way to remove it by side effect;
1608 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1613 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1615 internal_equal (key, XCAR (elt), 0)));
1620 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
1622 int speccount = specpdl_depth ();
1623 specbind (Qinhibit_quit, Qt);
1624 return unbind_to (speccount, Fremassoc (key, alist));
1627 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1628 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
1629 The modified ALIST is returned. If the first member of ALIST has a car
1630 that is `eq' to KEY, there is no way to remove it by side effect;
1631 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1636 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1638 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1642 /* no quit, no errors; be careful */
1645 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
1647 LIST_LOOP_DELETE_IF (elt, alist,
1649 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1653 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1654 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
1655 The modified ALIST is returned. If the first member of ALIST has a car
1656 that is `equal' to VALUE, there is no way to remove it by side effect;
1657 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1662 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1664 internal_equal (value, XCDR (elt), 0)));
1668 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1669 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
1670 The modified ALIST is returned. If the first member of ALIST has a car
1671 that is `eq' to VALUE, there is no way to remove it by side effect;
1672 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1677 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1679 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1683 /* Like Fremrassq, fast and unsafe; be careful */
1685 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
1687 LIST_LOOP_DELETE_IF (elt, alist,
1689 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1693 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1694 Reverse LIST by destructively modifying cdr pointers.
1695 Return the beginning of the reversed list.
1696 Also see: `reverse'.
1700 struct gcpro gcpro1, gcpro2;
1701 REGISTER Lisp_Object prev = Qnil;
1702 REGISTER Lisp_Object tail = list;
1704 /* We gcpro our args; see `nconc' */
1705 GCPRO2 (prev, tail);
1706 while (!NILP (tail))
1708 REGISTER Lisp_Object next;
1709 CONCHECK_CONS (tail);
1719 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1720 Reverse LIST, copying. Return the beginning of the reversed list.
1721 See also the function `nreverse', which is used more often.
1725 Lisp_Object reversed_list = Qnil;
1726 EXTERNAL_LIST_LOOP_2 (elt, list)
1728 reversed_list = Fcons (elt, reversed_list);
1730 return reversed_list;
1733 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1734 Lisp_Object lisp_arg,
1735 int (*pred_fn) (Lisp_Object, Lisp_Object,
1736 Lisp_Object lisp_arg));
1739 list_sort (Lisp_Object list,
1740 Lisp_Object lisp_arg,
1741 int (*pred_fn) (Lisp_Object, Lisp_Object,
1742 Lisp_Object lisp_arg))
1744 struct gcpro gcpro1, gcpro2, gcpro3;
1745 Lisp_Object back, tem;
1746 Lisp_Object front = list;
1747 Lisp_Object len = Flength (list);
1752 len = make_int (XINT (len) / 2 - 1);
1753 tem = Fnthcdr (len, list);
1755 Fsetcdr (tem, Qnil);
1757 GCPRO3 (front, back, lisp_arg);
1758 front = list_sort (front, lisp_arg, pred_fn);
1759 back = list_sort (back, lisp_arg, pred_fn);
1761 return list_merge (front, back, lisp_arg, pred_fn);
1766 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1771 /* prevents the GC from happening in call2 */
1772 int speccount = specpdl_depth ();
1773 /* Emacs' GC doesn't actually relocate pointers, so this probably
1774 isn't strictly necessary */
1775 record_unwind_protect (restore_gc_inhibit,
1776 make_int (gc_currently_forbidden));
1777 gc_currently_forbidden = 1;
1778 tmp = call2 (pred, obj1, obj2);
1779 unbind_to (speccount, Qnil);
1787 DEFUN ("sort", Fsort, 2, 2, 0, /*
1788 Sort LIST, stably, comparing elements using PREDICATE.
1789 Returns the sorted list. LIST is modified by side effects.
1790 PREDICATE is called with two elements of LIST, and should return T
1791 if the first element is "less" than the second.
1795 return list_sort (list, predicate, merge_pred_function);
1799 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1802 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1807 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1808 Lisp_Object lisp_arg,
1809 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1815 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1822 /* It is sufficient to protect org_l1 and org_l2.
1823 When l1 and l2 are updated, we copy the new values
1824 back into the org_ vars. */
1826 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1847 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1862 Fsetcdr (tail, tem);
1868 /************************************************************************/
1869 /* property-list functions */
1870 /************************************************************************/
1872 /* For properties of text, we need to do order-insensitive comparison of
1873 plists. That is, we need to compare two plists such that they are the
1874 same if they have the same set of keys, and equivalent values.
1875 So (a 1 b 2) would be equal to (b 2 a 1).
1877 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1878 LAXP means use `equal' for comparisons.
1881 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1882 int laxp, int depth)
1884 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1885 int la, lb, m, i, fill;
1886 Lisp_Object *keys, *vals;
1889 int speccount = specpdl_depth();
1891 if (NILP (a) && NILP (b))
1894 Fcheck_valid_plist (a);
1895 Fcheck_valid_plist (b);
1897 la = XINT (Flength (a));
1898 lb = XINT (Flength (b));
1899 m = (la > lb ? la : lb);
1901 XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
1902 XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
1903 XMALLOC_OR_ALLOCA(flags, m, char);
1905 /* First extract the pairs from A. */
1906 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1908 Lisp_Object k = XCAR (rest);
1909 Lisp_Object v = XCAR (XCDR (rest));
1910 /* Maybe be Ebolified. */
1911 if (nil_means_not_present && NILP (v)) continue;
1917 /* Now iterate over B, and stop if we find something that's not in A,
1918 or that doesn't match. As we match, mark them. */
1919 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1921 Lisp_Object k = XCAR (rest);
1922 Lisp_Object v = XCAR (XCDR (rest));
1923 /* Maybe be Ebolified. */
1924 if (nil_means_not_present && NILP (v)) continue;
1925 for (i = 0; i < fill; i++)
1927 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1930 /* We narrowly escaped being Ebolified here. */
1931 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1932 : !internal_equal (v, vals [i], depth))
1933 /* a property in B has a different value than in A */
1940 /* there are some properties in B that are not in A */
1943 /* Now check to see that all the properties in A were also in B */
1944 for (i = 0; i < fill; i++)
1949 XMALLOC_UNBIND(flags, m, speccount);
1950 XMALLOC_UNBIND(vals, m, speccount);
1951 XMALLOC_UNBIND(keys, m, speccount);
1956 XMALLOC_UNBIND(flags, m, speccount);
1957 XMALLOC_UNBIND(vals, m, speccount);
1958 XMALLOC_UNBIND(keys, m, speccount);
1962 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1963 Return non-nil if property lists A and B are `eq'.
1964 A property list is an alternating list of keywords and values.
1965 This function does order-insensitive comparisons of the property lists:
1966 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1967 Comparison between values is done using `eq'. See also `plists-equal'.
1968 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1969 a nil value is ignored. This feature is a virus that has infected
1970 old Lisp implementations, but should not be used except for backward
1973 (a, b, nil_means_not_present))
1975 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1979 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1980 Return non-nil if property lists A and B are `equal'.
1981 A property list is an alternating list of keywords and values. This
1982 function does order-insensitive comparisons of the property lists: For
1983 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1984 Comparison between values is done using `equal'. See also `plists-eq'.
1985 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1986 a nil value is ignored. This feature is a virus that has infected
1987 old Lisp implementations, but should not be used except for backward
1990 (a, b, nil_means_not_present))
1992 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1997 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1998 Return non-nil if lax property lists A and B are `eq'.
1999 A property list is an alternating list of keywords and values.
2000 This function does order-insensitive comparisons of the property lists:
2001 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2002 Comparison between values is done using `eq'. See also `plists-equal'.
2003 A lax property list is like a regular one except that comparisons between
2004 keywords is done using `equal' instead of `eq'.
2005 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2006 a nil value is ignored. This feature is a virus that has infected
2007 old Lisp implementations, but should not be used except for backward
2010 (a, b, nil_means_not_present))
2012 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
2016 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2017 Return non-nil if lax property lists A and B are `equal'.
2018 A property list is an alternating list of keywords and values. This
2019 function does order-insensitive comparisons of the property lists: For
2020 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2021 Comparison between values is done using `equal'. See also `plists-eq'.
2022 A lax property list is like a regular one except that comparisons between
2023 keywords is done using `equal' instead of `eq'.
2024 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2025 a nil value is ignored. This feature is a virus that has infected
2026 old Lisp implementations, but should not be used except for backward
2029 (a, b, nil_means_not_present))
2031 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
2035 /* Return the value associated with key PROPERTY in property list PLIST.
2036 Return nil if key not found. This function is used for internal
2037 property lists that cannot be directly manipulated by the user.
2041 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2045 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2047 if (EQ (XCAR (tail), property))
2048 return XCAR (XCDR (tail));
2054 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2055 internal_plist_get(). */
2058 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2063 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2065 if (EQ (XCAR (tail), property))
2067 XCAR (XCDR (tail)) = value;
2072 *plist = Fcons (property, Fcons (value, *plist));
2076 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2078 Lisp_Object tail, prev;
2080 for (tail = *plist, prev = Qnil;
2082 tail = XCDR (XCDR (tail)))
2084 if (EQ (XCAR (tail), property))
2087 *plist = XCDR (XCDR (tail));
2089 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2099 /* Called on a malformed property list. BADPLACE should be some
2100 place where truncating will form a good list -- i.e. we shouldn't
2101 result in a list with an odd length. */
2104 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2106 if (ERRB_EQ (errb, ERROR_ME))
2107 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2110 if (ERRB_EQ (errb, ERROR_ME_WARN))
2112 warn_when_safe_lispobj
2115 ("Malformed property list -- list has been truncated"),
2123 /* Called on a circular property list. BADPLACE should be some place
2124 where truncating will result in an even-length list, as above.
2125 If doesn't particularly matter where we truncate -- anywhere we
2126 truncate along the entire list will break the circularity, because
2127 it will create a terminus and the list currently doesn't have one.
2131 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2133 if (ERRB_EQ (errb, ERROR_ME))
2134 return Fsignal (Qcircular_property_list, list1 (*plist));
2137 if (ERRB_EQ (errb, ERROR_ME_WARN))
2139 warn_when_safe_lispobj
2142 ("Circular property list -- list has been truncated"),
2150 /* Advance the tortoise pointer by two (one iteration of a property-list
2151 loop) and the hare pointer by four and verify that no malformations
2152 or circularities exist. If so, return zero and store a value into
2153 RETVAL that should be returned by the calling function. Otherwise,
2154 return 1. See external_plist_get().
2158 advance_plist_pointers (Lisp_Object *plist,
2159 Lisp_Object **tortoise, Lisp_Object **hare,
2160 Error_behavior errb, Lisp_Object *retval)
2163 Lisp_Object *tortsave = *tortoise;
2165 /* Note that our "fixing" may be more brutal than necessary,
2166 but it's the user's own problem, not ours, if they went in and
2167 manually fucked up a plist. */
2169 for (i = 0; i < 2; i++)
2171 /* This is a standard iteration of a defensive-loop-checking
2172 loop. We just do it twice because we want to advance past
2173 both the property and its value.
2175 If the pointer indirection is confusing you, remember that
2176 one level of indirection on the hare and tortoise pointers
2177 is only due to pass-by-reference for this function. The other
2178 level is so that the plist can be fixed in place. */
2180 /* When we reach the end of a well-formed plist, **HARE is
2181 nil. In that case, we don't do anything at all except
2182 advance TORTOISE by one. Otherwise, we advance HARE
2183 by two (making sure it's OK to do so), then advance
2184 TORTOISE by one (it will always be OK to do so because
2185 the HARE is always ahead of the TORTOISE and will have
2186 already verified the path), then make sure TORTOISE and
2187 HARE don't contain the same non-nil object -- if the
2188 TORTOISE and the HARE ever meet, then obviously we're
2189 in a circularity, and if we're in a circularity, then
2190 the TORTOISE and the HARE can't cross paths without
2191 meeting, since the HARE only gains one step over the
2192 TORTOISE per iteration. */
2196 Lisp_Object *haresave = *hare;
2197 if (!CONSP (**hare))
2199 *retval = bad_bad_bunny (plist, haresave, errb);
2202 *hare = &XCDR (**hare);
2203 /* In a non-plist, we'd check here for a nil value for
2204 **HARE, which is OK (it just means the list has an
2205 odd number of elements). In a plist, it's not OK
2206 for the list to have an odd number of elements. */
2207 if (!CONSP (**hare))
2209 *retval = bad_bad_bunny (plist, haresave, errb);
2212 *hare = &XCDR (**hare);
2215 *tortoise = &XCDR (**tortoise);
2216 if (!NILP (**hare) && EQ (**tortoise, **hare))
2218 *retval = bad_bad_turtle (plist, tortsave, errb);
2226 /* Return the value of PROPERTY from PLIST, or Qunbound if
2227 property is not on the list.
2229 PLIST is a Lisp-accessible property list, meaning that it
2230 has to be checked for malformations and circularities.
2232 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2233 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2234 on finding a malformation or a circularity, it issues a warning and
2235 attempts to silently fix the problem.
2237 A pointer to PLIST is passed in so that PLIST can be successfully
2238 "fixed" even if the error is at the beginning of the plist. */
2241 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2242 int laxp, Error_behavior errb)
2244 Lisp_Object *tortoise = plist;
2245 Lisp_Object *hare = plist;
2247 while (!NILP (*tortoise))
2249 Lisp_Object *tortsave = tortoise;
2252 /* We do the standard tortoise/hare march. We isolate the
2253 grungy stuff to do this in advance_plist_pointers(), though.
2254 To us, all this function does is advance the tortoise
2255 pointer by two and the hare pointer by four and make sure
2256 everything's OK. We first advance the pointers and then
2257 check if a property matched; this ensures that our
2258 check for a matching property is safe. */
2260 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2263 if (!laxp ? EQ (XCAR (*tortsave), property)
2264 : internal_equal (XCAR (*tortsave), property, 0))
2265 return XCAR (XCDR (*tortsave));
2271 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2272 malformed or circular plist. Analogous to external_plist_get(). */
2275 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2276 Lisp_Object value, int laxp, Error_behavior errb)
2278 Lisp_Object *tortoise = plist;
2279 Lisp_Object *hare = plist;
2281 while (!NILP (*tortoise))
2283 Lisp_Object *tortsave = tortoise;
2287 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2290 if (!laxp ? EQ (XCAR (*tortsave), property)
2291 : internal_equal (XCAR (*tortsave), property, 0))
2293 XCAR (XCDR (*tortsave)) = value;
2298 *plist = Fcons (property, Fcons (value, *plist));
2302 external_remprop (Lisp_Object *plist, Lisp_Object property,
2303 int laxp, Error_behavior errb)
2305 Lisp_Object *tortoise = plist;
2306 Lisp_Object *hare = plist;
2308 while (!NILP (*tortoise))
2310 Lisp_Object *tortsave = tortoise;
2314 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2317 if (!laxp ? EQ (XCAR (*tortsave), property)
2318 : internal_equal (XCAR (*tortsave), property, 0))
2320 /* Now you see why it's so convenient to have that level
2322 *tortsave = XCDR (XCDR (*tortsave));
2330 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2331 Extract a value from a property list.
2332 PLIST is a property list, which is a list of the form
2333 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
2334 PROPERTY is usually a symbol.
2335 This function returns the value corresponding to the PROPERTY,
2336 or DEFAULT if PROPERTY is not one of the properties on the list.
2338 (plist, property, default_))
2340 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
2341 return UNBOUNDP (value) ? default_ : value;
2344 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2345 Change value in PLIST of PROPERTY to VALUE.
2346 PLIST is a property list, which is a list of the form
2347 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2348 PROPERTY is usually a symbol and VALUE is any object.
2349 If PROPERTY is already a property on the list, its value is set to VALUE,
2350 otherwise the new PROPERTY VALUE pair is added.
2351 The new plist is returned; use `(setq x (plist-put x property value))'
2352 to be sure to use the new value. PLIST is modified by side effect.
2354 (plist, property, value))
2356 external_plist_put (&plist, property, value, 0, ERROR_ME);
2360 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2361 Remove from PLIST the property PROPERTY and its value.
2362 PLIST is a property list, which is a list of the form
2363 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2364 PROPERTY is usually a symbol.
2365 The new plist is returned; use `(setq x (plist-remprop x property))'
2366 to be sure to use the new value. PLIST is modified by side effect.
2370 external_remprop (&plist, property, 0, ERROR_ME);
2374 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2375 Return t if PROPERTY has a value specified in PLIST.
2379 Lisp_Object value = Fplist_get (plist, property, Qunbound);
2380 return UNBOUNDP (value) ? Qnil : Qt;
2383 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2384 Given a plist, signal an error if there is anything wrong with it.
2385 This means that it's a malformed or circular plist.
2389 Lisp_Object *tortoise;
2395 while (!NILP (*tortoise))
2400 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2408 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2409 Given a plist, return non-nil if its format is correct.
2410 If it returns nil, `check-valid-plist' will signal an error when given
2411 the plist; that means it's a malformed or circular plist.
2415 Lisp_Object *tortoise;
2420 while (!NILP (*tortoise))
2425 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2433 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2434 Destructively remove any duplicate entries from a plist.
2435 In such cases, the first entry applies.
2437 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2438 a nil value is removed. This feature is a virus that has infected
2439 old Lisp implementations, but should not be used except for backward
2442 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2443 return value may not be EQ to the passed-in value, so make sure to
2444 `setq' the value back into where it came from.
2446 (plist, nil_means_not_present))
2448 Lisp_Object head = plist;
2450 Fcheck_valid_plist (plist);
2452 while (!NILP (plist))
2454 Lisp_Object prop = Fcar (plist);
2455 Lisp_Object next = Fcdr (plist);
2457 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2458 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2460 if (EQ (head, plist))
2462 plist = Fcdr (next);
2465 /* external_remprop returns 1 if it removed any property.
2466 We have to loop till it didn't remove anything, in case
2467 the property occurs many times. */
2468 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2470 plist = Fcdr (next);
2476 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2477 Extract a value from a lax property list.
2478 LAX-PLIST is a lax property list, which is a list of the form
2479 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2480 properties is done using `equal' instead of `eq'.
2481 PROPERTY is usually a symbol.
2482 This function returns the value corresponding to PROPERTY,
2483 or DEFAULT if PROPERTY is not one of the properties on the list.
2485 (lax_plist, property, default_))
2487 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
2488 return UNBOUNDP (value) ? default_ : value;
2491 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2492 Change value in LAX-PLIST of PROPERTY to VALUE.
2493 LAX-PLIST is a lax property list, which is a list of the form
2494 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2495 properties is done using `equal' instead of `eq'.
2496 PROPERTY is usually a symbol and VALUE is any object.
2497 If PROPERTY is already a property on the list, its value is set to
2498 VALUE, otherwise the new PROPERTY VALUE pair is added.
2499 The new plist is returned; use `(setq x (lax-plist-put x property value))'
2500 to be sure to use the new value. LAX-PLIST is modified by side effect.
2502 (lax_plist, property, value))
2504 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
2508 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2509 Remove from LAX-PLIST the property PROPERTY and its value.
2510 LAX-PLIST is a lax property list, which is a list of the form
2511 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2512 properties is done using `equal' instead of `eq'.
2513 PROPERTY is usually a symbol.
2514 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
2515 to be sure to use the new value. LAX-PLIST is modified by side effect.
2517 (lax_plist, property))
2519 external_remprop (&lax_plist, property, 1, ERROR_ME);
2523 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2524 Return t if PROPERTY has a value specified in LAX-PLIST.
2525 LAX-PLIST is a lax property list, which is a list of the form
2526 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2527 properties is done using `equal' instead of `eq'.
2529 (lax_plist, property))
2531 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
2534 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2535 Destructively remove any duplicate entries from a lax plist.
2536 In such cases, the first entry applies.
2538 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2539 a nil value is removed. This feature is a virus that has infected
2540 old Lisp implementations, but should not be used except for backward
2543 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2544 return value may not be EQ to the passed-in value, so make sure to
2545 `setq' the value back into where it came from.
2547 (lax_plist, nil_means_not_present))
2549 Lisp_Object head = lax_plist;
2551 Fcheck_valid_plist (lax_plist);
2553 while (!NILP (lax_plist))
2555 Lisp_Object prop = Fcar (lax_plist);
2556 Lisp_Object next = Fcdr (lax_plist);
2558 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2559 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2561 if (EQ (head, lax_plist))
2563 lax_plist = Fcdr (next);
2566 /* external_remprop returns 1 if it removed any property.
2567 We have to loop till it didn't remove anything, in case
2568 the property occurs many times. */
2569 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2571 lax_plist = Fcdr (next);
2577 /* In C because the frame props stuff uses it */
2579 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2580 Convert association list ALIST into the equivalent property-list form.
2581 The plist is returned. This converts from
2583 \((a . 1) (b . 2) (c . 3))
2589 The original alist is destroyed in the process of constructing the plist.
2590 See also `alist-to-plist'.
2594 Lisp_Object head = alist;
2595 while (!NILP (alist))
2597 /* remember the alist element. */
2598 Lisp_Object el = Fcar (alist);
2600 Fsetcar (alist, Fcar (el));
2601 Fsetcar (el, Fcdr (el));
2602 Fsetcdr (el, Fcdr (alist));
2603 Fsetcdr (alist, el);
2604 alist = Fcdr (Fcdr (alist));
2610 DEFUN ("get", Fget, 2, 3, 0, /*
2611 Return the value of OBJECT's PROPERTY property.
2612 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2613 If there is no such property, return optional third arg DEFAULT
2614 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2615 face, or glyph. See also `put', `remprop', and `object-plist'.
2617 (object, property, default_))
2619 /* Various places in emacs call Fget() and expect it not to quit,
2623 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2624 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2626 signal_simple_error ("Object type has no properties", object);
2628 return UNBOUNDP (val) ? default_ : val;
2631 DEFUN ("put", Fput, 3, 3, 0, /*
2632 Set OBJECT's PROPERTY to VALUE.
2633 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2634 OBJECT can be a symbol, face, extent, or string.
2635 For a string, no properties currently have predefined meanings.
2636 For the predefined properties for extents, see `set-extent-property'.
2637 For the predefined properties for faces, see `set-face-property'.
2638 See also `get', `remprop', and `object-plist'.
2640 (object, property, value))
2642 CHECK_LISP_WRITEABLE (object);
2644 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2646 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2647 (object, property, value))
2648 signal_simple_error ("Can't set property on object", property);
2651 signal_simple_error ("Object type has no settable properties", object);
2656 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2657 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2658 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2659 if the property list was actually modified (i.e. if PROPERTY was present
2660 in the property list). See also `get', `put', and `object-plist'.
2666 CHECK_LISP_WRITEABLE (object);
2668 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2670 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2672 signal_simple_error ("Can't remove property from object", property);
2675 signal_simple_error ("Object type has no removable properties", object);
2677 return ret ? Qt : Qnil;
2680 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2681 Return a property list of OBJECT's properties.
2682 For a symbol, this is equivalent to `symbol-plist'.
2683 OBJECT can be a symbol, string, extent, face, or glyph.
2684 Do not modify the returned property list directly;
2685 this may or may not have the desired effects. Use `put' instead.
2689 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2690 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2692 signal_simple_error ("Object type has no properties", object);
2699 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2702 error ("Stack overflow in equal");
2704 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2706 /* Note that (equal 20 20.0) should be nil */
2707 if (XTYPE (obj1) != XTYPE (obj2))
2709 if (LRECORDP (obj1))
2711 const struct lrecord_implementation
2712 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2713 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2715 return (imp1 == imp2) &&
2716 /* EQ-ness of the objects was noticed above */
2717 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2723 /* Note that we may be calling sub-objects that will use
2724 internal_equal() (instead of internal_old_equal()). Oh well.
2725 We will get an Ebola note if there's any possibility of confusion,
2726 but that seems unlikely. */
2729 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2732 error ("Stack overflow in equal");
2734 if (HACKEQ_UNSAFE (obj1, obj2))
2736 /* Note that (equal 20 20.0) should be nil */
2737 if (XTYPE (obj1) != XTYPE (obj2))
2740 return internal_equal (obj1, obj2, depth);
2743 DEFUN ("equal", Fequal, 2, 2, 0, /*
2744 Return t if two Lisp objects have similar structure and contents.
2745 They must have the same data type.
2746 Conses are compared by comparing the cars and the cdrs.
2747 Vectors and strings are compared element by element.
2748 Numbers are compared by value. Symbols must match exactly.
2752 return internal_equal (object1, object2, 0) ? Qt : Qnil;
2755 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2756 Return t if two Lisp objects have similar structure and contents.
2757 They must have the same data type.
2758 \(Note, however, that an exception is made for characters and integers;
2759 this is known as the "char-int confoundance disease." See `eq' and
2761 This function is provided only for byte-code compatibility with v19.
2766 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
2770 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2771 Destructively modify ARRAY by replacing each element with ITEM.
2772 ARRAY is a vector, bit vector, or string.
2777 if (STRINGP (array))
2779 Lisp_String *s = XSTRING (array);
2780 Bytecount old_bytecount = string_length (s);
2781 Bytecount new_bytecount;
2782 Bytecount item_bytecount;
2783 Bufbyte item_buf[MAX_EMCHAR_LEN];
2787 CHECK_CHAR_COERCE_INT (item);
2788 CHECK_LISP_WRITEABLE (array);
2790 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2791 new_bytecount = item_bytecount * string_char_length (s);
2793 resize_string (s, -1, new_bytecount - old_bytecount);
2795 for (p = string_data (s), end = p + new_bytecount;
2797 p += item_bytecount)
2798 memcpy (p, item_buf, item_bytecount);
2801 bump_string_modiff (array);
2803 else if (VECTORP (array))
2805 Lisp_Object *p = XVECTOR_DATA (array);
2806 size_t len = XVECTOR_LENGTH (array);
2807 CHECK_LISP_WRITEABLE (array);
2811 else if (BIT_VECTORP (array))
2813 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2814 size_t len = bit_vector_length (v);
2818 CHECK_LISP_WRITEABLE (array);
2820 set_bit_vector_bit (v, len, bit);
2824 array = wrong_type_argument (Qarrayp, array);
2831 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2833 Lisp_Object args[2];
2834 struct gcpro gcpro1;
2841 RETURN_UNGCPRO (bytecode_nconc2 (args));
2845 bytecode_nconc2 (Lisp_Object *args)
2849 if (CONSP (args[0]))
2851 /* (setcdr (last args[0]) args[1]) */
2852 Lisp_Object tortoise, hare;
2855 for (hare = tortoise = args[0], count = 0;
2856 CONSP (XCDR (hare));
2857 hare = XCDR (hare), count++)
2859 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2862 tortoise = XCDR (tortoise);
2863 if (EQ (hare, tortoise))
2864 signal_circular_list_error (args[0]);
2866 XCDR (hare) = args[1];
2869 else if (NILP (args[0]))
2875 args[0] = wrong_type_argument (args[0], Qlistp);
2880 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2881 Concatenate any number of lists by altering them.
2882 Only the last argument is not altered, and need not be a list.
2884 If the first argument is nil, there is no way to modify it by side
2885 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2886 changing the value of `foo'.
2888 (int nargs, Lisp_Object *args))
2891 struct gcpro gcpro1;
2893 /* The modus operandi in Emacs is "caller gc-protects args".
2894 However, nconc (particularly nconc2 ()) is called many times
2895 in Emacs on freshly created stuff (e.g. you see the idiom
2896 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2897 callers out by protecting the args ourselves to save them
2898 a lot of temporary-variable grief. */
2901 gcpro1.nvars = nargs;
2903 while (argnum < nargs)
2910 /* `val' is the first cons, which will be our return value. */
2911 /* `last_cons' will be the cons cell to mutate. */
2912 Lisp_Object last_cons = val;
2913 Lisp_Object tortoise = val;
2915 for (argnum++; argnum < nargs; argnum++)
2917 Lisp_Object next = args[argnum];
2919 if (CONSP (next) || argnum == nargs -1)
2921 /* (setcdr (last val) next) */
2925 CONSP (XCDR (last_cons));
2926 last_cons = XCDR (last_cons), count++)
2928 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2931 tortoise = XCDR (tortoise);
2932 if (EQ (last_cons, tortoise))
2933 signal_circular_list_error (args[argnum-1]);
2935 XCDR (last_cons) = next;
2937 else if (NILP (next))
2943 next = wrong_type_argument (Qlistp, next);
2947 RETURN_UNGCPRO (val);
2949 else if (NILP (val))
2951 else if (argnum == nargs - 1) /* last arg? */
2952 RETURN_UNGCPRO (val);
2955 args[argnum] = wrong_type_argument (Qlistp, val);
2959 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2963 /* This is the guts of several mapping functions.
2964 Apply FUNCTION to each element of SEQUENCE, one by one,
2965 storing the results into elements of VALS, a C vector of Lisp_Objects.
2966 LENI is the length of VALS, which should also be the length of SEQUENCE.
2968 If VALS is a null pointer, do not accumulate the results. */
2971 mapcar1 (size_t leni, Lisp_Object *vals,
2972 Lisp_Object function, Lisp_Object sequence)
2975 Lisp_Object args[2];
2976 struct gcpro gcpro1;
2986 if (LISTP (sequence))
2988 /* A devious `function' could either:
2989 - insert garbage into the list in front of us, causing XCDR to crash
2990 - amputate the list behind us using (setcdr), causing the remaining
2991 elts to lose their GCPRO status.
2993 if (vals != 0) we avoid this by copying the elts into the
2994 `vals' array. By a stroke of luck, `vals' is exactly large
2995 enough to hold the elts left to be traversed as well as the
2996 results computed so far.
2998 if (vals == 0) we don't have any free space available and
2999 don't want to eat up any more stack with alloca().
3000 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
3004 Lisp_Object *val = vals;
3007 LIST_LOOP_2 (elt, sequence)
3010 gcpro1.nvars = leni;
3012 for (i = 0; i < leni; i++)
3015 vals[i] = Ffuncall (2, args);
3020 Lisp_Object elt, tail;
3021 EMACS_INT len_unused;
3022 struct gcpro ngcpro1;
3027 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
3037 else if (VECTORP (sequence))
3039 Lisp_Object *objs = XVECTOR_DATA (sequence);
3041 for (i = 0; i < leni; i++)
3044 result = Ffuncall (2, args);
3045 if (vals) vals[gcpro1.nvars++] = result;
3048 else if (STRINGP (sequence))
3050 /* The string data of `sequence' might be relocated during GC. */
3051 Bytecount slen = XSTRING_LENGTH (sequence);
3053 Bufbyte *end = NULL;
3054 int speccount = specpdl_depth();
3056 XMALLOC_OR_ALLOCA(p, slen, Bufbyte);
3059 memcpy (p, XSTRING_DATA (sequence), slen);
3063 args[1] = make_char (charptr_emchar (p));
3065 result = Ffuncall (2, args);
3066 if (vals) vals[gcpro1.nvars++] = result;
3068 XMALLOC_UNBIND(p, slen, speccount);
3070 else if (BIT_VECTORP (sequence))
3072 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3074 for (i = 0; i < leni; i++)
3076 args[1] = make_int (bit_vector_bit (v, i));
3077 result = Ffuncall (2, args);
3078 if (vals) vals[gcpro1.nvars++] = result;
3082 ABORT (); /* unreachable, since Flength (sequence) did not get an error */
3088 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3089 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
3090 Between each pair of results, insert SEPARATOR.
3092 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
3093 results in spaces between the values returned by FUNCTION. SEQUENCE itself
3094 may be a list, a vector, a bit vector, or a string.
3096 (function, sequence, separator))
3098 EMACS_INT len = XINT (Flength (sequence));
3102 EMACS_INT nargs = len + len - 1;
3103 int speccount = specpdl_depth();
3105 if (len == 0) return build_string ("");
3107 XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
3109 mapcar1 (len, args, function, sequence);
3111 for (i = len - 1; i >= 0; i--)
3112 args[i + i] = args[i];
3114 for (i = 1; i < nargs; i += 2)
3115 args[i] = separator;
3117 result = Fconcat(nargs, args);
3118 XMALLOC_UNBIND(args, nargs, speccount);
3122 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3123 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3124 The result is a list of the same length as SEQUENCE.
3125 SEQUENCE may be a list, a vector, a bit vector, or a string.
3127 (function, sequence))
3129 size_t len = XINT (Flength (sequence));
3130 Lisp_Object *args = NULL;
3132 int speccount = specpdl_depth();
3134 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
3136 mapcar1 (len, args, function, sequence);
3138 result = Flist(len, args);
3139 XMALLOC_UNBIND(args, len, speccount);
3143 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3144 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3145 The result is a vector of the same length as SEQUENCE.
3146 SEQUENCE may be a list, a vector, a bit vector, or a string.
3148 (function, sequence))
3150 size_t len = XINT (Flength (sequence));
3151 Lisp_Object result = make_vector (len, Qnil);
3152 struct gcpro gcpro1;
3155 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3161 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3162 Apply FUNCTION to each element of SEQUENCE.
3163 SEQUENCE may be a list, a vector, a bit vector, or a string.
3164 This function is like `mapcar' but does not accumulate the results,
3165 which is more efficient if you do not use the results.
3167 The difference between this and `mapc' is that `mapc' supports all
3168 the spiffy Common Lisp arguments. You should normally use `mapc'.
3170 (function, sequence))
3172 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3180 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3181 Destructively replace the list OLD with NEW.
3182 This is like (copy-sequence NEW) except that it reuses the
3183 conses in OLD as much as possible. If OLD and NEW are the same
3184 length, no consing will take place.
3188 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
3190 EXTERNAL_LIST_LOOP (tail, new)
3192 if (!NILP (oldtail))
3194 CHECK_CONS (oldtail);
3195 XCAR (oldtail) = XCAR (tail);
3197 else if (!NILP (prevoldtail))
3199 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
3200 prevoldtail = XCDR (prevoldtail);
3203 old = oldtail = Fcons (XCAR (tail), Qnil);
3205 if (!NILP (oldtail))
3207 prevoldtail = oldtail;
3208 oldtail = XCDR (oldtail);
3212 if (!NILP (prevoldtail))
3213 XCDR (prevoldtail) = Qnil;
3221 /* #### this function doesn't belong in this file! */
3223 #ifdef HAVE_GETLOADAVG
3224 #ifdef HAVE_SYS_LOADAVG_H
3225 #include <sys/loadavg.h>
3228 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
3231 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3232 Return list of 1 minute, 5 minute and 15 minute load averages.
3233 Each of the three load averages is multiplied by 100,
3234 then converted to integer.
3236 When USE-FLOATS is non-nil, floats will be used instead of integers.
3237 These floats are not multiplied by 100.
3239 If the 5-minute or 15-minute load averages are not available, return a
3240 shortened list, containing only those averages which are available.
3242 On some systems, this won't work due to permissions on /dev/kmem,
3243 in which case you can't use this.
3248 int loads = getloadavg (load_ave, countof (load_ave));
3249 Lisp_Object ret = Qnil;
3252 error ("load-average not implemented for this operating system");
3254 signal_simple_error ("Could not get load-average",
3255 lisp_strerror (errno));
3259 Lisp_Object load = (NILP (use_floats) ?
3260 make_int ((int) (100.0 * load_ave[loads]))
3261 : make_float (load_ave[loads]));
3262 ret = Fcons (load, ret);
3268 Lisp_Object Vfeatures;
3270 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3271 Return non-nil if feature FEXP is present in this Emacs.
3272 Use this to conditionalize execution of lisp code based on the
3273 presence or absence of emacs or environment extensions.
3274 FEXP can be a symbol, a number, or a list.
3275 If it is a symbol, that symbol is looked up in the `features' variable,
3276 and non-nil will be returned if found.
3277 If it is a number, the function will return non-nil if this Emacs
3278 has an equal or greater version number than FEXP.
3279 If it is a list whose car is the symbol `and', it will return
3280 non-nil if all the features in its cdr are non-nil.
3281 If it is a list whose car is the symbol `or', it will return non-nil
3282 if any of the features in its cdr are non-nil.
3283 If it is a list whose car is the symbol `not', it will return
3284 non-nil if the feature is not present.
3289 => ; Non-nil on XEmacs.
3291 (featurep '(and xemacs gnus))
3292 => ; Non-nil on XEmacs with Gnus loaded.
3294 (featurep '(or tty-frames (and emacs 19.30)))
3295 => ; Non-nil if this Emacs supports TTY frames.
3297 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3298 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3300 (featurep '(and xemacs 21.02))
3301 => ; Non-nil on XEmacs 21.2 and later.
3303 NOTE: The advanced arguments of this function (anything other than a
3304 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3305 for supporting multiple Emacs variants, lobby Richard Stallman at
3306 <bug-gnu-emacs@gnu.org>.
3310 #ifndef FEATUREP_SYNTAX
3311 CHECK_SYMBOL (fexp);
3312 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3313 #else /* FEATUREP_SYNTAX */
3314 static double featurep_emacs_version;
3316 /* Brute force translation from Erik Naggum's lisp function. */
3319 /* Original definition */
3320 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3322 else if (INTP (fexp) || FLOATP (fexp))
3324 double d = extract_float (fexp);
3326 if (featurep_emacs_version == 0.0)
3328 featurep_emacs_version = XINT (Vemacs_major_version) +
3329 (XINT (Vemacs_minor_version) / 100.0);
3331 return featurep_emacs_version >= d ? Qt : Qnil;
3333 else if (CONSP (fexp))
3335 Lisp_Object tem = XCAR (fexp);
3341 negate = Fcar (tem);
3343 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3345 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3347 else if (EQ (tem, Qand))
3350 /* Use Fcar/Fcdr for error-checking. */
3351 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3355 return NILP (tem) ? Qt : Qnil;
3357 else if (EQ (tem, Qor))
3360 /* Use Fcar/Fcdr for error-checking. */
3361 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3365 return NILP (tem) ? Qnil : Qt;
3369 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3374 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3377 #endif /* FEATUREP_SYNTAX */
3379 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3380 Announce that FEATURE is a feature of the current Emacs.
3381 This function updates the value of the variable `features'.
3386 CHECK_SYMBOL (feature);
3387 if (!NILP (Vautoload_queue))
3388 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3389 tem = Fmemq (feature, Vfeatures);
3391 Vfeatures = Fcons (feature, Vfeatures);
3392 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3396 DEFUN ("require", Frequire, 1, 2, 0, /*
3397 If feature FEATURE is not loaded, load it from FILENAME.
3398 If FEATURE is not a member of the list `features', then the feature
3399 is not loaded; so load the file FILENAME.
3400 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3402 (feature, filename))
3405 CHECK_SYMBOL (feature);
3406 tem = Fmemq (feature, Vfeatures);
3407 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3412 int speccount = specpdl_depth ();
3414 /* Value saved here is to be restored into Vautoload_queue */
3415 record_unwind_protect (un_autoload, Vautoload_queue);
3416 Vautoload_queue = Qt;
3418 call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
3421 tem = Fmemq (feature, Vfeatures);
3423 error ("Required feature %s was not provided",
3424 string_data (XSYMBOL (feature)->name));
3426 /* Once loading finishes, don't undo it. */
3427 Vautoload_queue = Qt;
3428 return unbind_to (speccount, feature);
3432 /* base64 encode/decode functions.
3434 Originally based on code from GNU recode. Ported to FSF Emacs by
3435 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3436 subsequently heavily hacked by Hrvoje Niksic. */
3438 #define MIME_LINE_LENGTH 72
3440 #define IS_ASCII(Character) \
3442 #define IS_BASE64(Character) \
3443 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3445 /* Table of characters coding the 64 values. */
3446 static char base64_value_to_char[64] =
3448 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3449 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3450 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3451 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3452 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3453 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3454 '8', '9', '+', '/' /* 60-63 */
3457 /* Table of base64 values for first 128 characters. */
3458 static short base64_char_to_value[128] =
3460 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3461 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3462 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3463 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3464 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3465 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3466 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3467 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3468 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3469 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3470 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3471 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3472 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3475 /* The following diagram shows the logical steps by which three octets
3476 get transformed into four base64 characters.
3478 .--------. .--------. .--------.
3479 |aaaaaabb| |bbbbcccc| |ccdddddd|
3480 `--------' `--------' `--------'
3482 .--------+--------+--------+--------.
3483 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3484 `--------+--------+--------+--------'
3486 .--------+--------+--------+--------.
3487 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3488 `--------+--------+--------+--------'
3490 The octets are divided into 6 bit chunks, which are then encoded into
3491 base64 characters. */
3493 #define ADVANCE_INPUT(c, stream) \
3494 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3496 (signal_simple_error ("Non-ascii character in base64 input", \
3497 make_char (ec)), 0) \
3498 : (c = (Bufbyte)ec), 1))
3501 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3503 EMACS_INT counter = 0;
3511 if (!ADVANCE_INPUT (c, istream))
3514 /* Wrap line every 76 characters. */
3517 if (counter < MIME_LINE_LENGTH / 4)
3526 /* Process first byte of a triplet. */
3527 *e++ = base64_value_to_char[0x3f & c >> 2];
3528 value = (0x03 & c) << 4;
3530 /* Process second byte of a triplet. */
3531 if (!ADVANCE_INPUT (c, istream))
3533 *e++ = base64_value_to_char[value];
3539 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3540 value = (0x0f & c) << 2;
3542 /* Process third byte of a triplet. */
3543 if (!ADVANCE_INPUT (c, istream))
3545 *e++ = base64_value_to_char[value];
3550 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3551 *e++ = base64_value_to_char[0x3f & c];
3556 #undef ADVANCE_INPUT
3558 /* Get next character from the stream, except that non-base64
3559 characters are ignored. This is in accordance with rfc2045. EC
3560 should be an Emchar, so that it can hold -1 as the value for EOF. */
3561 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3562 ec = Lstream_get_emchar (stream); \
3564 /* IS_BASE64 may not be called with negative arguments so check for \
3566 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3570 #define STORE_BYTE(pos, val, ccnt) do { \
3571 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3576 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3580 EMACS_INT streampos = 0;
3585 unsigned long value;
3587 /* Process first byte of a quadruplet. */
3588 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3592 signal_simple_error ("Illegal `=' character while decoding base64",
3593 make_int (streampos));
3594 value = base64_char_to_value[ec] << 18;
3596 /* Process second byte of a quadruplet. */
3597 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3599 error ("Premature EOF while decoding base64");
3601 signal_simple_error ("Illegal `=' character while decoding base64",
3602 make_int (streampos));
3603 value |= base64_char_to_value[ec] << 12;
3604 STORE_BYTE (e, value >> 16, ccnt);
3606 /* Process third byte of a quadruplet. */
3607 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3609 error ("Premature EOF while decoding base64");
3613 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3615 error ("Premature EOF while decoding base64");
3617 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3618 make_int (streampos));
3622 value |= base64_char_to_value[ec] << 6;
3623 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3625 /* Process fourth byte of a quadruplet. */
3626 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3628 error ("Premature EOF while decoding base64");
3632 value |= base64_char_to_value[ec];
3633 STORE_BYTE (e, 0xff & value, ccnt);
3639 #undef ADVANCE_INPUT
3640 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3644 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3645 Base64-encode the region between START and END.
3646 Return the length of the encoded text.
3647 Optional third argument NO-LINE-BREAK means do not break long lines
3650 (start, end, no_line_break))
3653 Bytind encoded_length;
3654 Charcount allength, length;
3655 struct buffer *buf = current_buffer;
3656 Bufpos begv, zv, old_pt = BUF_PT (buf);
3658 int speccount = specpdl_depth();
3660 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3661 barf_if_buffer_read_only (buf, begv, zv);
3663 /* We need to allocate enough room for encoding the text.
3664 We need 33 1/3% more space, plus a newline every 76
3665 characters, and then we round up. */
3667 allength = length + length/3 + 1;
3668 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3670 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3671 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3672 base64 characters will be single-byte. */
3673 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3674 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3675 NILP (no_line_break));
3676 if (encoded_length > allength)
3678 Lstream_delete (XLSTREAM (input));
3680 /* Now we have encoded the region, so we insert the new contents
3681 and delete the old. (Insert first in order to preserve markers.) */
3682 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3683 XMALLOC_UNBIND (encoded, allength, speccount);
3684 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3686 /* Simulate FSF Emacs implementation of this function: if point was
3687 in the region, place it at the beginning. */
3688 if (old_pt >= begv && old_pt < zv)
3689 BUF_SET_PT (buf, begv);
3691 /* We return the length of the encoded text. */
3692 return make_int (encoded_length);
3695 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3696 Base64 encode STRING and return the result.
3697 Optional argument NO-LINE-BREAK means do not break long lines
3700 (string, no_line_break))
3702 Charcount allength, length;
3703 Bytind encoded_length;
3705 Lisp_Object input, result;
3706 int speccount = specpdl_depth();
3708 CHECK_STRING (string);
3710 length = XSTRING_CHAR_LENGTH (string);
3711 allength = length + length/3 + 1;
3712 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3714 input = make_lisp_string_input_stream (string, 0, -1);
3715 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3716 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3717 NILP (no_line_break));
3718 if (encoded_length > allength)
3720 Lstream_delete (XLSTREAM (input));
3721 result = make_string (encoded, encoded_length);
3722 XMALLOC_UNBIND (encoded, allength, speccount);
3726 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3727 Base64-decode the region between START and END.
3728 Return the length of the decoded text.
3729 If the region can't be decoded, return nil and don't modify the buffer.
3730 Characters out of the base64 alphabet are ignored.
3734 struct buffer *buf = current_buffer;
3735 Bufpos begv, zv, old_pt = BUF_PT (buf);
3737 Bytind decoded_length;
3738 Charcount length, cc_decoded_length;
3740 int speccount = specpdl_depth();
3742 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3743 barf_if_buffer_read_only (buf, begv, zv);
3747 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3748 /* We need to allocate enough room for decoding the text. */
3749 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3750 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3751 if (decoded_length > length * MAX_EMCHAR_LEN)
3753 Lstream_delete (XLSTREAM (input));
3755 /* Now we have decoded the region, so we insert the new contents
3756 and delete the old. (Insert first in order to preserve markers.) */
3757 BUF_SET_PT (buf, begv);
3758 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3759 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3760 buffer_delete_range (buf, begv + cc_decoded_length,
3761 zv + cc_decoded_length, 0);
3763 /* Simulate FSF Emacs implementation of this function: if point was
3764 in the region, place it at the beginning. */
3765 if (old_pt >= begv && old_pt < zv)
3766 BUF_SET_PT (buf, begv);
3768 return make_int (cc_decoded_length);
3771 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3772 Base64-decode STRING and return the result.
3773 Characters out of the base64 alphabet are ignored.
3778 Bytind decoded_length;
3779 Charcount length, cc_decoded_length;
3780 Lisp_Object input, result;
3781 int speccount = specpdl_depth();
3783 CHECK_STRING (string);
3785 length = XSTRING_CHAR_LENGTH (string);
3786 /* We need to allocate enough room for decoding the text. */
3787 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3789 input = make_lisp_string_input_stream (string, 0, -1);
3790 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3791 &cc_decoded_length);
3792 if (decoded_length > length * MAX_EMCHAR_LEN)
3794 Lstream_delete (XLSTREAM (input));
3796 result = make_string (decoded, decoded_length);
3797 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3801 Lisp_Object Qideographic_structure;
3802 Lisp_Object Qkeyword_char;
3804 EXFUN (Fideographic_structure_to_ids, 1);
3806 Lisp_Object ids_format_unit (Lisp_Object ids_char);
3808 ids_format_unit (Lisp_Object ids_char)
3810 if (CHARP (ids_char))
3811 return Fchar_to_string (ids_char);
3812 else if (INTP (ids_char))
3813 return Fchar_to_string (Fdecode_char (Qrep_ucs, ids_char, Qnil, Qnil));
3816 Lisp_Object ret = Ffind_char (ids_char);
3819 return Fchar_to_string (ret);
3822 ret = Fassq (Qideographic_structure, ids_char);
3825 return Fideographic_structure_to_ids (XCDR (ret));
3831 DEFUN ("ideographic-structure-to-ids",
3832 Fideographic_structure_to_ids, 1, 1, 0, /*
3833 Format ideographic-structure IDS-LIST as an IDS-string.
3837 Lisp_Object dest = Qnil;
3839 while (CONSP (ids_list))
3841 Lisp_Object cell = XCAR (ids_list);
3843 if (!NILP (Fchar_ref_p (cell)))
3844 cell = Fplist_get (cell, Qkeyword_char, Qnil);
3845 dest = concat2 (dest, ids_format_unit (cell));
3846 ids_list = XCDR (ids_list);
3851 Lisp_Object simplify_char_spec (Lisp_Object char_spec);
3853 simplify_char_spec (Lisp_Object char_spec)
3855 if (CHARP (char_spec))
3858 int code_point = ENCODE_CHAR (XCHAR (char_spec), ccs);
3860 if (code_point >= 0)
3862 int cid = decode_defined_char (ccs, code_point, Qnil);
3865 return make_char (cid);
3869 else if (INTP (char_spec))
3870 return Fdecode_char (Qrep_ucs, char_spec, Qnil, Qnil);
3874 Lisp_Object ret = Ffind_char (char_spec);
3877 Lisp_Object rest = char_spec;
3880 while (CONSP (rest))
3882 Lisp_Object cell = Fcar (rest);
3887 signal_simple_error ("Invalid argument", char_spec);
3889 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3893 ret = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3895 ret = Fdecode_char (ccs, cell, Qt, Qt);
3903 ret = Fdefine_char (char_spec);
3915 Lisp_Object char_ref_simplify_spec (Lisp_Object char_ref);
3917 char_ref_simplify_spec (Lisp_Object char_ref)
3919 if (!NILP (Fchar_ref_p (char_ref)))
3921 Lisp_Object ret = Fplist_get (char_ref, Qkeyword_char, Qnil);
3926 return Fplist_put (Fcopy_sequence (char_ref), Qkeyword_char,
3927 simplify_char_spec (ret));
3930 return simplify_char_spec (char_ref);
3933 DEFUN ("char-refs-simplify-char-specs",
3934 Fchar_refs_simplify_char_specs, 1, 1, 0, /*
3935 Simplify char-specs in CHAR-REFS.
3939 Lisp_Object rest = char_refs;
3941 while (CONSP (rest))
3943 Fsetcar (rest, char_ref_simplify_spec (XCAR (rest)));
3949 Lisp_Object Qyes_or_no_p;
3954 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3956 defsymbol (&Qstring_lessp, "string-lessp");
3957 defsymbol (&Qidentity, "identity");
3958 defsymbol (&Qideographic_structure, "ideographic-structure");
3959 defsymbol (&Qkeyword_char, ":char");
3960 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3962 DEFSUBR (Fidentity);
3965 DEFSUBR (Fsafe_length);
3966 DEFSUBR (Fstring_equal);
3967 DEFSUBR (Fstring_lessp);
3968 DEFSUBR (Fstring_modified_tick);
3972 DEFSUBR (Fbvconcat);
3973 DEFSUBR (Fcopy_list);
3974 DEFSUBR (Fcopy_sequence);
3975 DEFSUBR (Fcopy_alist);
3976 DEFSUBR (Fcopy_tree);
3977 DEFSUBR (Fsubstring);
3984 DEFSUBR (Fnbutlast);
3986 DEFSUBR (Fold_member);
3988 DEFSUBR (Fold_memq);
3990 DEFSUBR (Fold_assoc);
3992 DEFSUBR (Fold_assq);
3994 DEFSUBR (Fold_rassoc);
3996 DEFSUBR (Fold_rassq);
3998 DEFSUBR (Fold_delete);
4000 DEFSUBR (Fold_delq);
4001 DEFSUBR (Fremassoc);
4003 DEFSUBR (Fremrassoc);
4004 DEFSUBR (Fremrassq);
4005 DEFSUBR (Fnreverse);
4008 DEFSUBR (Fplists_eq);
4009 DEFSUBR (Fplists_equal);
4010 DEFSUBR (Flax_plists_eq);
4011 DEFSUBR (Flax_plists_equal);
4012 DEFSUBR (Fplist_get);
4013 DEFSUBR (Fplist_put);
4014 DEFSUBR (Fplist_remprop);
4015 DEFSUBR (Fplist_member);
4016 DEFSUBR (Fcheck_valid_plist);
4017 DEFSUBR (Fvalid_plist_p);
4018 DEFSUBR (Fcanonicalize_plist);
4019 DEFSUBR (Flax_plist_get);
4020 DEFSUBR (Flax_plist_put);
4021 DEFSUBR (Flax_plist_remprop);
4022 DEFSUBR (Flax_plist_member);
4023 DEFSUBR (Fcanonicalize_lax_plist);
4024 DEFSUBR (Fdestructive_alist_to_plist);
4028 DEFSUBR (Fobject_plist);
4030 DEFSUBR (Fold_equal);
4031 DEFSUBR (Ffillarray);
4034 DEFSUBR (Fmapvector);
4035 DEFSUBR (Fmapc_internal);
4036 DEFSUBR (Fmapconcat);
4037 DEFSUBR (Freplace_list);
4038 DEFSUBR (Fload_average);
4039 DEFSUBR (Ffeaturep);
4042 DEFSUBR (Fbase64_encode_region);
4043 DEFSUBR (Fbase64_encode_string);
4044 DEFSUBR (Fbase64_decode_region);
4045 DEFSUBR (Fbase64_decode_string);
4046 DEFSUBR (Fideographic_structure_to_ids);
4047 DEFSUBR (Fchar_refs_simplify_char_specs);
4051 init_provide_once (void)
4053 DEFVAR_LISP ("features", &Vfeatures /*
4054 A list of symbols which are the features of the executing emacs.
4055 Used by `featurep' and `require', and altered by `provide'.
4059 Fprovide (intern ("base64"));