1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
55 /* NOTE: This symbol is also used in lread.c */
56 #define FEATUREP_SYNTAX
58 Lisp_Object Qstring_lessp;
59 Lisp_Object Qidentity;
61 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
64 mark_bit_vector (Lisp_Object obj)
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
73 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
74 size_t len = bit_vector_length (v);
77 if (INTP (Vprint_length))
78 last = min (len, XINT (Vprint_length));
79 write_c_string ("#*", printcharfun);
80 for (i = 0; i < last; i++)
82 if (bit_vector_bit (v, i))
83 write_c_string ("1", printcharfun);
85 write_c_string ("0", printcharfun);
89 write_c_string ("...", printcharfun);
93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
95 struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
96 struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
98 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
99 !memcmp (v1->bits, v2->bits,
100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
105 bit_vector_hash (Lisp_Object obj, int depth)
107 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 return HASH2 (bit_vector_length (v),
109 memory_hash (v->bits,
110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
114 static const struct lrecord_description bit_vector_description[] = {
115 { XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next), 1 },
120 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
121 mark_bit_vector, print_bit_vector, 0,
122 bit_vector_equal, bit_vector_hash,
123 bit_vector_description,
124 struct Lisp_Bit_Vector);
126 DEFUN ("identity", Fidentity, 1, 1, 0, /*
127 Return the argument unchanged.
134 extern long get_random (void);
135 extern void seed_random (long arg);
137 DEFUN ("random", Frandom, 0, 1, 0, /*
138 Return a pseudo-random number.
139 All integers representable in Lisp are equally likely.
140 On most systems, this is 28 bits' worth.
141 With positive integer argument N, return random number in interval [0,N).
142 With argument t, set the random number seed from the current time and pid.
147 unsigned long denominator;
150 seed_random (getpid () + time (NULL));
151 if (NATNUMP (limit) && !ZEROP (limit))
153 /* Try to take our random number from the higher bits of VAL,
154 not the lower, since (says Gentzel) the low bits of `random'
155 are less random than the higher ones. We do this by using the
156 quotient rather than the remainder. At the high end of the RNG
157 it's possible to get a quotient larger than limit; discarding
158 these values eliminates the bias that would otherwise appear
159 when using a large limit. */
160 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
162 val = get_random () / denominator;
163 while (val >= XINT (limit));
168 return make_int (val);
171 /* Random data-structure functions */
173 #ifdef LOSING_BYTECODE
175 /* #### Delete this shit */
177 /* Charcount is a misnomer here as we might be dealing with the
178 length of a vector or list, but emphasizes that we're not dealing
179 with Bytecounts in strings */
181 length_with_bytecode_hack (Lisp_Object seq)
183 if (!COMPILED_FUNCTIONP (seq))
184 return XINT (Flength (seq));
187 struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
189 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
190 f->flags.domainp ? COMPILED_DOMAIN :
196 #endif /* LOSING_BYTECODE */
199 check_losing_bytecode (CONST char *function, Lisp_Object seq)
201 if (COMPILED_FUNCTIONP (seq))
204 "As of 20.3, `%s' no longer works with compiled-function objects",
208 DEFUN ("length", Flength, 1, 1, 0, /*
209 Return the length of vector, bit vector, list or string SEQUENCE.
214 if (STRINGP (sequence))
215 return make_int (XSTRING_CHAR_LENGTH (sequence));
216 else if (CONSP (sequence))
219 GET_EXTERNAL_LIST_LENGTH (sequence, len);
220 return make_int (len);
222 else if (VECTORP (sequence))
223 return make_int (XVECTOR_LENGTH (sequence));
224 else if (NILP (sequence))
226 else if (BIT_VECTORP (sequence))
227 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
230 check_losing_bytecode ("length", sequence);
231 sequence = wrong_type_argument (Qsequencep, sequence);
236 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
237 Return the length of a list, but avoid error or infinite loop.
238 This function never gets an error. If LIST is not really a list,
239 it returns 0. If LIST is circular, it returns a finite value
240 which is at least the number of distinct elements.
244 Lisp_Object hare, tortoise;
247 for (hare = tortoise = list, len = 0;
248 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
249 hare = XCDR (hare), len++)
252 tortoise = XCDR (tortoise);
255 return make_int (len);
258 /*** string functions. ***/
260 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
261 Return t if two strings have identical contents.
262 Case is significant. Text properties are ignored.
263 \(Under XEmacs, `equal' also ignores text properties and extents in
264 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
265 `equal' is the same as in XEmacs, in that respect.)
266 Symbols are also allowed; their print names are used instead.
271 struct Lisp_String *p1, *p2;
274 p1 = XSYMBOL (s1)->name;
282 p2 = XSYMBOL (s2)->name;
289 return (((len = string_length (p1)) == string_length (p2)) &&
290 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
294 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
295 Return t if first arg string is less than second in lexicographic order.
296 If I18N2 support (but not Mule support) was compiled in, ordering is
297 determined by the locale. (Case is significant for the default C locale.)
298 In all other cases, comparison is simply done on a character-by-
299 character basis using the numeric value of a character. (Note that
300 this may not produce particularly meaningful results under Mule if
301 characters from different charsets are being compared.)
303 Symbols are also allowed; their print names are used instead.
305 The reason that the I18N2 locale-specific collation is not used under
306 Mule is that the locale model of internationalization does not handle
307 multiple charsets and thus has no hope of working properly under Mule.
308 What we really should do is create a collation table over all built-in
309 charsets. This is extremely difficult to do from scratch, however.
311 Unicode is a good first step towards solving this problem. In fact,
312 it is quite likely that a collation table exists (or will exist) for
313 Unicode. When Unicode support is added to XEmacs/Mule, this problem
318 struct Lisp_String *p1, *p2;
323 p1 = XSYMBOL (s1)->name;
331 p2 = XSYMBOL (s2)->name;
338 end = string_char_length (p1);
339 len2 = string_char_length (p2);
343 #if defined (I18N2) && !defined (MULE)
344 /* There is no hope of this working under Mule. Even if we converted
345 the data into an external format so that strcoll() processed it
346 properly, it would still not work because strcoll() does not
347 handle multiple locales. This is the fundamental flaw in the
350 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
351 /* Compare strings using collation order of locale. */
352 /* Need to be tricky to handle embedded nulls. */
354 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
356 int val = strcoll ((char *) string_data (p1) + i,
357 (char *) string_data (p2) + i);
364 #else /* not I18N2, or MULE */
366 Bufbyte *ptr1 = string_data (p1);
367 Bufbyte *ptr2 = string_data (p2);
369 /* #### It is not really necessary to do this: We could compare
370 byte-by-byte and still get a reasonable comparison, since this
371 would compare characters with a charset in the same way. With
372 a little rearrangement of the leading bytes, we could make most
373 inter-charset comparisons work out the same, too; even if some
374 don't, this is not a big deal because inter-charset comparisons
375 aren't really well-defined anyway. */
376 for (i = 0; i < end; i++)
378 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
379 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
384 #endif /* not I18N2, or MULE */
385 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
386 won't work right in I18N2 case */
387 return end < len2 ? Qt : Qnil;
390 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
391 Return STRING's tick counter, incremented for each change to the string.
392 Each string has a tick counter which is incremented each time the contents
393 of the string are changed (e.g. with `aset'). It wraps around occasionally.
397 struct Lisp_String *s;
399 CHECK_STRING (string);
400 s = XSTRING (string);
401 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
402 return XCAR (s->plist);
408 bump_string_modiff (Lisp_Object str)
410 struct Lisp_String *s = XSTRING (str);
411 Lisp_Object *ptr = &s->plist;
414 /* #### remove the `string-translatable' property from the string,
417 /* skip over extent info if it's there */
418 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
420 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
421 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
423 *ptr = Fcons (make_int (1), *ptr);
427 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
428 static Lisp_Object concat (int nargs, Lisp_Object *args,
429 enum concat_target_type target_type,
433 concat2 (Lisp_Object s1, Lisp_Object s2)
438 return concat (2, args, c_string, 0);
442 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
448 return concat (3, args, c_string, 0);
452 vconcat2 (Lisp_Object s1, Lisp_Object s2)
457 return concat (2, args, c_vector, 0);
461 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
467 return concat (3, args, c_vector, 0);
470 DEFUN ("append", Fappend, 0, MANY, 0, /*
471 Concatenate all the arguments and make the result a list.
472 The result is a list whose elements are the elements of all the arguments.
473 Each argument may be a list, vector, bit vector, or string.
474 The last argument is not copied, just used as the tail of the new list.
477 (int nargs, Lisp_Object *args))
479 return concat (nargs, args, c_cons, 1);
482 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
483 Concatenate all the arguments and make the result a string.
484 The result is a string whose elements are the elements of all the arguments.
485 Each argument may be a string or a list or vector of characters.
487 As of XEmacs 21.0, this function does NOT accept individual integers
488 as arguments. Old code that relies on, for example, (concat "foo" 50)
489 returning "foo50" will fail. To fix such code, either apply
490 `int-to-string' to the integer argument, or use `format'.
492 (int nargs, Lisp_Object *args))
494 return concat (nargs, args, c_string, 0);
497 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
498 Concatenate all the arguments and make the result a vector.
499 The result is a vector whose elements are the elements of all the arguments.
500 Each argument may be a list, vector, bit vector, or string.
502 (int nargs, Lisp_Object *args))
504 return concat (nargs, args, c_vector, 0);
507 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
508 Concatenate all the arguments and make the result a bit vector.
509 The result is a bit vector whose elements are the elements of all the
510 arguments. Each argument may be a list, vector, bit vector, or string.
512 (int nargs, Lisp_Object *args))
514 return concat (nargs, args, c_bit_vector, 0);
517 /* Copy a (possibly dotted) list. LIST must be a cons.
518 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
520 copy_list (Lisp_Object list)
522 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
523 Lisp_Object last = list_copy;
524 Lisp_Object hare, tortoise;
527 for (tortoise = hare = XCDR (list), len = 1;
529 hare = XCDR (hare), len++)
531 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
534 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
537 tortoise = XCDR (tortoise);
538 if (EQ (tortoise, hare))
539 signal_circular_list_error (list);
545 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
546 Return a copy of list LIST, which may be a dotted list.
547 The elements of LIST are not copied; they are shared
553 if (NILP (list)) return list;
554 if (CONSP (list)) return copy_list (list);
556 list = wrong_type_argument (Qlistp, list);
560 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
561 Return a copy of list, vector, bit vector or string SEQUENCE.
562 The elements of a list or vector are not copied; they are shared
563 with the original. SEQUENCE may be a dotted list.
568 if (NILP (sequence)) return sequence;
569 if (CONSP (sequence)) return copy_list (sequence);
570 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
571 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
572 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
574 check_losing_bytecode ("copy-sequence", sequence);
575 sequence = wrong_type_argument (Qsequencep, sequence);
579 struct merge_string_extents_struct
582 Bytecount entry_offset;
583 Bytecount entry_length;
587 concat (int nargs, Lisp_Object *args,
588 enum concat_target_type target_type,
592 Lisp_Object tail = Qnil;
595 Lisp_Object last_tail;
597 struct merge_string_extents_struct *args_mse = 0;
598 Bufbyte *string_result = 0;
599 Bufbyte *string_result_ptr = 0;
602 /* The modus operandi in Emacs is "caller gc-protects args".
603 However, concat is called many times in Emacs on freshly
604 created stuff. So we help those callers out by protecting
605 the args ourselves to save them a lot of temporary-variable
609 gcpro1.nvars = nargs;
612 /* #### if the result is a string and any of the strings have a string
613 for the `string-translatable' property, then concat should also
614 concat the args but use the `string-translatable' strings, and store
615 the result in the returned string's `string-translatable' property. */
617 if (target_type == c_string)
618 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
620 /* In append, the last arg isn't treated like the others */
621 if (last_special && nargs > 0)
624 last_tail = args[nargs];
629 /* Check and coerce the arguments. */
630 for (argnum = 0; argnum < nargs; argnum++)
632 Lisp_Object seq = args[argnum];
635 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
637 #ifdef LOSING_BYTECODE
638 else if (COMPILED_FUNCTIONP (seq))
639 /* Urk! We allow this, for "compatibility"... */
642 #if 0 /* removed for XEmacs 21 */
644 /* This is too revolting to think about but maintains
645 compatibility with FSF (and lots and lots of old code). */
646 args[argnum] = Fnumber_to_string (seq);
650 check_losing_bytecode ("concat", seq);
651 args[argnum] = wrong_type_argument (Qsequencep, seq);
657 args_mse[argnum].string = seq;
659 args_mse[argnum].string = Qnil;
664 /* Charcount is a misnomer here as we might be dealing with the
665 length of a vector or list, but emphasizes that we're not dealing
666 with Bytecounts in strings */
667 Charcount total_length;
669 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
671 #ifdef LOSING_BYTECODE
672 Charcount thislen = length_with_bytecode_hack (args[argnum]);
674 Charcount thislen = XINT (Flength (args[argnum]));
676 total_length += thislen;
682 if (total_length == 0)
683 /* In append, if all but last arg are nil, return last arg */
684 RETURN_UNGCPRO (last_tail);
685 val = Fmake_list (make_int (total_length), Qnil);
688 val = make_vector (total_length, Qnil);
691 val = make_bit_vector (total_length, Qzero);
694 /* We don't make the string yet because we don't know the
695 actual number of bytes. This loop was formerly written
696 to call Fmake_string() here and then call set_string_char()
697 for each char. This seems logical enough but is waaaaaaaay
698 slow -- set_string_char() has to scan the whole string up
699 to the place where the substitution is called for in order
700 to find the place to change, and may have to do some
701 realloc()ing in order to make the char fit properly.
704 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
705 string_result_ptr = string_result;
714 tail = val, toindex = -1; /* -1 in toindex is flag we are
721 for (argnum = 0; argnum < nargs; argnum++)
723 Charcount thisleni = 0;
724 Charcount thisindex = 0;
725 Lisp_Object seq = args[argnum];
726 Bufbyte *string_source_ptr = 0;
727 Bufbyte *string_prev_result_ptr = string_result_ptr;
731 #ifdef LOSING_BYTECODE
732 thisleni = length_with_bytecode_hack (seq);
734 thisleni = XINT (Flength (seq));
738 string_source_ptr = XSTRING_DATA (seq);
744 /* We've come to the end of this arg, so exit. */
748 /* Fetch next element of `seq' arg into `elt' */
756 if (thisindex >= thisleni)
761 elt = make_char (charptr_emchar (string_source_ptr));
762 INC_CHARPTR (string_source_ptr);
764 else if (VECTORP (seq))
765 elt = XVECTOR_DATA (seq)[thisindex];
766 else if (BIT_VECTORP (seq))
767 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
770 elt = Felt (seq, make_int (thisindex));
774 /* Store into result */
777 /* toindex negative means we are making a list */
782 else if (VECTORP (val))
783 XVECTOR_DATA (val)[toindex++] = elt;
784 else if (BIT_VECTORP (val))
787 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
791 CHECK_CHAR_COERCE_INT (elt);
792 string_result_ptr += set_charptr_emchar (string_result_ptr,
798 args_mse[argnum].entry_offset =
799 string_prev_result_ptr - string_result;
800 args_mse[argnum].entry_length =
801 string_result_ptr - string_prev_result_ptr;
805 /* Now we finally make the string. */
806 if (target_type == c_string)
808 val = make_string (string_result, string_result_ptr - string_result);
809 for (argnum = 0; argnum < nargs; argnum++)
811 if (STRINGP (args_mse[argnum].string))
812 copy_string_extents (val, args_mse[argnum].string,
813 args_mse[argnum].entry_offset, 0,
814 args_mse[argnum].entry_length);
819 XCDR (prev) = last_tail;
821 RETURN_UNGCPRO (val);
824 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
825 Return a copy of ALIST.
826 This is an alist which represents the same mapping from objects to objects,
827 but does not share the alist structure with ALIST.
828 The objects mapped (cars and cdrs of elements of the alist)
830 Elements of ALIST that are not conses are also shared.
840 alist = concat (1, &alist, c_cons, 0);
841 for (tail = alist; CONSP (tail); tail = XCDR (tail))
843 Lisp_Object car = XCAR (tail);
846 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
851 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
852 Return a copy of a list and substructures.
853 The argument is copied, and any lists contained within it are copied
854 recursively. Circularities and shared substructures are not preserved.
855 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
863 rest = arg = Fcopy_sequence (arg);
866 Lisp_Object elt = XCAR (rest);
868 if (CONSP (elt) || VECTORP (elt))
869 XCAR (rest) = Fcopy_tree (elt, vecp);
870 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
871 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
875 else if (VECTORP (arg) && ! NILP (vecp))
877 int i = XVECTOR_LENGTH (arg);
879 arg = Fcopy_sequence (arg);
880 for (j = 0; j < i; j++)
882 Lisp_Object elt = XVECTOR_DATA (arg) [j];
884 if (CONSP (elt) || VECTORP (elt))
885 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
891 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
892 Return a substring of STRING, starting at index FROM and ending before TO.
893 TO may be nil or omitted; then the substring runs to the end of STRING.
894 If FROM or TO is negative, it counts from the end.
895 Relevant parts of the string-extent-data are copied in the new string.
899 Charcount ccfr, ccto;
903 CHECK_STRING (string);
905 get_string_range_char (string, from, to, &ccfr, &ccto,
906 GB_HISTORICAL_STRING_BEHAVIOR);
907 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
908 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
909 val = make_string (XSTRING_DATA (string) + bfr, blen);
910 /* Copy any applicable extent information into the new string: */
911 copy_string_extents (val, string, 0, bfr, blen);
915 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
916 Return a subsequence of SEQ, starting at index FROM and ending before TO.
917 TO may be nil or omitted; then the subsequence runs to the end of SEQ.
918 If FROM or TO is negative, it counts from the end.
919 The resulting subsequence is always the same type as the original
921 If SEQ is a string, relevant parts of the string-extent-data are copied
929 return Fsubstring (seq, from, to);
931 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
933 check_losing_bytecode ("subseq", seq);
934 seq = wrong_type_argument (Qsequencep, seq);
937 len = XINT (Flength (seq));
954 if (!(0 <= f && f <= t && t <= len))
955 args_out_of_range_3 (seq, make_int (f), make_int (t));
959 Lisp_Object result = make_vector (t - f, Qnil);
961 Lisp_Object *in_elts = XVECTOR_DATA (seq);
962 Lisp_Object *out_elts = XVECTOR_DATA (result);
964 for (i = f; i < t; i++)
965 out_elts[i - f] = in_elts[i];
971 Lisp_Object result = Qnil;
974 seq = Fnthcdr (make_int (f), seq);
976 for (i = f; i < t; i++)
978 result = Fcons (Fcar (seq), result);
982 return Fnreverse (result);
987 Lisp_Object result = make_bit_vector (t - f, Qzero);
990 for (i = f; i < t; i++)
991 set_bit_vector_bit (XBIT_VECTOR (result), i - f,
992 bit_vector_bit (XBIT_VECTOR (seq), i));
998 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
999 Take cdr N times on LIST, and return the result.
1004 REGISTER Lisp_Object tail = list;
1006 for (i = XINT (n); i; i--)
1010 else if (NILP (tail))
1014 tail = wrong_type_argument (Qlistp, tail);
1021 DEFUN ("nth", Fnth, 2, 2, 0, /*
1022 Return the Nth element of LIST.
1023 N counts from zero. If LIST is not that long, nil is returned.
1027 return Fcar (Fnthcdr (n, list));
1030 DEFUN ("elt", Felt, 2, 2, 0, /*
1031 Return element of SEQUENCE at index N.
1036 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1037 if (LISTP (sequence))
1039 Lisp_Object tem = Fnthcdr (n, sequence);
1040 /* #### Utterly, completely, fucking disgusting.
1041 * #### The whole point of "elt" is that it operates on
1042 * #### sequences, and does error- (bounds-) checking.
1048 /* This is The Way It Has Always Been. */
1051 /* This is The Way Mly and Cltl2 say It Should Be. */
1052 args_out_of_range (sequence, n);
1055 else if (STRINGP (sequence) ||
1056 VECTORP (sequence) ||
1057 BIT_VECTORP (sequence))
1058 return Faref (sequence, n);
1059 #ifdef LOSING_BYTECODE
1060 else if (COMPILED_FUNCTIONP (sequence))
1062 EMACS_INT idx = XINT (n);
1066 args_out_of_range (sequence, n);
1068 /* Utter perversity */
1070 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1073 case COMPILED_ARGLIST:
1074 return compiled_function_arglist (f);
1075 case COMPILED_INSTRUCTIONS:
1076 return compiled_function_instructions (f);
1077 case COMPILED_CONSTANTS:
1078 return compiled_function_constants (f);
1079 case COMPILED_STACK_DEPTH:
1080 return compiled_function_stack_depth (f);
1081 case COMPILED_DOC_STRING:
1082 return compiled_function_documentation (f);
1083 case COMPILED_DOMAIN:
1084 return compiled_function_domain (f);
1085 case COMPILED_INTERACTIVE:
1086 if (f->flags.interactivep)
1087 return compiled_function_interactive (f);
1088 /* if we return nil, can't tell interactive with no args
1089 from noninteractive. */
1096 #endif /* LOSING_BYTECODE */
1099 check_losing_bytecode ("elt", sequence);
1100 sequence = wrong_type_argument (Qsequencep, sequence);
1105 DEFUN ("last", Flast, 1, 2, 0, /*
1106 Return the tail of list LIST, of length N (default 1).
1107 LIST may be a dotted list, but not a circular list.
1108 Optional argument N must be a non-negative integer.
1109 If N is zero, then the atom that terminates the list is returned.
1110 If N is greater than the length of LIST, then LIST itself is returned.
1114 EMACS_INT int_n, count;
1115 Lisp_Object retval, tortoise, hare;
1127 for (retval = tortoise = hare = list, count = 0;
1130 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1133 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1136 tortoise = XCDR (tortoise);
1137 if (EQ (hare, tortoise))
1138 signal_circular_list_error (list);
1144 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1145 Modify LIST to remove the last N (default 1) elements.
1146 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1163 Lisp_Object last_cons = list;
1165 EXTERNAL_LIST_LOOP_1 (list)
1168 last_cons = XCDR (last_cons);
1174 XCDR (last_cons) = Qnil;
1179 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1180 Return a copy of LIST with the last N (default 1) elements removed.
1181 If LIST has N or fewer elements, nil is returned.
1198 Lisp_Object retval = Qnil;
1199 Lisp_Object tail = list;
1201 EXTERNAL_LIST_LOOP_1 (list)
1205 retval = Fcons (XCAR (tail), retval);
1210 return Fnreverse (retval);
1214 DEFUN ("member", Fmember, 2, 2, 0, /*
1215 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1216 The value is actually the tail of LIST whose car is ELT.
1220 Lisp_Object list_elt, tail;
1221 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1223 if (internal_equal (elt, list_elt, 0))
1229 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1230 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1231 The value is actually the tail of LIST whose car is ELT.
1232 This function is provided only for byte-code compatibility with v19.
1237 Lisp_Object list_elt, tail;
1238 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1240 if (internal_old_equal (elt, list_elt, 0))
1246 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1247 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1248 The value is actually the tail of LIST whose car is ELT.
1252 Lisp_Object list_elt, tail;
1253 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1255 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1261 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1262 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1263 The value is actually the tail of LIST whose car is ELT.
1264 This function is provided only for byte-code compatibility with v19.
1269 Lisp_Object list_elt, tail;
1270 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1272 if (HACKEQ_UNSAFE (elt, list_elt))
1279 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1281 Lisp_Object list_elt, tail;
1282 LIST_LOOP_3 (list_elt, list, tail)
1284 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1290 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1291 Return non-nil if KEY is `equal' to the car of an element of LIST.
1292 The value is actually the element of LIST whose car equals KEY.
1296 /* This function can GC. */
1297 Lisp_Object elt, elt_car, elt_cdr;
1298 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1300 if (internal_equal (key, elt_car, 0))
1306 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1307 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1308 The value is actually the element of LIST whose car equals KEY.
1312 /* This function can GC. */
1313 Lisp_Object elt, elt_car, elt_cdr;
1314 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1316 if (internal_old_equal (key, elt_car, 0))
1323 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1325 int speccount = specpdl_depth ();
1326 specbind (Qinhibit_quit, Qt);
1327 return unbind_to (speccount, Fassoc (key, list));
1330 DEFUN ("assq", Fassq, 2, 2, 0, /*
1331 Return non-nil if KEY is `eq' to the car of an element of LIST.
1332 The value is actually the element of LIST whose car is KEY.
1333 Elements of LIST that are not conses are ignored.
1337 Lisp_Object elt, elt_car, elt_cdr;
1338 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1340 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1346 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1347 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1348 The value is actually the element of LIST whose car is KEY.
1349 Elements of LIST that are not conses are ignored.
1350 This function is provided only for byte-code compatibility with v19.
1355 Lisp_Object elt, elt_car, elt_cdr;
1356 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1358 if (HACKEQ_UNSAFE (key, elt_car))
1364 /* Like Fassq but never report an error and do not allow quits.
1365 Use only on lists known never to be circular. */
1368 assq_no_quit (Lisp_Object key, Lisp_Object list)
1370 /* This cannot GC. */
1372 LIST_LOOP_2 (elt, list)
1374 Lisp_Object elt_car = XCAR (elt);
1375 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1381 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1382 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1383 The value is actually the element of LIST whose cdr equals KEY.
1387 Lisp_Object elt, elt_car, elt_cdr;
1388 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1390 if (internal_equal (key, elt_cdr, 0))
1396 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1397 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1398 The value is actually the element of LIST whose cdr equals KEY.
1402 Lisp_Object elt, elt_car, elt_cdr;
1403 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1405 if (internal_old_equal (key, elt_cdr, 0))
1411 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1412 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1413 The value is actually the element of LIST whose cdr is KEY.
1417 Lisp_Object elt, elt_car, elt_cdr;
1418 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1420 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1426 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1427 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1428 The value is actually the element of LIST whose cdr is KEY.
1432 Lisp_Object elt, elt_car, elt_cdr;
1433 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1435 if (HACKEQ_UNSAFE (key, elt_cdr))
1441 /* Like Frassq, but caller must ensure that LIST is properly
1442 nil-terminated and ebola-free. */
1444 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1447 LIST_LOOP_2 (elt, list)
1449 Lisp_Object elt_cdr = XCDR (elt);
1450 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1457 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1458 Delete by side effect any occurrences of ELT as a member of LIST.
1459 The modified LIST is returned. Comparison is done with `equal'.
1460 If the first member of LIST is ELT, there is no way to remove it by side
1461 effect; therefore, write `(setq foo (delete element foo))' to be sure
1462 of changing the value of `foo'.
1467 Lisp_Object list_elt;
1468 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1469 (internal_equal (elt, list_elt, 0)));
1473 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1474 Delete by side effect any occurrences of ELT as a member of LIST.
1475 The modified LIST is returned. Comparison is done with `old-equal'.
1476 If the first member of LIST is ELT, there is no way to remove it by side
1477 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1478 of changing the value of `foo'.
1482 Lisp_Object list_elt;
1483 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1484 (internal_old_equal (elt, list_elt, 0)));
1488 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1489 Delete by side effect any occurrences of ELT as a member of LIST.
1490 The modified LIST is returned. Comparison is done with `eq'.
1491 If the first member of LIST is ELT, there is no way to remove it by side
1492 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1493 changing the value of `foo'.
1497 Lisp_Object list_elt;
1498 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1499 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1503 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1504 Delete by side effect any occurrences of ELT as a member of LIST.
1505 The modified LIST is returned. Comparison is done with `old-eq'.
1506 If the first member of LIST is ELT, there is no way to remove it by side
1507 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1508 changing the value of `foo'.
1512 Lisp_Object list_elt;
1513 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1514 (HACKEQ_UNSAFE (elt, list_elt)));
1518 /* Like Fdelq, but caller must ensure that LIST is properly
1519 nil-terminated and ebola-free. */
1522 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1524 Lisp_Object list_elt;
1525 LIST_LOOP_DELETE_IF (list_elt, list,
1526 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1530 /* Be VERY careful with this. This is like delq_no_quit() but
1531 also calls free_cons() on the removed conses. You must be SURE
1532 that no pointers to the freed conses remain around (e.g.
1533 someone else is pointing to part of the list). This function
1534 is useful on internal lists that are used frequently and where
1535 the actual list doesn't escape beyond known code bounds. */
1538 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1540 REGISTER Lisp_Object tail = list;
1541 REGISTER Lisp_Object prev = Qnil;
1543 while (!NILP (tail))
1545 REGISTER Lisp_Object tem = XCAR (tail);
1548 Lisp_Object cons_to_free = tail;
1552 XCDR (prev) = XCDR (tail);
1554 free_cons (XCONS (cons_to_free));
1565 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1566 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1567 The modified LIST is returned. If the first member of LIST has a car
1568 that is `equal' to KEY, there is no way to remove it by side effect;
1569 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1575 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1577 internal_equal (key, XCAR (elt), 0)));
1582 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1584 int speccount = specpdl_depth ();
1585 specbind (Qinhibit_quit, Qt);
1586 return unbind_to (speccount, Fremassoc (key, list));
1589 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1590 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1591 The modified LIST is returned. If the first member of LIST has a car
1592 that is `eq' to KEY, there is no way to remove it by side effect;
1593 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1599 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1601 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1605 /* no quit, no errors; be careful */
1608 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1611 LIST_LOOP_DELETE_IF (elt, list,
1613 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1617 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1618 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1619 The modified LIST is returned. If the first member of LIST has a car
1620 that is `equal' to VALUE, there is no way to remove it by side effect;
1621 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1627 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1629 internal_equal (value, XCDR (elt), 0)));
1633 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1634 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1635 The modified LIST is returned. If the first member of LIST has a car
1636 that is `eq' to VALUE, there is no way to remove it by side effect;
1637 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1643 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1645 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1649 /* Like Fremrassq, fast and unsafe; be careful */
1651 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1654 LIST_LOOP_DELETE_IF (elt, list,
1656 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1660 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1661 Reverse LIST by destructively modifying cdr pointers.
1662 Return the beginning of the reversed list.
1663 Also see: `reverse'.
1667 struct gcpro gcpro1, gcpro2;
1668 REGISTER Lisp_Object prev = Qnil;
1669 REGISTER Lisp_Object tail = list;
1671 /* We gcpro our args; see `nconc' */
1672 GCPRO2 (prev, tail);
1673 while (!NILP (tail))
1675 REGISTER Lisp_Object next;
1676 CONCHECK_CONS (tail);
1686 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1687 Reverse LIST, copying. Return the beginning of the reversed list.
1688 See also the function `nreverse', which is used more often.
1692 Lisp_Object reversed_list = Qnil;
1694 EXTERNAL_LIST_LOOP_2 (elt, list)
1696 reversed_list = Fcons (elt, reversed_list);
1698 return reversed_list;
1701 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1702 Lisp_Object lisp_arg,
1703 int (*pred_fn) (Lisp_Object, Lisp_Object,
1704 Lisp_Object lisp_arg));
1707 list_sort (Lisp_Object list,
1708 Lisp_Object lisp_arg,
1709 int (*pred_fn) (Lisp_Object, Lisp_Object,
1710 Lisp_Object lisp_arg))
1712 struct gcpro gcpro1, gcpro2, gcpro3;
1713 Lisp_Object back, tem;
1714 Lisp_Object front = list;
1715 Lisp_Object len = Flength (list);
1716 int length = XINT (len);
1721 XSETINT (len, (length / 2) - 1);
1722 tem = Fnthcdr (len, list);
1724 Fsetcdr (tem, Qnil);
1726 GCPRO3 (front, back, lisp_arg);
1727 front = list_sort (front, lisp_arg, pred_fn);
1728 back = list_sort (back, lisp_arg, pred_fn);
1730 return list_merge (front, back, lisp_arg, pred_fn);
1735 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1740 /* prevents the GC from happening in call2 */
1741 int speccount = specpdl_depth ();
1742 /* Emacs' GC doesn't actually relocate pointers, so this probably
1743 isn't strictly necessary */
1744 record_unwind_protect (restore_gc_inhibit,
1745 make_int (gc_currently_forbidden));
1746 gc_currently_forbidden = 1;
1747 tmp = call2 (pred, obj1, obj2);
1748 unbind_to (speccount, Qnil);
1756 DEFUN ("sort", Fsort, 2, 2, 0, /*
1757 Sort LIST, stably, comparing elements using PREDICATE.
1758 Returns the sorted list. LIST is modified by side effects.
1759 PREDICATE is called with two elements of LIST, and should return T
1760 if the first element is "less" than the second.
1764 return list_sort (list, pred, merge_pred_function);
1768 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1771 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1776 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1777 Lisp_Object lisp_arg,
1778 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1784 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1791 /* It is sufficient to protect org_l1 and org_l2.
1792 When l1 and l2 are updated, we copy the new values
1793 back into the org_ vars. */
1795 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1816 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1831 Fsetcdr (tail, tem);
1837 /************************************************************************/
1838 /* property-list functions */
1839 /************************************************************************/
1841 /* For properties of text, we need to do order-insensitive comparison of
1842 plists. That is, we need to compare two plists such that they are the
1843 same if they have the same set of keys, and equivalent values.
1844 So (a 1 b 2) would be equal to (b 2 a 1).
1846 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1847 LAXP means use `equal' for comparisons.
1850 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1851 int laxp, int depth)
1853 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
1854 int la, lb, m, i, fill;
1855 Lisp_Object *keys, *vals;
1859 if (NILP (a) && NILP (b))
1862 Fcheck_valid_plist (a);
1863 Fcheck_valid_plist (b);
1865 la = XINT (Flength (a));
1866 lb = XINT (Flength (b));
1867 m = (la > lb ? la : lb);
1869 keys = alloca_array (Lisp_Object, m);
1870 vals = alloca_array (Lisp_Object, m);
1871 flags = alloca_array (char, m);
1873 /* First extract the pairs from A. */
1874 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1876 Lisp_Object k = XCAR (rest);
1877 Lisp_Object v = XCAR (XCDR (rest));
1878 /* Maybe be Ebolified. */
1879 if (nil_means_not_present && NILP (v)) continue;
1885 /* Now iterate over B, and stop if we find something that's not in A,
1886 or that doesn't match. As we match, mark them. */
1887 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1889 Lisp_Object k = XCAR (rest);
1890 Lisp_Object v = XCAR (XCDR (rest));
1891 /* Maybe be Ebolified. */
1892 if (nil_means_not_present && NILP (v)) continue;
1893 for (i = 0; i < fill; i++)
1895 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1898 /* We narrowly escaped being Ebolified here. */
1899 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1900 : !internal_equal (v, vals [i], depth))
1901 /* a property in B has a different value than in A */
1908 /* there are some properties in B that are not in A */
1911 /* Now check to see that all the properties in A were also in B */
1912 for (i = 0; i < fill; i++)
1923 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1924 Return non-nil if property lists A and B are `eq'.
1925 A property list is an alternating list of keywords and values.
1926 This function does order-insensitive comparisons of the property lists:
1927 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1928 Comparison between values is done using `eq'. See also `plists-equal'.
1929 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1930 a nil value is ignored. This feature is a virus that has infected
1931 old Lisp implementations, but should not be used except for backward
1934 (a, b, nil_means_not_present))
1936 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1940 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1941 Return non-nil if property lists A and B are `equal'.
1942 A property list is an alternating list of keywords and values. This
1943 function does order-insensitive comparisons of the property lists: For
1944 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1945 Comparison between values is done using `equal'. See also `plists-eq'.
1946 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1947 a nil value is ignored. This feature is a virus that has infected
1948 old Lisp implementations, but should not be used except for backward
1951 (a, b, nil_means_not_present))
1953 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1958 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1959 Return non-nil if lax property lists A and B are `eq'.
1960 A property list is an alternating list of keywords and values.
1961 This function does order-insensitive comparisons of the property lists:
1962 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1963 Comparison between values is done using `eq'. See also `plists-equal'.
1964 A lax property list is like a regular one except that comparisons between
1965 keywords is done using `equal' instead of `eq'.
1966 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1967 a nil value is ignored. This feature is a virus that has infected
1968 old Lisp implementations, but should not be used except for backward
1971 (a, b, nil_means_not_present))
1973 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1977 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1978 Return non-nil if lax property lists A and B are `equal'.
1979 A property list is an alternating list of keywords and values. This
1980 function does order-insensitive comparisons of the property lists: For
1981 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1982 Comparison between values is done using `equal'. See also `plists-eq'.
1983 A lax property list is like a regular one except that comparisons between
1984 keywords is done using `equal' instead of `eq'.
1985 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1986 a nil value is ignored. This feature is a virus that has infected
1987 old Lisp implementations, but should not be used except for backward
1990 (a, b, nil_means_not_present))
1992 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1996 /* Return the value associated with key PROPERTY in property list PLIST.
1997 Return nil if key not found. This function is used for internal
1998 property lists that cannot be directly manipulated by the user.
2002 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2006 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2008 if (EQ (XCAR (tail), property))
2009 return XCAR (XCDR (tail));
2015 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2016 internal_plist_get(). */
2019 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2024 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2026 if (EQ (XCAR (tail), property))
2028 XCAR (XCDR (tail)) = value;
2033 *plist = Fcons (property, Fcons (value, *plist));
2037 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2039 Lisp_Object tail, prev;
2041 for (tail = *plist, prev = Qnil;
2043 tail = XCDR (XCDR (tail)))
2045 if (EQ (XCAR (tail), property))
2048 *plist = XCDR (XCDR (tail));
2050 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2060 /* Called on a malformed property list. BADPLACE should be some
2061 place where truncating will form a good list -- i.e. we shouldn't
2062 result in a list with an odd length. */
2065 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2067 if (ERRB_EQ (errb, ERROR_ME))
2068 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2071 if (ERRB_EQ (errb, ERROR_ME_WARN))
2073 warn_when_safe_lispobj
2076 ("Malformed property list -- list has been truncated"),
2084 /* Called on a circular property list. BADPLACE should be some place
2085 where truncating will result in an even-length list, as above.
2086 If doesn't particularly matter where we truncate -- anywhere we
2087 truncate along the entire list will break the circularity, because
2088 it will create a terminus and the list currently doesn't have one.
2092 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2094 if (ERRB_EQ (errb, ERROR_ME))
2095 /* #### Eek, this will probably result in another error
2096 when PLIST is printed out */
2097 return Fsignal (Qcircular_property_list, list1 (*plist));
2100 if (ERRB_EQ (errb, ERROR_ME_WARN))
2102 warn_when_safe_lispobj
2105 ("Circular property list -- list has been truncated"),
2113 /* Advance the tortoise pointer by two (one iteration of a property-list
2114 loop) and the hare pointer by four and verify that no malformations
2115 or circularities exist. If so, return zero and store a value into
2116 RETVAL that should be returned by the calling function. Otherwise,
2117 return 1. See external_plist_get().
2121 advance_plist_pointers (Lisp_Object *plist,
2122 Lisp_Object **tortoise, Lisp_Object **hare,
2123 Error_behavior errb, Lisp_Object *retval)
2126 Lisp_Object *tortsave = *tortoise;
2128 /* Note that our "fixing" may be more brutal than necessary,
2129 but it's the user's own problem, not ours, if they went in and
2130 manually fucked up a plist. */
2132 for (i = 0; i < 2; i++)
2134 /* This is a standard iteration of a defensive-loop-checking
2135 loop. We just do it twice because we want to advance past
2136 both the property and its value.
2138 If the pointer indirection is confusing you, remember that
2139 one level of indirection on the hare and tortoise pointers
2140 is only due to pass-by-reference for this function. The other
2141 level is so that the plist can be fixed in place. */
2143 /* When we reach the end of a well-formed plist, **HARE is
2144 nil. In that case, we don't do anything at all except
2145 advance TORTOISE by one. Otherwise, we advance HARE
2146 by two (making sure it's OK to do so), then advance
2147 TORTOISE by one (it will always be OK to do so because
2148 the HARE is always ahead of the TORTOISE and will have
2149 already verified the path), then make sure TORTOISE and
2150 HARE don't contain the same non-nil object -- if the
2151 TORTOISE and the HARE ever meet, then obviously we're
2152 in a circularity, and if we're in a circularity, then
2153 the TORTOISE and the HARE can't cross paths without
2154 meeting, since the HARE only gains one step over the
2155 TORTOISE per iteration. */
2159 Lisp_Object *haresave = *hare;
2160 if (!CONSP (**hare))
2162 *retval = bad_bad_bunny (plist, haresave, errb);
2165 *hare = &XCDR (**hare);
2166 /* In a non-plist, we'd check here for a nil value for
2167 **HARE, which is OK (it just means the list has an
2168 odd number of elements). In a plist, it's not OK
2169 for the list to have an odd number of elements. */
2170 if (!CONSP (**hare))
2172 *retval = bad_bad_bunny (plist, haresave, errb);
2175 *hare = &XCDR (**hare);
2178 *tortoise = &XCDR (**tortoise);
2179 if (!NILP (**hare) && EQ (**tortoise, **hare))
2181 *retval = bad_bad_turtle (plist, tortsave, errb);
2189 /* Return the value of PROPERTY from PLIST, or Qunbound if
2190 property is not on the list.
2192 PLIST is a Lisp-accessible property list, meaning that it
2193 has to be checked for malformations and circularities.
2195 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2196 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2197 on finding a malformation or a circularity, it issues a warning and
2198 attempts to silently fix the problem.
2200 A pointer to PLIST is passed in so that PLIST can be successfully
2201 "fixed" even if the error is at the beginning of the plist. */
2204 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2205 int laxp, Error_behavior errb)
2207 Lisp_Object *tortoise = plist;
2208 Lisp_Object *hare = plist;
2210 while (!NILP (*tortoise))
2212 Lisp_Object *tortsave = tortoise;
2215 /* We do the standard tortoise/hare march. We isolate the
2216 grungy stuff to do this in advance_plist_pointers(), though.
2217 To us, all this function does is advance the tortoise
2218 pointer by two and the hare pointer by four and make sure
2219 everything's OK. We first advance the pointers and then
2220 check if a property matched; this ensures that our
2221 check for a matching property is safe. */
2223 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2226 if (!laxp ? EQ (XCAR (*tortsave), property)
2227 : internal_equal (XCAR (*tortsave), property, 0))
2228 return XCAR (XCDR (*tortsave));
2234 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2235 malformed or circular plist. Analogous to external_plist_get(). */
2238 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2239 Lisp_Object value, int laxp, Error_behavior errb)
2241 Lisp_Object *tortoise = plist;
2242 Lisp_Object *hare = plist;
2244 while (!NILP (*tortoise))
2246 Lisp_Object *tortsave = tortoise;
2250 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2253 if (!laxp ? EQ (XCAR (*tortsave), property)
2254 : internal_equal (XCAR (*tortsave), property, 0))
2256 XCAR (XCDR (*tortsave)) = value;
2261 *plist = Fcons (property, Fcons (value, *plist));
2265 external_remprop (Lisp_Object *plist, Lisp_Object property,
2266 int laxp, Error_behavior errb)
2268 Lisp_Object *tortoise = plist;
2269 Lisp_Object *hare = plist;
2271 while (!NILP (*tortoise))
2273 Lisp_Object *tortsave = tortoise;
2277 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2280 if (!laxp ? EQ (XCAR (*tortsave), property)
2281 : internal_equal (XCAR (*tortsave), property, 0))
2283 /* Now you see why it's so convenient to have that level
2285 *tortsave = XCDR (XCDR (*tortsave));
2293 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2294 Extract a value from a property list.
2295 PLIST is a property list, which is a list of the form
2296 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2297 corresponding to the given PROP, or DEFAULT if PROP is not
2298 one of the properties on the list.
2300 (plist, prop, default_))
2302 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2303 return UNBOUNDP (val) ? default_ : val;
2306 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2307 Change value in PLIST of PROP to VAL.
2308 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2309 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2310 If PROP is already a property on the list, its value is set to VAL,
2311 otherwise the new PROP VAL pair is added. The new plist is returned;
2312 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2313 The PLIST is modified by side effects.
2317 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2321 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2322 Remove from PLIST the property PROP and its value.
2323 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2324 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2325 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2326 the new value. The PLIST is modified by side effects.
2330 external_remprop (&plist, prop, 0, ERROR_ME);
2334 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2335 Return t if PROP has a value specified in PLIST.
2339 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2340 return UNBOUNDP (val) ? Qnil : Qt;
2343 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2344 Given a plist, signal an error if there is anything wrong with it.
2345 This means that it's a malformed or circular plist.
2349 Lisp_Object *tortoise;
2355 while (!NILP (*tortoise))
2360 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2368 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2369 Given a plist, return non-nil if its format is correct.
2370 If it returns nil, `check-valid-plist' will signal an error when given
2371 the plist; that means it's a malformed or circular plist or has non-symbols
2376 Lisp_Object *tortoise;
2381 while (!NILP (*tortoise))
2386 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2394 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2395 Destructively remove any duplicate entries from a plist.
2396 In such cases, the first entry applies.
2398 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2399 a nil value is removed. This feature is a virus that has infected
2400 old Lisp implementations, but should not be used except for backward
2403 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2404 return value may not be EQ to the passed-in value, so make sure to
2405 `setq' the value back into where it came from.
2407 (plist, nil_means_not_present))
2409 Lisp_Object head = plist;
2411 Fcheck_valid_plist (plist);
2413 while (!NILP (plist))
2415 Lisp_Object prop = Fcar (plist);
2416 Lisp_Object next = Fcdr (plist);
2418 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2419 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2421 if (EQ (head, plist))
2423 plist = Fcdr (next);
2426 /* external_remprop returns 1 if it removed any property.
2427 We have to loop till it didn't remove anything, in case
2428 the property occurs many times. */
2429 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2431 plist = Fcdr (next);
2437 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2438 Extract a value from a lax property list.
2440 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2441 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2442 using `equal' instead of `eq'. This function returns the value
2443 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2444 properties on the list.
2446 (lax_plist, prop, default_))
2448 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2454 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2455 Change value in LAX-PLIST of PROP to VAL.
2456 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2457 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2458 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2459 any object. If PROP is already a property on the list, its value is
2460 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2461 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2462 use the new value. The LAX-PLIST is modified by side effects.
2464 (lax_plist, prop, val))
2466 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2470 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2471 Remove from LAX-PLIST the property PROP and its value.
2472 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2473 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2474 using `equal' instead of `eq'. PROP is usually a symbol. The new
2475 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2476 sure to use the new value. The LAX-PLIST is modified by side effects.
2480 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2484 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2485 Return t if PROP has a value specified in LAX-PLIST.
2486 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2487 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2488 using `equal' instead of `eq'.
2492 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2495 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2496 Destructively remove any duplicate entries from a lax plist.
2497 In such cases, the first entry applies.
2499 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2500 a nil value is removed. This feature is a virus that has infected
2501 old Lisp implementations, but should not be used except for backward
2504 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2505 return value may not be EQ to the passed-in value, so make sure to
2506 `setq' the value back into where it came from.
2508 (lax_plist, nil_means_not_present))
2510 Lisp_Object head = lax_plist;
2512 Fcheck_valid_plist (lax_plist);
2514 while (!NILP (lax_plist))
2516 Lisp_Object prop = Fcar (lax_plist);
2517 Lisp_Object next = Fcdr (lax_plist);
2519 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2520 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2522 if (EQ (head, lax_plist))
2524 lax_plist = Fcdr (next);
2527 /* external_remprop returns 1 if it removed any property.
2528 We have to loop till it didn't remove anything, in case
2529 the property occurs many times. */
2530 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2532 lax_plist = Fcdr (next);
2538 /* In C because the frame props stuff uses it */
2540 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2541 Convert association list ALIST into the equivalent property-list form.
2542 The plist is returned. This converts from
2544 \((a . 1) (b . 2) (c . 3))
2550 The original alist is destroyed in the process of constructing the plist.
2551 See also `alist-to-plist'.
2555 Lisp_Object head = alist;
2556 while (!NILP (alist))
2558 /* remember the alist element. */
2559 Lisp_Object el = Fcar (alist);
2561 Fsetcar (alist, Fcar (el));
2562 Fsetcar (el, Fcdr (el));
2563 Fsetcdr (el, Fcdr (alist));
2564 Fsetcdr (alist, el);
2565 alist = Fcdr (Fcdr (alist));
2571 /* Symbol plists are directly accessible, so we need to protect against
2572 invalid property list structure */
2575 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2577 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2579 return UNBOUNDP (val) ? default_ : val;
2583 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2585 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2589 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2591 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2594 /* We store the string's extent info as the first element of the string's
2595 property list; and the string's MODIFF as the first or second element
2596 of the string's property list (depending on whether the extent info
2597 is present), but only if the string has been modified. This is ugly
2598 but it reduces the memory allocated for the string in the vast
2599 majority of cases, where the string is never modified and has no
2603 static Lisp_Object *
2604 string_plist_ptr (struct Lisp_String *s)
2606 Lisp_Object *ptr = &s->plist;
2608 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2610 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2616 string_getprop (struct Lisp_String *s, Lisp_Object property,
2617 Lisp_Object default_)
2619 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2621 return UNBOUNDP (val) ? default_ : val;
2625 string_putprop (struct Lisp_String *s, Lisp_Object property,
2628 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2632 string_remprop (struct Lisp_String *s, Lisp_Object property)
2634 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2638 string_plist (struct Lisp_String *s)
2640 return *string_plist_ptr (s);
2643 DEFUN ("get", Fget, 2, 3, 0, /*
2644 Return the value of OBJECT's PROPNAME property.
2645 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
2646 If there is no such property, return optional third arg DEFAULT
2647 \(which defaults to `nil'). OBJECT can be a symbol, face, extent,
2648 or string. See also `put', `remprop', and `object-plist'.
2650 (object, propname, default_))
2652 /* Various places in emacs call Fget() and expect it not to quit,
2655 /* It's easiest to treat symbols specially because they may not
2657 if (SYMBOLP (object))
2658 return symbol_getprop (object, propname, default_);
2659 else if (STRINGP (object))
2660 return string_getprop (XSTRING (object), propname, default_);
2661 else if (LRECORDP (object))
2663 CONST struct lrecord_implementation *imp
2664 = XRECORD_LHEADER_IMPLEMENTATION (object);
2669 Lisp_Object val = (imp->getprop) (object, propname);
2678 signal_simple_error ("Object type has no properties", object);
2679 return Qnil; /* Not reached */
2683 DEFUN ("put", Fput, 3, 3, 0, /*
2684 Store OBJECT's PROPNAME property with value VALUE.
2685 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
2686 symbol, face, extent, or string.
2688 For a string, no properties currently have predefined meanings.
2689 For the predefined properties for extents, see `set-extent-property'.
2690 For the predefined properties for faces, see `set-face-property'.
2692 See also `get', `remprop', and `object-plist'.
2694 (object, propname, value))
2696 CHECK_SYMBOL (propname);
2697 CHECK_LISP_WRITEABLE (object);
2699 if (SYMBOLP (object))
2700 symbol_putprop (object, propname, value);
2701 else if (STRINGP (object))
2702 string_putprop (XSTRING (object), propname, value);
2703 else if (LRECORDP (object))
2705 CONST struct lrecord_implementation
2706 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2709 if (! (imp->putprop) (object, propname, value))
2710 signal_simple_error ("Can't set property on object", propname);
2718 signal_simple_error ("Object type has no settable properties", object);
2724 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2725 Remove from OBJECT's property list the property PROPNAME and its
2726 value. OBJECT can be a symbol, face, extent, or string. Returns
2727 non-nil if the property list was actually changed (i.e. if PROPNAME
2728 was present in the property list). See also `get', `put', and
2735 CHECK_SYMBOL (propname);
2736 CHECK_LISP_WRITEABLE (object);
2738 if (SYMBOLP (object))
2739 retval = symbol_remprop (object, propname);
2740 else if (STRINGP (object))
2741 retval = string_remprop (XSTRING (object), propname);
2742 else if (LRECORDP (object))
2744 CONST struct lrecord_implementation
2745 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2748 retval = (imp->remprop) (object, propname);
2750 signal_simple_error ("Can't remove property from object",
2759 signal_simple_error ("Object type has no removable properties", object);
2762 return retval ? Qt : Qnil;
2765 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2766 Return a property list of OBJECT's props.
2767 For a symbol this is equivalent to `symbol-plist'.
2768 Do not modify the property list directly; this may or may not have
2769 the desired effects. (In particular, for a property with a special
2770 interpretation, this will probably have no effect at all.)
2774 if (SYMBOLP (object))
2775 return Fsymbol_plist (object);
2776 else if (STRINGP (object))
2777 return string_plist (XSTRING (object));
2778 else if (LRECORDP (object))
2780 CONST struct lrecord_implementation
2781 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2783 return (imp->plist) (object);
2785 signal_simple_error ("Object type has no properties", object);
2788 signal_simple_error ("Object type has no properties", object);
2795 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2798 error ("Stack overflow in equal");
2800 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2802 /* Note that (equal 20 20.0) should be nil */
2803 if (XTYPE (obj1) != XTYPE (obj2))
2805 if (LRECORDP (obj1))
2807 CONST struct lrecord_implementation
2808 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2809 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2811 return (imp1 == imp2) &&
2812 /* EQ-ness of the objects was noticed above */
2813 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2819 /* Note that we may be calling sub-objects that will use
2820 internal_equal() (instead of internal_old_equal()). Oh well.
2821 We will get an Ebola note if there's any possibility of confusion,
2822 but that seems unlikely. */
2825 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2828 error ("Stack overflow in equal");
2830 if (HACKEQ_UNSAFE (obj1, obj2))
2832 /* Note that (equal 20 20.0) should be nil */
2833 if (XTYPE (obj1) != XTYPE (obj2))
2836 return internal_equal (obj1, obj2, depth);
2839 DEFUN ("equal", Fequal, 2, 2, 0, /*
2840 Return t if two Lisp objects have similar structure and contents.
2841 They must have the same data type.
2842 Conses are compared by comparing the cars and the cdrs.
2843 Vectors and strings are compared element by element.
2844 Numbers are compared by value. Symbols must match exactly.
2848 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2851 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2852 Return t if two Lisp objects have similar structure and contents.
2853 They must have the same data type.
2854 \(Note, however, that an exception is made for characters and integers;
2855 this is known as the "char-int confoundance disease." See `eq' and
2857 This function is provided only for byte-code compatibility with v19.
2862 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2866 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2867 Destructively modify ARRAY by replacing each element with ITEM.
2868 ARRAY is a vector, bit vector, or string.
2873 if (STRINGP (array))
2875 struct Lisp_String *s = XSTRING (array);
2876 Bytecount old_bytecount = string_length (s);
2877 Bytecount new_bytecount;
2878 Bytecount item_bytecount;
2879 Bufbyte item_buf[MAX_EMCHAR_LEN];
2883 CHECK_CHAR_COERCE_INT (item);
2884 CHECK_LISP_WRITEABLE (array);
2886 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2887 new_bytecount = item_bytecount * string_char_length (s);
2889 resize_string (s, -1, new_bytecount - old_bytecount);
2891 for (p = string_data (s), end = p + new_bytecount;
2893 p += item_bytecount)
2894 memcpy (p, item_buf, item_bytecount);
2897 bump_string_modiff (array);
2899 else if (VECTORP (array))
2901 Lisp_Object *p = XVECTOR_DATA (array);
2902 int len = XVECTOR_LENGTH (array);
2903 CHECK_LISP_WRITEABLE (array);
2907 else if (BIT_VECTORP (array))
2909 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2910 int len = bit_vector_length (v);
2913 CHECK_LISP_WRITEABLE (array);
2916 set_bit_vector_bit (v, len, bit);
2920 array = wrong_type_argument (Qarrayp, array);
2927 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2929 Lisp_Object args[2];
2930 struct gcpro gcpro1;
2937 RETURN_UNGCPRO (bytecode_nconc2 (args));
2941 bytecode_nconc2 (Lisp_Object *args)
2945 if (CONSP (args[0]))
2947 /* (setcdr (last args[0]) args[1]) */
2948 Lisp_Object tortoise, hare;
2951 for (hare = tortoise = args[0], count = 0;
2952 CONSP (XCDR (hare));
2953 hare = XCDR (hare), count++)
2955 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2958 tortoise = XCDR (tortoise);
2959 if (EQ (hare, tortoise))
2960 signal_circular_list_error (args[0]);
2962 XCDR (hare) = args[1];
2965 else if (NILP (args[0]))
2971 args[0] = wrong_type_argument (args[0], Qlistp);
2976 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2977 Concatenate any number of lists by altering them.
2978 Only the last argument is not altered, and need not be a list.
2980 If the first argument is nil, there is no way to modify it by side
2981 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2982 changing the value of `foo'.
2984 (int nargs, Lisp_Object *args))
2987 struct gcpro gcpro1;
2989 /* The modus operandi in Emacs is "caller gc-protects args".
2990 However, nconc (particularly nconc2 ()) is called many times
2991 in Emacs on freshly created stuff (e.g. you see the idiom
2992 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2993 callers out by protecting the args ourselves to save them
2994 a lot of temporary-variable grief. */
2997 gcpro1.nvars = nargs;
2999 while (argnum < nargs)
3006 /* `val' is the first cons, which will be our return value. */
3007 /* `last_cons' will be the cons cell to mutate. */
3008 Lisp_Object last_cons = val;
3009 Lisp_Object tortoise = val;
3011 for (argnum++; argnum < nargs; argnum++)
3013 Lisp_Object next = args[argnum];
3015 if (CONSP (next) || argnum == nargs -1)
3017 /* (setcdr (last val) next) */
3021 CONSP (XCDR (last_cons));
3022 last_cons = XCDR (last_cons), count++)
3024 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3027 tortoise = XCDR (tortoise);
3028 if (EQ (last_cons, tortoise))
3029 signal_circular_list_error (args[argnum-1]);
3031 XCDR (last_cons) = next;
3033 else if (NILP (next))
3039 next = wrong_type_argument (Qlistp, next);
3043 RETURN_UNGCPRO (val);
3045 else if (NILP (val))
3047 else if (argnum == nargs - 1) /* last arg? */
3048 RETURN_UNGCPRO (val);
3051 args[argnum] = wrong_type_argument (Qlistp, val);
3055 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3059 /* This is the guts of several mapping functions.
3060 Apply FUNCTION to each element of SEQUENCE, one by one,
3061 storing the results into elements of VALS, a C vector of Lisp_Objects.
3062 LENI is the length of VALS, which should also be the length of SEQUENCE.
3064 If VALS is a null pointer, do not accumulate the results. */
3067 mapcar1 (size_t leni, Lisp_Object *vals,
3068 Lisp_Object function, Lisp_Object sequence)
3071 Lisp_Object args[2];
3073 struct gcpro gcpro1;
3083 if (LISTP (sequence))
3085 /* A devious `function' could either:
3086 - insert garbage into the list in front of us, causing XCDR to crash
3087 - amputate the list behind us using (setcdr), causing the remaining
3088 elts to lose their GCPRO status.
3090 if (vals != 0) we avoid this by copying the elts into the
3091 `vals' array. By a stroke of luck, `vals' is exactly large
3092 enough to hold the elts left to be traversed as well as the
3093 results computed so far.
3095 if (vals == 0) we don't have any free space available and
3096 don't want to eat up any more stack with alloca().
3097 So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
3101 Lisp_Object *val = vals;
3104 LIST_LOOP_2 (elt, sequence)
3107 gcpro1.nvars = leni;
3109 for (i = 0; i < leni; i++)
3112 vals[i] = Ffuncall (2, args);
3117 Lisp_Object elt, tail;
3118 struct gcpro ngcpro1;
3123 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
3133 else if (VECTORP (sequence))
3135 Lisp_Object *objs = XVECTOR_DATA (sequence);
3136 for (i = 0; i < leni; i++)
3139 result = Ffuncall (2, args);
3140 if (vals) vals[gcpro1.nvars++] = result;
3143 else if (STRINGP (sequence))
3145 /* The string data of `sequence' might be relocated during GC. */
3146 Bytecount slen = XSTRING_LENGTH (sequence);
3147 Bufbyte *p = alloca_array (Bufbyte, slen);
3148 Bufbyte *end = p + slen;
3150 memcpy (p, XSTRING_DATA (sequence), slen);
3154 args[1] = make_char (charptr_emchar (p));
3156 result = Ffuncall (2, args);
3157 if (vals) vals[gcpro1.nvars++] = result;
3160 else if (BIT_VECTORP (sequence))
3162 struct Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3163 for (i = 0; i < leni; i++)
3165 args[1] = make_int (bit_vector_bit (v, i));
3166 result = Ffuncall (2, args);
3167 if (vals) vals[gcpro1.nvars++] = result;
3171 abort(); /* cannot get here since Flength(sequence) did not get an error */
3177 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3178 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3179 In between each pair of results, insert SEPARATOR. Thus, using " " as
3180 SEPARATOR results in spaces between the values returned by FUNCTION.
3181 SEQUENCE may be a list, a vector, a bit vector, or a string.
3183 (function, sequence, separator))
3185 size_t len = XINT (Flength (sequence));
3188 struct gcpro gcpro1;
3189 int nargs = len + len - 1;
3191 if (nargs < 0) return build_string ("");
3193 args = alloca_array (Lisp_Object, nargs);
3196 mapcar1 (len, args, function, sequence);
3199 for (i = len - 1; i >= 0; i--)
3200 args[i + i] = args[i];
3202 for (i = 1; i < nargs; i += 2)
3203 args[i] = separator;
3205 return Fconcat (nargs, args);
3208 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3209 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3210 The result is a list of the same length as SEQUENCE.
3211 SEQUENCE may be a list, a vector, a bit vector, or a string.
3213 (function, sequence))
3215 size_t len = XINT (Flength (sequence));
3216 Lisp_Object *args = alloca_array (Lisp_Object, len);
3218 mapcar1 (len, args, function, sequence);
3220 return Flist (len, args);
3223 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3224 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3225 The result is a vector of the same length as SEQUENCE.
3226 SEQUENCE may be a list, a vector, a bit vector, or a string.
3228 (function, sequence))
3230 size_t len = XINT (Flength (sequence));
3231 Lisp_Object result = make_vector (len, Qnil);
3232 struct gcpro gcpro1;
3235 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3241 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3242 Apply FUNCTION to each element of SEQUENCE.
3243 SEQUENCE may be a list, a vector, a bit vector, or a string.
3244 This function is like `mapcar' but does not accumulate the results,
3245 which is more efficient if you do not use the results.
3247 The difference between this and `mapc' is that `mapc' supports all
3248 the spiffy Common Lisp arguments. You should normally use `mapc'.
3250 (function, sequence))
3252 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3258 /* #### this function doesn't belong in this file! */
3260 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3261 Return list of 1 minute, 5 minute and 15 minute load averages.
3262 Each of the three load averages is multiplied by 100,
3263 then converted to integer.
3265 When USE-FLOATS is non-nil, floats will be used instead of integers.
3266 These floats are not multiplied by 100.
3268 If the 5-minute or 15-minute load averages are not available, return a
3269 shortened list, containing only those averages which are available.
3271 On some systems, this won't work due to permissions on /dev/kmem,
3272 in which case you can't use this.
3277 int loads = getloadavg (load_ave, countof (load_ave));
3278 Lisp_Object ret = Qnil;
3281 error ("load-average not implemented for this operating system");
3283 signal_simple_error ("Could not get load-average",
3284 lisp_strerror (errno));
3288 Lisp_Object load = (NILP (use_floats) ?
3289 make_int ((int) (100.0 * load_ave[loads]))
3290 : make_float (load_ave[loads]));
3291 ret = Fcons (load, ret);
3297 Lisp_Object Vfeatures;
3299 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3300 Return non-nil if feature FEXP is present in this Emacs.
3301 Use this to conditionalize execution of lisp code based on the
3302 presence or absence of emacs or environment extensions.
3303 FEXP can be a symbol, a number, or a list.
3304 If it is a symbol, that symbol is looked up in the `features' variable,
3305 and non-nil will be returned if found.
3306 If it is a number, the function will return non-nil if this Emacs
3307 has an equal or greater version number than FEXP.
3308 If it is a list whose car is the symbol `and', it will return
3309 non-nil if all the features in its cdr are non-nil.
3310 If it is a list whose car is the symbol `or', it will return non-nil
3311 if any of the features in its cdr are non-nil.
3312 If it is a list whose car is the symbol `not', it will return
3313 non-nil if the feature is not present.
3318 => ; Non-nil on XEmacs.
3320 (featurep '(and xemacs gnus))
3321 => ; Non-nil on XEmacs with Gnus loaded.
3323 (featurep '(or tty-frames (and emacs 19.30)))
3324 => ; Non-nil if this Emacs supports TTY frames.
3326 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3327 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3329 NOTE: The advanced arguments of this function (anything other than a
3330 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3331 for supporting multiple Emacs variants, lobby Richard Stallman at
3332 <bug-gnu-emacs@prep.ai.mit.edu>.
3336 #ifndef FEATUREP_SYNTAX
3337 CHECK_SYMBOL (fexp);
3338 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3339 #else /* FEATUREP_SYNTAX */
3340 static double featurep_emacs_version;
3342 /* Brute force translation from Erik Naggum's lisp function. */
3345 /* Original definition */
3346 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3348 else if (INTP (fexp) || FLOATP (fexp))
3350 double d = extract_float (fexp);
3352 if (featurep_emacs_version == 0.0)
3354 featurep_emacs_version = XINT (Vemacs_major_version) +
3355 (XINT (Vemacs_minor_version) / 100.0);
3357 return featurep_emacs_version >= d ? Qt : Qnil;
3359 else if (CONSP (fexp))
3361 Lisp_Object tem = XCAR (fexp);
3367 negate = Fcar (tem);
3369 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3371 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3373 else if (EQ (tem, Qand))
3376 /* Use Fcar/Fcdr for error-checking. */
3377 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3381 return NILP (tem) ? Qt : Qnil;
3383 else if (EQ (tem, Qor))
3386 /* Use Fcar/Fcdr for error-checking. */
3387 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3391 return NILP (tem) ? Qnil : Qt;
3395 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3400 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3403 #endif /* FEATUREP_SYNTAX */
3405 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3406 Announce that FEATURE is a feature of the current Emacs.
3407 This function updates the value of the variable `features'.
3412 CHECK_SYMBOL (feature);
3413 if (!NILP (Vautoload_queue))
3414 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3415 tem = Fmemq (feature, Vfeatures);
3417 Vfeatures = Fcons (feature, Vfeatures);
3418 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3422 DEFUN ("require", Frequire, 1, 2, 0, /*
3423 If feature FEATURE is not loaded, load it from FILENAME.
3424 If FEATURE is not a member of the list `features', then the feature
3425 is not loaded; so load the file FILENAME.
3426 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3428 (feature, file_name))
3431 CHECK_SYMBOL (feature);
3432 tem = Fmemq (feature, Vfeatures);
3433 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3438 int speccount = specpdl_depth ();
3440 /* Value saved here is to be restored into Vautoload_queue */
3441 record_unwind_protect (un_autoload, Vautoload_queue);
3442 Vautoload_queue = Qt;
3444 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3447 tem = Fmemq (feature, Vfeatures);
3449 error ("Required feature %s was not provided",
3450 string_data (XSYMBOL (feature)->name));
3452 /* Once loading finishes, don't undo it. */
3453 Vautoload_queue = Qt;
3454 return unbind_to (speccount, feature);
3458 /* base64 encode/decode functions.
3460 Originally based on code from GNU recode. Ported to FSF Emacs by
3461 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3462 subsequently heavily hacked by Hrvoje Niksic. */
3464 #define MIME_LINE_LENGTH 72
3466 #define IS_ASCII(Character) \
3468 #define IS_BASE64(Character) \
3469 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3471 /* Table of characters coding the 64 values. */
3472 static char base64_value_to_char[64] =
3474 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3475 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3476 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3477 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3478 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3479 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3480 '8', '9', '+', '/' /* 60-63 */
3483 /* Table of base64 values for first 128 characters. */
3484 static short base64_char_to_value[128] =
3486 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3487 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3488 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3489 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3490 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3491 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3492 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3493 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3494 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3495 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3496 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3497 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3498 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3501 /* The following diagram shows the logical steps by which three octets
3502 get transformed into four base64 characters.
3504 .--------. .--------. .--------.
3505 |aaaaaabb| |bbbbcccc| |ccdddddd|
3506 `--------' `--------' `--------'
3508 .--------+--------+--------+--------.
3509 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3510 `--------+--------+--------+--------'
3512 .--------+--------+--------+--------.
3513 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3514 `--------+--------+--------+--------'
3516 The octets are divided into 6 bit chunks, which are then encoded into
3517 base64 characters. */
3519 #define ADVANCE_INPUT(c, stream) \
3520 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3522 (signal_simple_error ("Non-ascii character in base64 input", \
3523 make_char (ec)), 0) \
3524 : (c = (Bufbyte)ec), 1))
3527 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3529 EMACS_INT counter = 0;
3537 if (!ADVANCE_INPUT (c, istream))
3540 /* Wrap line every 76 characters. */
3543 if (counter < MIME_LINE_LENGTH / 4)
3552 /* Process first byte of a triplet. */
3553 *e++ = base64_value_to_char[0x3f & c >> 2];
3554 value = (0x03 & c) << 4;
3556 /* Process second byte of a triplet. */
3557 if (!ADVANCE_INPUT (c, istream))
3559 *e++ = base64_value_to_char[value];
3565 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3566 value = (0x0f & c) << 2;
3568 /* Process third byte of a triplet. */
3569 if (!ADVANCE_INPUT (c, istream))
3571 *e++ = base64_value_to_char[value];
3576 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3577 *e++ = base64_value_to_char[0x3f & c];
3582 #undef ADVANCE_INPUT
3584 /* Get next character from the stream, except that non-base64
3585 characters are ignored. This is in accordance with rfc2045. EC
3586 should be an Emchar, so that it can hold -1 as the value for EOF. */
3587 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3588 ec = Lstream_get_emchar (stream); \
3590 /* IS_BASE64 may not be called with negative arguments so check for \
3592 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3596 #define STORE_BYTE(pos, val, ccnt) do { \
3597 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3602 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3606 EMACS_INT streampos = 0;
3611 unsigned long value;
3613 /* Process first byte of a quadruplet. */
3614 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3618 signal_simple_error ("Illegal `=' character while decoding base64",
3619 make_int (streampos));
3620 value = base64_char_to_value[ec] << 18;
3622 /* Process second byte of a quadruplet. */
3623 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3625 error ("Premature EOF while decoding base64");
3627 signal_simple_error ("Illegal `=' character while decoding base64",
3628 make_int (streampos));
3629 value |= base64_char_to_value[ec] << 12;
3630 STORE_BYTE (e, value >> 16, ccnt);
3632 /* Process third byte of a quadruplet. */
3633 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3635 error ("Premature EOF while decoding base64");
3639 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3641 error ("Premature EOF while decoding base64");
3643 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3644 make_int (streampos));
3648 value |= base64_char_to_value[ec] << 6;
3649 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3651 /* Process fourth byte of a quadruplet. */
3652 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3654 error ("Premature EOF while decoding base64");
3658 value |= base64_char_to_value[ec];
3659 STORE_BYTE (e, 0xff & value, ccnt);
3665 #undef ADVANCE_INPUT
3666 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3670 free_malloced_ptr (Lisp_Object unwind_obj)
3672 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3674 free_opaque_ptr (unwind_obj);
3678 /* Don't use alloca for regions larger than this, lest we overflow
3680 #define MAX_ALLOCA 65536
3682 /* We need to setup proper unwinding, because there is a number of
3683 ways these functions can blow up, and we don't want to have memory
3684 leaks in those cases. */
3685 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3686 size_t XOA_len = (len); \
3687 if (XOA_len > MAX_ALLOCA) \
3689 ptr = xnew_array (type, XOA_len); \
3690 record_unwind_protect (free_malloced_ptr, \
3691 make_opaque_ptr ((void *)ptr)); \
3694 ptr = alloca_array (type, XOA_len); \
3697 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3698 if ((len) > MAX_ALLOCA) \
3699 unbind_to (speccount, Qnil); \
3702 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3703 Base64-encode the region between BEG and END.
3704 Return the length of the encoded text.
3705 Optional third argument NO-LINE-BREAK means do not break long lines
3708 (beg, end, no_line_break))
3711 Bytind encoded_length;
3712 Charcount allength, length;
3713 struct buffer *buf = current_buffer;
3714 Bufpos begv, zv, old_pt = BUF_PT (buf);
3716 int speccount = specpdl_depth();
3718 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3719 barf_if_buffer_read_only (buf, begv, zv);
3721 /* We need to allocate enough room for encoding the text.
3722 We need 33 1/3% more space, plus a newline every 76
3723 characters, and then we round up. */
3725 allength = length + length/3 + 1;
3726 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3728 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3729 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3730 base64 characters will be single-byte. */
3731 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3732 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3733 NILP (no_line_break));
3734 if (encoded_length > allength)
3736 Lstream_delete (XLSTREAM (input));
3738 /* Now we have encoded the region, so we insert the new contents
3739 and delete the old. (Insert first in order to preserve markers.) */
3740 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3741 XMALLOC_UNBIND (encoded, allength, speccount);
3742 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3744 /* Simulate FSF Emacs implementation of this function: if point was
3745 in the region, place it at the beginning. */
3746 if (old_pt >= begv && old_pt < zv)
3747 BUF_SET_PT (buf, begv);
3749 /* We return the length of the encoded text. */
3750 return make_int (encoded_length);
3753 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3754 Base64 encode STRING and return the result.
3756 (string, no_line_break))
3758 Charcount allength, length;
3759 Bytind encoded_length;
3761 Lisp_Object input, result;
3762 int speccount = specpdl_depth();
3764 CHECK_STRING (string);
3766 length = XSTRING_CHAR_LENGTH (string);
3767 allength = length + length/3 + 1;
3768 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3770 input = make_lisp_string_input_stream (string, 0, -1);
3771 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3772 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3773 NILP (no_line_break));
3774 if (encoded_length > allength)
3776 Lstream_delete (XLSTREAM (input));
3777 result = make_string (encoded, encoded_length);
3778 XMALLOC_UNBIND (encoded, allength, speccount);
3782 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3783 Base64-decode the region between BEG and END.
3784 Return the length of the decoded text.
3785 If the region can't be decoded, return nil and don't modify the buffer.
3786 Characters out of the base64 alphabet are ignored.
3790 struct buffer *buf = current_buffer;
3791 Bufpos begv, zv, old_pt = BUF_PT (buf);
3793 Bytind decoded_length;
3794 Charcount length, cc_decoded_length;
3796 int speccount = specpdl_depth();
3798 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3799 barf_if_buffer_read_only (buf, begv, zv);
3803 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3804 /* We need to allocate enough room for decoding the text. */
3805 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3806 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3807 if (decoded_length > length * MAX_EMCHAR_LEN)
3809 Lstream_delete (XLSTREAM (input));
3811 /* Now we have decoded the region, so we insert the new contents
3812 and delete the old. (Insert first in order to preserve markers.) */
3813 BUF_SET_PT (buf, begv);
3814 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3815 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3816 buffer_delete_range (buf, begv + cc_decoded_length,
3817 zv + cc_decoded_length, 0);
3819 /* Simulate FSF Emacs implementation of this function: if point was
3820 in the region, place it at the beginning. */
3821 if (old_pt >= begv && old_pt < zv)
3822 BUF_SET_PT (buf, begv);
3824 return make_int (cc_decoded_length);
3827 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3828 Base64-decode STRING and return the result.
3829 Characters out of the base64 alphabet are ignored.
3834 Bytind decoded_length;
3835 Charcount length, cc_decoded_length;
3836 Lisp_Object input, result;
3837 int speccount = specpdl_depth();
3839 CHECK_STRING (string);
3841 length = XSTRING_CHAR_LENGTH (string);
3842 /* We need to allocate enough room for decoding the text. */
3843 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3845 input = make_lisp_string_input_stream (string, 0, -1);
3846 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3847 &cc_decoded_length);
3848 if (decoded_length > length * MAX_EMCHAR_LEN)
3850 Lstream_delete (XLSTREAM (input));
3852 result = make_string (decoded, decoded_length);
3853 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3857 Lisp_Object Qyes_or_no_p;
3862 defsymbol (&Qstring_lessp, "string-lessp");
3863 defsymbol (&Qidentity, "identity");
3864 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3866 DEFSUBR (Fidentity);
3869 DEFSUBR (Fsafe_length);
3870 DEFSUBR (Fstring_equal);
3871 DEFSUBR (Fstring_lessp);
3872 DEFSUBR (Fstring_modified_tick);
3876 DEFSUBR (Fbvconcat);
3877 DEFSUBR (Fcopy_list);
3878 DEFSUBR (Fcopy_sequence);
3879 DEFSUBR (Fcopy_alist);
3880 DEFSUBR (Fcopy_tree);
3881 DEFSUBR (Fsubstring);
3888 DEFSUBR (Fnbutlast);
3890 DEFSUBR (Fold_member);
3892 DEFSUBR (Fold_memq);
3894 DEFSUBR (Fold_assoc);
3896 DEFSUBR (Fold_assq);
3898 DEFSUBR (Fold_rassoc);
3900 DEFSUBR (Fold_rassq);
3902 DEFSUBR (Fold_delete);
3904 DEFSUBR (Fold_delq);
3905 DEFSUBR (Fremassoc);
3907 DEFSUBR (Fremrassoc);
3908 DEFSUBR (Fremrassq);
3909 DEFSUBR (Fnreverse);
3912 DEFSUBR (Fplists_eq);
3913 DEFSUBR (Fplists_equal);
3914 DEFSUBR (Flax_plists_eq);
3915 DEFSUBR (Flax_plists_equal);
3916 DEFSUBR (Fplist_get);
3917 DEFSUBR (Fplist_put);
3918 DEFSUBR (Fplist_remprop);
3919 DEFSUBR (Fplist_member);
3920 DEFSUBR (Fcheck_valid_plist);
3921 DEFSUBR (Fvalid_plist_p);
3922 DEFSUBR (Fcanonicalize_plist);
3923 DEFSUBR (Flax_plist_get);
3924 DEFSUBR (Flax_plist_put);
3925 DEFSUBR (Flax_plist_remprop);
3926 DEFSUBR (Flax_plist_member);
3927 DEFSUBR (Fcanonicalize_lax_plist);
3928 DEFSUBR (Fdestructive_alist_to_plist);
3932 DEFSUBR (Fobject_plist);
3934 DEFSUBR (Fold_equal);
3935 DEFSUBR (Ffillarray);
3938 DEFSUBR (Fmapvector);
3939 DEFSUBR (Fmapc_internal);
3940 DEFSUBR (Fmapconcat);
3941 DEFSUBR (Fload_average);
3942 DEFSUBR (Ffeaturep);
3945 DEFSUBR (Fbase64_encode_region);
3946 DEFSUBR (Fbase64_encode_string);
3947 DEFSUBR (Fbase64_decode_region);
3948 DEFSUBR (Fbase64_decode_string);
3952 init_provide_once (void)
3954 DEFVAR_LISP ("features", &Vfeatures /*
3955 A list of symbols which are the features of the executing emacs.
3956 Used by `featurep' and `require', and altered by `provide'.
3960 Fprovide (intern ("base64"));