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. */
52 /* NOTE: This symbol is also used in lread.c */
53 #define FEATUREP_SYNTAX
55 Lisp_Object Qstring_lessp;
56 Lisp_Object Qidentity;
58 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
61 mark_bit_vector (Lisp_Object obj)
67 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
70 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
71 size_t len = bit_vector_length (v);
74 if (INTP (Vprint_length))
75 last = min (len, XINT (Vprint_length));
76 write_c_string ("#*", printcharfun);
77 for (i = 0; i < last; i++)
79 if (bit_vector_bit (v, i))
80 write_c_string ("1", printcharfun);
82 write_c_string ("0", printcharfun);
86 write_c_string ("...", printcharfun);
90 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
92 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
93 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
95 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
96 !memcmp (v1->bits, v2->bits,
97 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
102 bit_vector_hash (Lisp_Object obj, int depth)
104 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
105 return HASH2 (bit_vector_length (v),
106 memory_hash (v->bits,
107 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
112 size_bit_vector (const void *lheader)
114 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
115 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
116 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
119 static const struct lrecord_description bit_vector_description[] = {
120 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
125 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
126 mark_bit_vector, print_bit_vector, 0,
127 bit_vector_equal, bit_vector_hash,
128 bit_vector_description, size_bit_vector,
131 DEFUN ("identity", Fidentity, 1, 1, 0, /*
132 Return the argument unchanged.
139 extern long get_random (void);
140 extern void seed_random (long arg);
142 DEFUN ("random", Frandom, 0, 1, 0, /*
143 Return a pseudo-random number.
144 All integers representable in Lisp are equally likely.
145 On most systems, this is 28 bits' worth.
146 With positive integer argument N, return random number in interval [0,N).
147 With argument t, set the random number seed from the current time and pid.
152 unsigned long denominator;
155 seed_random (getpid () + time (NULL));
156 if (NATNUMP (limit) && !ZEROP (limit))
158 /* Try to take our random number from the higher bits of VAL,
159 not the lower, since (says Gentzel) the low bits of `random'
160 are less random than the higher ones. We do this by using the
161 quotient rather than the remainder. At the high end of the RNG
162 it's possible to get a quotient larger than limit; discarding
163 these values eliminates the bias that would otherwise appear
164 when using a large limit. */
165 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
167 val = get_random () / denominator;
168 while (val >= XINT (limit));
173 return make_int (val);
176 /* Random data-structure functions */
178 #ifdef LOSING_BYTECODE
180 /* #### Delete this shit */
182 /* Charcount is a misnomer here as we might be dealing with the
183 length of a vector or list, but emphasizes that we're not dealing
184 with Bytecounts in strings */
186 length_with_bytecode_hack (Lisp_Object seq)
188 if (!COMPILED_FUNCTIONP (seq))
189 return XINT (Flength (seq));
192 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
194 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
195 f->flags.domainp ? COMPILED_DOMAIN :
201 #endif /* LOSING_BYTECODE */
204 check_losing_bytecode (const char *function, Lisp_Object seq)
206 if (COMPILED_FUNCTIONP (seq))
209 "As of 20.3, `%s' no longer works with compiled-function objects",
213 DEFUN ("length", Flength, 1, 1, 0, /*
214 Return the length of vector, bit vector, list or string SEQUENCE.
219 if (STRINGP (sequence))
220 return make_int (XSTRING_CHAR_LENGTH (sequence));
221 else if (CONSP (sequence))
224 GET_EXTERNAL_LIST_LENGTH (sequence, len);
225 return make_int (len);
227 else if (VECTORP (sequence))
228 return make_int (XVECTOR_LENGTH (sequence));
229 else if (NILP (sequence))
231 else if (BIT_VECTORP (sequence))
232 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
235 check_losing_bytecode ("length", sequence);
236 sequence = wrong_type_argument (Qsequencep, sequence);
241 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
242 Return the length of a list, but avoid error or infinite loop.
243 This function never gets an error. If LIST is not really a list,
244 it returns 0. If LIST is circular, it returns a finite value
245 which is at least the number of distinct elements.
249 Lisp_Object hare, tortoise;
252 for (hare = tortoise = list, len = 0;
253 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
254 hare = XCDR (hare), len++)
257 tortoise = XCDR (tortoise);
260 return make_int (len);
263 /*** string functions. ***/
265 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
266 Return t if two strings have identical contents.
267 Case is significant. Text properties are ignored.
268 \(Under XEmacs, `equal' also ignores text properties and extents in
269 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
270 `equal' is the same as in XEmacs, in that respect.)
271 Symbols are also allowed; their print names are used instead.
276 Lisp_String *p1, *p2;
278 if (SYMBOLP (string1))
279 p1 = XSYMBOL (string1)->name;
282 CHECK_STRING (string1);
283 p1 = XSTRING (string1);
286 if (SYMBOLP (string2))
287 p2 = XSYMBOL (string2)->name;
290 CHECK_STRING (string2);
291 p2 = XSTRING (string2);
294 return (((len = string_length (p1)) == string_length (p2)) &&
295 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
299 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
300 Return t if first arg string is less than second in lexicographic order.
301 If I18N2 support (but not Mule support) was compiled in, ordering is
302 determined by the locale. (Case is significant for the default C locale.)
303 In all other cases, comparison is simply done on a character-by-
304 character basis using the numeric value of a character. (Note that
305 this may not produce particularly meaningful results under Mule if
306 characters from different charsets are being compared.)
308 Symbols are also allowed; their print names are used instead.
310 The reason that the I18N2 locale-specific collation is not used under
311 Mule is that the locale model of internationalization does not handle
312 multiple charsets and thus has no hope of working properly under Mule.
313 What we really should do is create a collation table over all built-in
314 charsets. This is extremely difficult to do from scratch, however.
316 Unicode is a good first step towards solving this problem. In fact,
317 it is quite likely that a collation table exists (or will exist) for
318 Unicode. When Unicode support is added to XEmacs/Mule, this problem
323 Lisp_String *p1, *p2;
327 if (SYMBOLP (string1))
328 p1 = XSYMBOL (string1)->name;
331 CHECK_STRING (string1);
332 p1 = XSTRING (string1);
335 if (SYMBOLP (string2))
336 p2 = XSYMBOL (string2)->name;
339 CHECK_STRING (string2);
340 p2 = XSTRING (string2);
343 end = string_char_length (p1);
344 len2 = string_char_length (p2);
348 #if defined (I18N2) && !defined (MULE)
349 /* There is no hope of this working under Mule. Even if we converted
350 the data into an external format so that strcoll() processed it
351 properly, it would still not work because strcoll() does not
352 handle multiple locales. This is the fundamental flaw in the
355 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
356 /* Compare strings using collation order of locale. */
357 /* Need to be tricky to handle embedded nulls. */
359 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
361 int val = strcoll ((char *) string_data (p1) + i,
362 (char *) string_data (p2) + i);
369 #else /* not I18N2, or MULE */
371 Bufbyte *ptr1 = string_data (p1);
372 Bufbyte *ptr2 = string_data (p2);
374 /* #### It is not really necessary to do this: We could compare
375 byte-by-byte and still get a reasonable comparison, since this
376 would compare characters with a charset in the same way. With
377 a little rearrangement of the leading bytes, we could make most
378 inter-charset comparisons work out the same, too; even if some
379 don't, this is not a big deal because inter-charset comparisons
380 aren't really well-defined anyway. */
381 for (i = 0; i < end; i++)
383 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
384 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
389 #endif /* not I18N2, or MULE */
390 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
391 won't work right in I18N2 case */
392 return end < len2 ? Qt : Qnil;
395 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
396 Return STRING's tick counter, incremented for each change to the string.
397 Each string has a tick counter which is incremented each time the contents
398 of the string are changed (e.g. with `aset'). It wraps around occasionally.
404 CHECK_STRING (string);
405 s = XSTRING (string);
406 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
407 return XCAR (s->plist);
413 bump_string_modiff (Lisp_Object str)
415 Lisp_String *s = XSTRING (str);
416 Lisp_Object *ptr = &s->plist;
419 /* #### remove the `string-translatable' property from the string,
422 /* skip over extent info if it's there */
423 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
425 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
426 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
428 *ptr = Fcons (make_int (1), *ptr);
432 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
433 static Lisp_Object concat (int nargs, Lisp_Object *args,
434 enum concat_target_type target_type,
438 concat2 (Lisp_Object string1, Lisp_Object string2)
443 return concat (2, args, c_string, 0);
447 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
453 return concat (3, args, c_string, 0);
457 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
462 return concat (2, args, c_vector, 0);
466 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
472 return concat (3, args, c_vector, 0);
475 DEFUN ("append", Fappend, 0, MANY, 0, /*
476 Concatenate all the arguments and make the result a list.
477 The result is a list whose elements are the elements of all the arguments.
478 Each argument may be a list, vector, bit vector, or string.
479 The last argument is not copied, just used as the tail of the new list.
482 (int nargs, Lisp_Object *args))
484 return concat (nargs, args, c_cons, 1);
487 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
488 Concatenate all the arguments and make the result a string.
489 The result is a string whose elements are the elements of all the arguments.
490 Each argument may be a string or a list or vector of characters.
492 As of XEmacs 21.0, this function does NOT accept individual integers
493 as arguments. Old code that relies on, for example, (concat "foo" 50)
494 returning "foo50" will fail. To fix such code, either apply
495 `int-to-string' to the integer argument, or use `format'.
497 (int nargs, Lisp_Object *args))
499 return concat (nargs, args, c_string, 0);
502 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
503 Concatenate all the arguments and make the result a vector.
504 The result is a vector whose elements are the elements of all the arguments.
505 Each argument may be a list, vector, bit vector, or string.
507 (int nargs, Lisp_Object *args))
509 return concat (nargs, args, c_vector, 0);
512 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
513 Concatenate all the arguments and make the result a bit vector.
514 The result is a bit vector whose elements are the elements of all the
515 arguments. Each argument may be a list, vector, bit vector, or string.
517 (int nargs, Lisp_Object *args))
519 return concat (nargs, args, c_bit_vector, 0);
522 /* Copy a (possibly dotted) list. LIST must be a cons.
523 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
525 copy_list (Lisp_Object list)
527 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
528 Lisp_Object last = list_copy;
529 Lisp_Object hare, tortoise;
532 for (tortoise = hare = XCDR (list), len = 1;
534 hare = XCDR (hare), len++)
536 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
539 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
542 tortoise = XCDR (tortoise);
543 if (EQ (tortoise, hare))
544 signal_circular_list_error (list);
550 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
551 Return a copy of list LIST, which may be a dotted list.
552 The elements of LIST are not copied; they are shared
558 if (NILP (list)) return list;
559 if (CONSP (list)) return copy_list (list);
561 list = wrong_type_argument (Qlistp, list);
565 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
566 Return a copy of list, vector, bit vector or string SEQUENCE.
567 The elements of a list or vector are not copied; they are shared
568 with the original. SEQUENCE may be a dotted list.
573 if (NILP (sequence)) return sequence;
574 if (CONSP (sequence)) return copy_list (sequence);
575 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
576 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
577 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
579 check_losing_bytecode ("copy-sequence", sequence);
580 sequence = wrong_type_argument (Qsequencep, sequence);
584 struct merge_string_extents_struct
587 Bytecount entry_offset;
588 Bytecount entry_length;
592 concat (int nargs, Lisp_Object *args,
593 enum concat_target_type target_type,
597 Lisp_Object tail = Qnil;
600 Lisp_Object last_tail;
602 struct merge_string_extents_struct *args_mse = 0;
603 Bufbyte *string_result = 0;
604 Bufbyte *string_result_ptr = 0;
607 /* The modus operandi in Emacs is "caller gc-protects args".
608 However, concat is called many times in Emacs on freshly
609 created stuff. So we help those callers out by protecting
610 the args ourselves to save them a lot of temporary-variable
614 gcpro1.nvars = nargs;
617 /* #### if the result is a string and any of the strings have a string
618 for the `string-translatable' property, then concat should also
619 concat the args but use the `string-translatable' strings, and store
620 the result in the returned string's `string-translatable' property. */
622 if (target_type == c_string)
623 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
625 /* In append, the last arg isn't treated like the others */
626 if (last_special && nargs > 0)
629 last_tail = args[nargs];
634 /* Check and coerce the arguments. */
635 for (argnum = 0; argnum < nargs; argnum++)
637 Lisp_Object seq = args[argnum];
640 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
642 #ifdef LOSING_BYTECODE
643 else if (COMPILED_FUNCTIONP (seq))
644 /* Urk! We allow this, for "compatibility"... */
647 #if 0 /* removed for XEmacs 21 */
649 /* This is too revolting to think about but maintains
650 compatibility with FSF (and lots and lots of old code). */
651 args[argnum] = Fnumber_to_string (seq);
655 check_losing_bytecode ("concat", seq);
656 args[argnum] = wrong_type_argument (Qsequencep, seq);
662 args_mse[argnum].string = seq;
664 args_mse[argnum].string = Qnil;
669 /* Charcount is a misnomer here as we might be dealing with the
670 length of a vector or list, but emphasizes that we're not dealing
671 with Bytecounts in strings */
672 Charcount total_length;
674 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
676 #ifdef LOSING_BYTECODE
677 Charcount thislen = length_with_bytecode_hack (args[argnum]);
679 Charcount thislen = XINT (Flength (args[argnum]));
681 total_length += thislen;
687 if (total_length == 0)
688 /* In append, if all but last arg are nil, return last arg */
689 RETURN_UNGCPRO (last_tail);
690 val = Fmake_list (make_int (total_length), Qnil);
693 val = make_vector (total_length, Qnil);
696 val = make_bit_vector (total_length, Qzero);
699 /* We don't make the string yet because we don't know the
700 actual number of bytes. This loop was formerly written
701 to call Fmake_string() here and then call set_string_char()
702 for each char. This seems logical enough but is waaaaaaaay
703 slow -- set_string_char() has to scan the whole string up
704 to the place where the substitution is called for in order
705 to find the place to change, and may have to do some
706 realloc()ing in order to make the char fit properly.
709 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
710 string_result_ptr = string_result;
720 tail = val, toindex = -1; /* -1 in toindex is flag we are
727 for (argnum = 0; argnum < nargs; argnum++)
729 Charcount thisleni = 0;
730 Charcount thisindex = 0;
731 Lisp_Object seq = args[argnum];
732 Bufbyte *string_source_ptr = 0;
733 Bufbyte *string_prev_result_ptr = string_result_ptr;
737 #ifdef LOSING_BYTECODE
738 thisleni = length_with_bytecode_hack (seq);
740 thisleni = XINT (Flength (seq));
744 string_source_ptr = XSTRING_DATA (seq);
750 /* We've come to the end of this arg, so exit. */
754 /* Fetch next element of `seq' arg into `elt' */
762 if (thisindex >= thisleni)
767 elt = make_char (charptr_emchar (string_source_ptr));
768 INC_CHARPTR (string_source_ptr);
770 else if (VECTORP (seq))
771 elt = XVECTOR_DATA (seq)[thisindex];
772 else if (BIT_VECTORP (seq))
773 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
776 elt = Felt (seq, make_int (thisindex));
780 /* Store into result */
783 /* toindex negative means we are making a list */
788 else if (VECTORP (val))
789 XVECTOR_DATA (val)[toindex++] = elt;
790 else if (BIT_VECTORP (val))
793 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
797 CHECK_CHAR_COERCE_INT (elt);
798 string_result_ptr += set_charptr_emchar (string_result_ptr,
804 args_mse[argnum].entry_offset =
805 string_prev_result_ptr - string_result;
806 args_mse[argnum].entry_length =
807 string_result_ptr - string_prev_result_ptr;
811 /* Now we finally make the string. */
812 if (target_type == c_string)
814 val = make_string (string_result, string_result_ptr - string_result);
815 for (argnum = 0; argnum < nargs; argnum++)
817 if (STRINGP (args_mse[argnum].string))
818 copy_string_extents (val, args_mse[argnum].string,
819 args_mse[argnum].entry_offset, 0,
820 args_mse[argnum].entry_length);
825 XCDR (prev) = last_tail;
827 RETURN_UNGCPRO (val);
830 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
831 Return a copy of ALIST.
832 This is an alist which represents the same mapping from objects to objects,
833 but does not share the alist structure with ALIST.
834 The objects mapped (cars and cdrs of elements of the alist)
836 Elements of ALIST that are not conses are also shared.
846 alist = concat (1, &alist, c_cons, 0);
847 for (tail = alist; CONSP (tail); tail = XCDR (tail))
849 Lisp_Object car = XCAR (tail);
852 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
857 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
858 Return a copy of a list and substructures.
859 The argument is copied, and any lists contained within it are copied
860 recursively. Circularities and shared substructures are not preserved.
861 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
869 rest = arg = Fcopy_sequence (arg);
872 Lisp_Object elt = XCAR (rest);
874 if (CONSP (elt) || VECTORP (elt))
875 XCAR (rest) = Fcopy_tree (elt, vecp);
876 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
877 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
881 else if (VECTORP (arg) && ! NILP (vecp))
883 int i = XVECTOR_LENGTH (arg);
885 arg = Fcopy_sequence (arg);
886 for (j = 0; j < i; j++)
888 Lisp_Object elt = XVECTOR_DATA (arg) [j];
890 if (CONSP (elt) || VECTORP (elt))
891 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
897 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
898 Return the substring of STRING starting at START and ending before END.
899 END may be nil or omitted; then the substring runs to the end of STRING.
900 If START or END is negative, it counts from the end.
901 Relevant parts of the string-extent-data are copied to the new string.
903 (string, start, end))
905 Charcount ccstart, ccend;
906 Bytecount bstart, blen;
909 CHECK_STRING (string);
911 get_string_range_char (string, start, end, &ccstart, &ccend,
912 GB_HISTORICAL_STRING_BEHAVIOR);
913 bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart);
914 blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart);
915 val = make_string (XSTRING_DATA (string) + bstart, blen);
916 /* Copy any applicable extent information into the new string. */
917 copy_string_extents (val, string, 0, bstart, blen);
921 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
922 Return the subsequence of SEQUENCE starting at START and ending before END.
923 END may be omitted; then the subsequence runs to the end of SEQUENCE.
924 If START or END is negative, it counts from the end.
925 The returned subsequence is always of the same type as SEQUENCE.
926 If SEQUENCE is a string, relevant parts of the string-extent-data
927 are copied to the new string.
929 (sequence, start, end))
933 if (STRINGP (sequence))
934 return Fsubstring (sequence, start, end);
936 len = XINT (Flength (sequence));
953 if (!(0 <= s && s <= e && e <= len))
954 args_out_of_range_3 (sequence, make_int (s), make_int (e));
956 if (VECTORP (sequence))
958 Lisp_Object result = make_vector (e - s, Qnil);
960 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
961 Lisp_Object *out_elts = XVECTOR_DATA (result);
963 for (i = s; i < e; i++)
964 out_elts[i - s] = in_elts[i];
967 else if (LISTP (sequence))
969 Lisp_Object result = Qnil;
972 sequence = Fnthcdr (make_int (s), sequence);
974 for (i = s; i < e; i++)
976 result = Fcons (Fcar (sequence), result);
977 sequence = Fcdr (sequence);
980 return Fnreverse (result);
982 else if (BIT_VECTORP (sequence))
984 Lisp_Object result = make_bit_vector (e - s, Qzero);
987 for (i = s; i < e; i++)
988 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
989 bit_vector_bit (XBIT_VECTOR (sequence), i));
994 abort (); /* unreachable, since Flength (sequence) did not get
1001 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1002 Take cdr N times on LIST, and return the result.
1007 REGISTER Lisp_Object tail = list;
1009 for (i = XINT (n); i; i--)
1013 else if (NILP (tail))
1017 tail = wrong_type_argument (Qlistp, tail);
1024 DEFUN ("nth", Fnth, 2, 2, 0, /*
1025 Return the Nth element of LIST.
1026 N counts from zero. If LIST is not that long, nil is returned.
1030 return Fcar (Fnthcdr (n, list));
1033 DEFUN ("elt", Felt, 2, 2, 0, /*
1034 Return element of SEQUENCE at index N.
1039 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1040 if (LISTP (sequence))
1042 Lisp_Object tem = Fnthcdr (n, sequence);
1043 /* #### Utterly, completely, fucking disgusting.
1044 * #### The whole point of "elt" is that it operates on
1045 * #### sequences, and does error- (bounds-) checking.
1051 /* This is The Way It Has Always Been. */
1054 /* This is The Way Mly and Cltl2 say It Should Be. */
1055 args_out_of_range (sequence, n);
1058 else if (STRINGP (sequence) ||
1059 VECTORP (sequence) ||
1060 BIT_VECTORP (sequence))
1061 return Faref (sequence, n);
1062 #ifdef LOSING_BYTECODE
1063 else if (COMPILED_FUNCTIONP (sequence))
1065 EMACS_INT idx = XINT (n);
1069 args_out_of_range (sequence, n);
1071 /* Utter perversity */
1073 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1076 case COMPILED_ARGLIST:
1077 return compiled_function_arglist (f);
1078 case COMPILED_INSTRUCTIONS:
1079 return compiled_function_instructions (f);
1080 case COMPILED_CONSTANTS:
1081 return compiled_function_constants (f);
1082 case COMPILED_STACK_DEPTH:
1083 return compiled_function_stack_depth (f);
1084 case COMPILED_DOC_STRING:
1085 return compiled_function_documentation (f);
1086 case COMPILED_DOMAIN:
1087 return compiled_function_domain (f);
1088 case COMPILED_INTERACTIVE:
1089 if (f->flags.interactivep)
1090 return compiled_function_interactive (f);
1091 /* if we return nil, can't tell interactive with no args
1092 from noninteractive. */
1099 #endif /* LOSING_BYTECODE */
1102 check_losing_bytecode ("elt", sequence);
1103 sequence = wrong_type_argument (Qsequencep, sequence);
1108 DEFUN ("last", Flast, 1, 2, 0, /*
1109 Return the tail of list LIST, of length N (default 1).
1110 LIST may be a dotted list, but not a circular list.
1111 Optional argument N must be a non-negative integer.
1112 If N is zero, then the atom that terminates the list is returned.
1113 If N is greater than the length of LIST, then LIST itself is returned.
1117 EMACS_INT int_n, count;
1118 Lisp_Object retval, tortoise, hare;
1130 for (retval = tortoise = hare = list, count = 0;
1133 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1136 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1139 tortoise = XCDR (tortoise);
1140 if (EQ (hare, tortoise))
1141 signal_circular_list_error (list);
1147 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1148 Modify LIST to remove the last N (default 1) elements.
1149 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1166 Lisp_Object last_cons = list;
1168 EXTERNAL_LIST_LOOP_1 (list)
1171 last_cons = XCDR (last_cons);
1177 XCDR (last_cons) = Qnil;
1182 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1183 Return a copy of LIST with the last N (default 1) elements removed.
1184 If LIST has N or fewer elements, nil is returned.
1201 Lisp_Object retval = Qnil;
1202 Lisp_Object tail = list;
1204 EXTERNAL_LIST_LOOP_1 (list)
1208 retval = Fcons (XCAR (tail), retval);
1213 return Fnreverse (retval);
1217 DEFUN ("member", Fmember, 2, 2, 0, /*
1218 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1219 The value is actually the tail of LIST whose car is ELT.
1223 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1225 if (internal_equal (elt, list_elt, 0))
1231 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1232 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1233 The value is actually the tail of LIST whose car is ELT.
1234 This function is provided only for byte-code compatibility with v19.
1239 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1241 if (internal_old_equal (elt, list_elt, 0))
1247 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1248 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1249 The value is actually the tail of LIST whose car is ELT.
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 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1271 if (HACKEQ_UNSAFE (elt, list_elt))
1278 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1280 LIST_LOOP_3 (list_elt, list, tail)
1282 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1288 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1289 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1290 The value is actually the element of ALIST whose car equals KEY.
1294 /* This function can GC. */
1295 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1297 if (internal_equal (key, elt_car, 0))
1303 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1304 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
1305 The value is actually the element of ALIST whose car equals KEY.
1309 /* This function can GC. */
1310 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1312 if (internal_old_equal (key, elt_car, 0))
1319 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
1321 int speccount = specpdl_depth ();
1322 specbind (Qinhibit_quit, Qt);
1323 return unbind_to (speccount, Fassoc (key, alist));
1326 DEFUN ("assq", Fassq, 2, 2, 0, /*
1327 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1328 The value is actually the element of ALIST whose car is KEY.
1329 Elements of ALIST that are not conses are ignored.
1333 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1335 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1341 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1342 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
1343 The value is actually the element of ALIST whose car is KEY.
1344 Elements of ALIST that are not conses are ignored.
1345 This function is provided only for byte-code compatibility with v19.
1350 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1352 if (HACKEQ_UNSAFE (key, elt_car))
1358 /* Like Fassq but never report an error and do not allow quits.
1359 Use only on lists known never to be circular. */
1362 assq_no_quit (Lisp_Object key, Lisp_Object alist)
1364 /* This cannot GC. */
1365 LIST_LOOP_2 (elt, alist)
1367 Lisp_Object elt_car = XCAR (elt);
1368 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1374 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1375 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1376 The value is actually the element of ALIST whose cdr equals VALUE.
1380 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1382 if (internal_equal (value, elt_cdr, 0))
1388 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1389 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
1390 The value is actually the element of ALIST whose cdr equals VALUE.
1394 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1396 if (internal_old_equal (value, elt_cdr, 0))
1402 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1403 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1404 The value is actually the element of ALIST whose cdr is VALUE.
1408 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1410 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1416 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1417 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
1418 The value is actually the element of ALIST whose cdr is VALUE.
1422 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1424 if (HACKEQ_UNSAFE (value, elt_cdr))
1430 /* Like Frassq, but caller must ensure that ALIST is properly
1431 nil-terminated and ebola-free. */
1433 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
1435 LIST_LOOP_2 (elt, alist)
1437 Lisp_Object elt_cdr = XCDR (elt);
1438 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1445 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1446 Delete by side effect any occurrences of ELT as a member of LIST.
1447 The modified LIST is returned. Comparison is done with `equal'.
1448 If the first member of LIST is ELT, there is no way to remove it by side
1449 effect; therefore, write `(setq foo (delete element foo))' to be sure
1450 of changing the value of `foo'.
1455 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1456 (internal_equal (elt, list_elt, 0)));
1460 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1461 Delete by side effect any occurrences of ELT as a member of LIST.
1462 The modified LIST is returned. Comparison is done with `old-equal'.
1463 If the first member of LIST is ELT, there is no way to remove it by side
1464 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1465 of changing the value of `foo'.
1469 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1470 (internal_old_equal (elt, list_elt, 0)));
1474 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1475 Delete by side effect any occurrences of ELT as a member of LIST.
1476 The modified LIST is returned. Comparison is done with `eq'.
1477 If the first member of LIST is ELT, there is no way to remove it by side
1478 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1479 changing the value of `foo'.
1483 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1484 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1488 DEFUN ("old-delq", Fold_delq, 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 `old-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 (old-delq element foo))' to be sure of
1493 changing the value of `foo'.
1497 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1498 (HACKEQ_UNSAFE (elt, list_elt)));
1502 /* Like Fdelq, but caller must ensure that LIST is properly
1503 nil-terminated and ebola-free. */
1506 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1508 LIST_LOOP_DELETE_IF (list_elt, list,
1509 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1513 /* Be VERY careful with this. This is like delq_no_quit() but
1514 also calls free_cons() on the removed conses. You must be SURE
1515 that no pointers to the freed conses remain around (e.g.
1516 someone else is pointing to part of the list). This function
1517 is useful on internal lists that are used frequently and where
1518 the actual list doesn't escape beyond known code bounds. */
1521 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1523 REGISTER Lisp_Object tail = list;
1524 REGISTER Lisp_Object prev = Qnil;
1526 while (!NILP (tail))
1528 REGISTER Lisp_Object tem = XCAR (tail);
1531 Lisp_Object cons_to_free = tail;
1535 XCDR (prev) = XCDR (tail);
1537 free_cons (XCONS (cons_to_free));
1548 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1549 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
1550 The modified ALIST is returned. If the first member of ALIST has a car
1551 that is `equal' to KEY, there is no way to remove it by side effect;
1552 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1557 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1559 internal_equal (key, XCAR (elt), 0)));
1564 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
1566 int speccount = specpdl_depth ();
1567 specbind (Qinhibit_quit, Qt);
1568 return unbind_to (speccount, Fremassoc (key, alist));
1571 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1572 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
1573 The modified ALIST is returned. If the first member of ALIST has a car
1574 that is `eq' to KEY, there is no way to remove it by side effect;
1575 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1580 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1582 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1586 /* no quit, no errors; be careful */
1589 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
1591 LIST_LOOP_DELETE_IF (elt, alist,
1593 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1597 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1598 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
1599 The modified ALIST is returned. If the first member of ALIST has a car
1600 that is `equal' to VALUE, there is no way to remove it by side effect;
1601 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1606 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1608 internal_equal (value, XCDR (elt), 0)));
1612 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1613 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
1614 The modified ALIST is returned. If the first member of ALIST has a car
1615 that is `eq' to VALUE, there is no way to remove it by side effect;
1616 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1621 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
1623 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1627 /* Like Fremrassq, fast and unsafe; be careful */
1629 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
1631 LIST_LOOP_DELETE_IF (elt, alist,
1633 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1637 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1638 Reverse LIST by destructively modifying cdr pointers.
1639 Return the beginning of the reversed list.
1640 Also see: `reverse'.
1644 struct gcpro gcpro1, gcpro2;
1645 REGISTER Lisp_Object prev = Qnil;
1646 REGISTER Lisp_Object tail = list;
1648 /* We gcpro our args; see `nconc' */
1649 GCPRO2 (prev, tail);
1650 while (!NILP (tail))
1652 REGISTER Lisp_Object next;
1653 CONCHECK_CONS (tail);
1663 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1664 Reverse LIST, copying. Return the beginning of the reversed list.
1665 See also the function `nreverse', which is used more often.
1669 Lisp_Object reversed_list = Qnil;
1670 EXTERNAL_LIST_LOOP_2 (elt, list)
1672 reversed_list = Fcons (elt, reversed_list);
1674 return reversed_list;
1677 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1678 Lisp_Object lisp_arg,
1679 int (*pred_fn) (Lisp_Object, Lisp_Object,
1680 Lisp_Object lisp_arg));
1683 list_sort (Lisp_Object list,
1684 Lisp_Object lisp_arg,
1685 int (*pred_fn) (Lisp_Object, Lisp_Object,
1686 Lisp_Object lisp_arg))
1688 struct gcpro gcpro1, gcpro2, gcpro3;
1689 Lisp_Object back, tem;
1690 Lisp_Object front = list;
1691 Lisp_Object len = Flength (list);
1696 len = make_int (XINT (len) / 2 - 1);
1697 tem = Fnthcdr (len, list);
1699 Fsetcdr (tem, Qnil);
1701 GCPRO3 (front, back, lisp_arg);
1702 front = list_sort (front, lisp_arg, pred_fn);
1703 back = list_sort (back, lisp_arg, pred_fn);
1705 return list_merge (front, back, lisp_arg, pred_fn);
1710 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1715 /* prevents the GC from happening in call2 */
1716 int speccount = specpdl_depth ();
1717 /* Emacs' GC doesn't actually relocate pointers, so this probably
1718 isn't strictly necessary */
1719 record_unwind_protect (restore_gc_inhibit,
1720 make_int (gc_currently_forbidden));
1721 gc_currently_forbidden = 1;
1722 tmp = call2 (pred, obj1, obj2);
1723 unbind_to (speccount, Qnil);
1731 DEFUN ("sort", Fsort, 2, 2, 0, /*
1732 Sort LIST, stably, comparing elements using PREDICATE.
1733 Returns the sorted list. LIST is modified by side effects.
1734 PREDICATE is called with two elements of LIST, and should return T
1735 if the first element is "less" than the second.
1739 return list_sort (list, predicate, merge_pred_function);
1743 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1746 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1751 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1752 Lisp_Object lisp_arg,
1753 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1759 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1766 /* It is sufficient to protect org_l1 and org_l2.
1767 When l1 and l2 are updated, we copy the new values
1768 back into the org_ vars. */
1770 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1791 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1806 Fsetcdr (tail, tem);
1812 /************************************************************************/
1813 /* property-list functions */
1814 /************************************************************************/
1816 /* For properties of text, we need to do order-insensitive comparison of
1817 plists. That is, we need to compare two plists such that they are the
1818 same if they have the same set of keys, and equivalent values.
1819 So (a 1 b 2) would be equal to (b 2 a 1).
1821 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1822 LAXP means use `equal' for comparisons.
1825 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1826 int laxp, int depth)
1828 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1829 int la, lb, m, i, fill;
1830 Lisp_Object *keys, *vals;
1834 if (NILP (a) && NILP (b))
1837 Fcheck_valid_plist (a);
1838 Fcheck_valid_plist (b);
1840 la = XINT (Flength (a));
1841 lb = XINT (Flength (b));
1842 m = (la > lb ? la : lb);
1844 keys = alloca_array (Lisp_Object, m);
1845 vals = alloca_array (Lisp_Object, m);
1846 flags = alloca_array (char, m);
1848 /* First extract the pairs from A. */
1849 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1851 Lisp_Object k = XCAR (rest);
1852 Lisp_Object v = XCAR (XCDR (rest));
1853 /* Maybe be Ebolified. */
1854 if (nil_means_not_present && NILP (v)) continue;
1860 /* Now iterate over B, and stop if we find something that's not in A,
1861 or that doesn't match. As we match, mark them. */
1862 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1864 Lisp_Object k = XCAR (rest);
1865 Lisp_Object v = XCAR (XCDR (rest));
1866 /* Maybe be Ebolified. */
1867 if (nil_means_not_present && NILP (v)) continue;
1868 for (i = 0; i < fill; i++)
1870 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1873 /* We narrowly escaped being Ebolified here. */
1874 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1875 : !internal_equal (v, vals [i], depth))
1876 /* a property in B has a different value than in A */
1883 /* there are some properties in B that are not in A */
1886 /* Now check to see that all the properties in A were also in B */
1887 for (i = 0; i < fill; i++)
1898 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1899 Return non-nil if property lists A and B are `eq'.
1900 A property list is an alternating list of keywords and values.
1901 This function does order-insensitive comparisons of the property lists:
1902 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1903 Comparison between values is done using `eq'. See also `plists-equal'.
1904 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1905 a nil value is ignored. This feature is a virus that has infected
1906 old Lisp implementations, but should not be used except for backward
1909 (a, b, nil_means_not_present))
1911 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1915 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1916 Return non-nil if property lists A and B are `equal'.
1917 A property list is an alternating list of keywords and values. This
1918 function does order-insensitive comparisons of the property lists: For
1919 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1920 Comparison between values is done using `equal'. See also `plists-eq'.
1921 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1922 a nil value is ignored. This feature is a virus that has infected
1923 old Lisp implementations, but should not be used except for backward
1926 (a, b, nil_means_not_present))
1928 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1933 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1934 Return non-nil if lax property lists A and B are `eq'.
1935 A property list is an alternating list of keywords and values.
1936 This function does order-insensitive comparisons of the property lists:
1937 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1938 Comparison between values is done using `eq'. See also `plists-equal'.
1939 A lax property list is like a regular one except that comparisons between
1940 keywords is done using `equal' instead of `eq'.
1941 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1942 a nil value is ignored. This feature is a virus that has infected
1943 old Lisp implementations, but should not be used except for backward
1946 (a, b, nil_means_not_present))
1948 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1952 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1953 Return non-nil if lax property lists A and B are `equal'.
1954 A property list is an alternating list of keywords and values. This
1955 function does order-insensitive comparisons of the property lists: For
1956 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1957 Comparison between values is done using `equal'. See also `plists-eq'.
1958 A lax property list is like a regular one except that comparisons between
1959 keywords is done using `equal' instead of `eq'.
1960 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1961 a nil value is ignored. This feature is a virus that has infected
1962 old Lisp implementations, but should not be used except for backward
1965 (a, b, nil_means_not_present))
1967 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1971 /* Return the value associated with key PROPERTY in property list PLIST.
1972 Return nil if key not found. This function is used for internal
1973 property lists that cannot be directly manipulated by the user.
1977 internal_plist_get (Lisp_Object plist, Lisp_Object property)
1981 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
1983 if (EQ (XCAR (tail), property))
1984 return XCAR (XCDR (tail));
1990 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
1991 internal_plist_get(). */
1994 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
1999 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2001 if (EQ (XCAR (tail), property))
2003 XCAR (XCDR (tail)) = value;
2008 *plist = Fcons (property, Fcons (value, *plist));
2012 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2014 Lisp_Object tail, prev;
2016 for (tail = *plist, prev = Qnil;
2018 tail = XCDR (XCDR (tail)))
2020 if (EQ (XCAR (tail), property))
2023 *plist = XCDR (XCDR (tail));
2025 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2035 /* Called on a malformed property list. BADPLACE should be some
2036 place where truncating will form a good list -- i.e. we shouldn't
2037 result in a list with an odd length. */
2040 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2042 if (ERRB_EQ (errb, ERROR_ME))
2043 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2046 if (ERRB_EQ (errb, ERROR_ME_WARN))
2048 warn_when_safe_lispobj
2051 ("Malformed property list -- list has been truncated"),
2059 /* Called on a circular property list. BADPLACE should be some place
2060 where truncating will result in an even-length list, as above.
2061 If doesn't particularly matter where we truncate -- anywhere we
2062 truncate along the entire list will break the circularity, because
2063 it will create a terminus and the list currently doesn't have one.
2067 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2069 if (ERRB_EQ (errb, ERROR_ME))
2070 return Fsignal (Qcircular_property_list, list1 (*plist));
2073 if (ERRB_EQ (errb, ERROR_ME_WARN))
2075 warn_when_safe_lispobj
2078 ("Circular property list -- list has been truncated"),
2086 /* Advance the tortoise pointer by two (one iteration of a property-list
2087 loop) and the hare pointer by four and verify that no malformations
2088 or circularities exist. If so, return zero and store a value into
2089 RETVAL that should be returned by the calling function. Otherwise,
2090 return 1. See external_plist_get().
2094 advance_plist_pointers (Lisp_Object *plist,
2095 Lisp_Object **tortoise, Lisp_Object **hare,
2096 Error_behavior errb, Lisp_Object *retval)
2099 Lisp_Object *tortsave = *tortoise;
2101 /* Note that our "fixing" may be more brutal than necessary,
2102 but it's the user's own problem, not ours, if they went in and
2103 manually fucked up a plist. */
2105 for (i = 0; i < 2; i++)
2107 /* This is a standard iteration of a defensive-loop-checking
2108 loop. We just do it twice because we want to advance past
2109 both the property and its value.
2111 If the pointer indirection is confusing you, remember that
2112 one level of indirection on the hare and tortoise pointers
2113 is only due to pass-by-reference for this function. The other
2114 level is so that the plist can be fixed in place. */
2116 /* When we reach the end of a well-formed plist, **HARE is
2117 nil. In that case, we don't do anything at all except
2118 advance TORTOISE by one. Otherwise, we advance HARE
2119 by two (making sure it's OK to do so), then advance
2120 TORTOISE by one (it will always be OK to do so because
2121 the HARE is always ahead of the TORTOISE and will have
2122 already verified the path), then make sure TORTOISE and
2123 HARE don't contain the same non-nil object -- if the
2124 TORTOISE and the HARE ever meet, then obviously we're
2125 in a circularity, and if we're in a circularity, then
2126 the TORTOISE and the HARE can't cross paths without
2127 meeting, since the HARE only gains one step over the
2128 TORTOISE per iteration. */
2132 Lisp_Object *haresave = *hare;
2133 if (!CONSP (**hare))
2135 *retval = bad_bad_bunny (plist, haresave, errb);
2138 *hare = &XCDR (**hare);
2139 /* In a non-plist, we'd check here for a nil value for
2140 **HARE, which is OK (it just means the list has an
2141 odd number of elements). In a plist, it's not OK
2142 for the list to have an odd number of elements. */
2143 if (!CONSP (**hare))
2145 *retval = bad_bad_bunny (plist, haresave, errb);
2148 *hare = &XCDR (**hare);
2151 *tortoise = &XCDR (**tortoise);
2152 if (!NILP (**hare) && EQ (**tortoise, **hare))
2154 *retval = bad_bad_turtle (plist, tortsave, errb);
2162 /* Return the value of PROPERTY from PLIST, or Qunbound if
2163 property is not on the list.
2165 PLIST is a Lisp-accessible property list, meaning that it
2166 has to be checked for malformations and circularities.
2168 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2169 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2170 on finding a malformation or a circularity, it issues a warning and
2171 attempts to silently fix the problem.
2173 A pointer to PLIST is passed in so that PLIST can be successfully
2174 "fixed" even if the error is at the beginning of the plist. */
2177 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2178 int laxp, Error_behavior errb)
2180 Lisp_Object *tortoise = plist;
2181 Lisp_Object *hare = plist;
2183 while (!NILP (*tortoise))
2185 Lisp_Object *tortsave = tortoise;
2188 /* We do the standard tortoise/hare march. We isolate the
2189 grungy stuff to do this in advance_plist_pointers(), though.
2190 To us, all this function does is advance the tortoise
2191 pointer by two and the hare pointer by four and make sure
2192 everything's OK. We first advance the pointers and then
2193 check if a property matched; this ensures that our
2194 check for a matching property is safe. */
2196 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2199 if (!laxp ? EQ (XCAR (*tortsave), property)
2200 : internal_equal (XCAR (*tortsave), property, 0))
2201 return XCAR (XCDR (*tortsave));
2207 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2208 malformed or circular plist. Analogous to external_plist_get(). */
2211 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2212 Lisp_Object value, int laxp, Error_behavior errb)
2214 Lisp_Object *tortoise = plist;
2215 Lisp_Object *hare = plist;
2217 while (!NILP (*tortoise))
2219 Lisp_Object *tortsave = tortoise;
2223 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2226 if (!laxp ? EQ (XCAR (*tortsave), property)
2227 : internal_equal (XCAR (*tortsave), property, 0))
2229 XCAR (XCDR (*tortsave)) = value;
2234 *plist = Fcons (property, Fcons (value, *plist));
2238 external_remprop (Lisp_Object *plist, Lisp_Object property,
2239 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 /* Now you see why it's so convenient to have that level
2258 *tortsave = XCDR (XCDR (*tortsave));
2266 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2267 Extract a value from a property list.
2268 PLIST is a property list, which is a list of the form
2269 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
2270 PROPERTY is usually a symbol.
2271 This function returns the value corresponding to the PROPERTY,
2272 or DEFAULT if PROPERTY is not one of the properties on the list.
2274 (plist, property, default_))
2276 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
2277 return UNBOUNDP (value) ? default_ : value;
2280 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2281 Change value in PLIST of PROPERTY to VALUE.
2282 PLIST is a property list, which is a list of the form
2283 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2284 PROPERTY is usually a symbol and VALUE is any object.
2285 If PROPERTY is already a property on the list, its value is set to VALUE,
2286 otherwise the new PROPERTY VALUE pair is added.
2287 The new plist is returned; use `(setq x (plist-put x property value))'
2288 to be sure to use the new value. PLIST is modified by side effect.
2290 (plist, property, value))
2292 external_plist_put (&plist, property, value, 0, ERROR_ME);
2296 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2297 Remove from PLIST the property PROPERTY and its value.
2298 PLIST is a property list, which is a list of the form
2299 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2300 PROPERTY is usually a symbol.
2301 The new plist is returned; use `(setq x (plist-remprop x property))'
2302 to be sure to use the new value. PLIST is modified by side effect.
2306 external_remprop (&plist, property, 0, ERROR_ME);
2310 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2311 Return t if PROPERTY has a value specified in PLIST.
2315 Lisp_Object value = Fplist_get (plist, property, Qunbound);
2316 return UNBOUNDP (value) ? Qnil : Qt;
2319 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2320 Given a plist, signal an error if there is anything wrong with it.
2321 This means that it's a malformed or circular plist.
2325 Lisp_Object *tortoise;
2331 while (!NILP (*tortoise))
2336 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2344 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2345 Given a plist, return non-nil if its format is correct.
2346 If it returns nil, `check-valid-plist' will signal an error when given
2347 the plist; that means it's a malformed or circular plist.
2351 Lisp_Object *tortoise;
2356 while (!NILP (*tortoise))
2361 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2369 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2370 Destructively remove any duplicate entries from a plist.
2371 In such cases, the first entry applies.
2373 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2374 a nil value is removed. This feature is a virus that has infected
2375 old Lisp implementations, but should not be used except for backward
2378 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2379 return value may not be EQ to the passed-in value, so make sure to
2380 `setq' the value back into where it came from.
2382 (plist, nil_means_not_present))
2384 Lisp_Object head = plist;
2386 Fcheck_valid_plist (plist);
2388 while (!NILP (plist))
2390 Lisp_Object prop = Fcar (plist);
2391 Lisp_Object next = Fcdr (plist);
2393 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2394 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2396 if (EQ (head, plist))
2398 plist = Fcdr (next);
2401 /* external_remprop returns 1 if it removed any property.
2402 We have to loop till it didn't remove anything, in case
2403 the property occurs many times. */
2404 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2406 plist = Fcdr (next);
2412 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2413 Extract a value from a lax property list.
2414 LAX-PLIST is a lax property list, which is a list of the form
2415 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2416 properties is done using `equal' instead of `eq'.
2417 PROPERTY is usually a symbol.
2418 This function returns the value corresponding to PROPERTY,
2419 or DEFAULT if PROPERTY is not one of the properties on the list.
2421 (lax_plist, property, default_))
2423 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
2424 return UNBOUNDP (value) ? default_ : value;
2427 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2428 Change value in LAX-PLIST of PROPERTY to VALUE.
2429 LAX-PLIST is a lax property list, which is a list of the form
2430 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2431 properties is done using `equal' instead of `eq'.
2432 PROPERTY is usually a symbol and VALUE is any object.
2433 If PROPERTY is already a property on the list, its value is set to
2434 VALUE, otherwise the new PROPERTY VALUE pair is added.
2435 The new plist is returned; use `(setq x (lax-plist-put x property value))'
2436 to be sure to use the new value. LAX-PLIST is modified by side effect.
2438 (lax_plist, property, value))
2440 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
2444 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2445 Remove from LAX-PLIST the property PROPERTY and its value.
2446 LAX-PLIST is a lax property list, which is a list of the form
2447 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2448 properties is done using `equal' instead of `eq'.
2449 PROPERTY is usually a symbol.
2450 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
2451 to be sure to use the new value. LAX-PLIST is modified by side effect.
2453 (lax_plist, property))
2455 external_remprop (&lax_plist, property, 1, ERROR_ME);
2459 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2460 Return t if PROPERTY has a value specified in LAX-PLIST.
2461 LAX-PLIST is a lax property list, which is a list of the form
2462 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2463 properties is done using `equal' instead of `eq'.
2465 (lax_plist, property))
2467 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
2470 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2471 Destructively remove any duplicate entries from a lax plist.
2472 In such cases, the first entry applies.
2474 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2475 a nil value is removed. This feature is a virus that has infected
2476 old Lisp implementations, but should not be used except for backward
2479 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2480 return value may not be EQ to the passed-in value, so make sure to
2481 `setq' the value back into where it came from.
2483 (lax_plist, nil_means_not_present))
2485 Lisp_Object head = lax_plist;
2487 Fcheck_valid_plist (lax_plist);
2489 while (!NILP (lax_plist))
2491 Lisp_Object prop = Fcar (lax_plist);
2492 Lisp_Object next = Fcdr (lax_plist);
2494 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2495 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2497 if (EQ (head, lax_plist))
2499 lax_plist = Fcdr (next);
2502 /* external_remprop returns 1 if it removed any property.
2503 We have to loop till it didn't remove anything, in case
2504 the property occurs many times. */
2505 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2507 lax_plist = Fcdr (next);
2513 /* In C because the frame props stuff uses it */
2515 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2516 Convert association list ALIST into the equivalent property-list form.
2517 The plist is returned. This converts from
2519 \((a . 1) (b . 2) (c . 3))
2525 The original alist is destroyed in the process of constructing the plist.
2526 See also `alist-to-plist'.
2530 Lisp_Object head = alist;
2531 while (!NILP (alist))
2533 /* remember the alist element. */
2534 Lisp_Object el = Fcar (alist);
2536 Fsetcar (alist, Fcar (el));
2537 Fsetcar (el, Fcdr (el));
2538 Fsetcdr (el, Fcdr (alist));
2539 Fsetcdr (alist, el);
2540 alist = Fcdr (Fcdr (alist));
2546 DEFUN ("get", Fget, 2, 3, 0, /*
2547 Return the value of OBJECT's PROPERTY property.
2548 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2549 If there is no such property, return optional third arg DEFAULT
2550 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2551 face, or glyph. See also `put', `remprop', and `object-plist'.
2553 (object, property, default_))
2555 /* Various places in emacs call Fget() and expect it not to quit,
2559 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2560 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2562 signal_simple_error ("Object type has no properties", object);
2564 return UNBOUNDP (val) ? default_ : val;
2567 DEFUN ("put", Fput, 3, 3, 0, /*
2568 Set OBJECT's PROPERTY to VALUE.
2569 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2570 OBJECT can be a symbol, face, extent, or string.
2571 For a string, no properties currently have predefined meanings.
2572 For the predefined properties for extents, see `set-extent-property'.
2573 For the predefined properties for faces, see `set-face-property'.
2574 See also `get', `remprop', and `object-plist'.
2576 (object, property, value))
2578 CHECK_LISP_WRITEABLE (object);
2580 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2582 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2583 (object, property, value))
2584 signal_simple_error ("Can't set property on object", property);
2587 signal_simple_error ("Object type has no settable properties", object);
2592 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2593 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2594 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2595 if the property list was actually modified (i.e. if PROPERTY was present
2596 in the property list). See also `get', `put', and `object-plist'.
2602 CHECK_LISP_WRITEABLE (object);
2604 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2606 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2608 signal_simple_error ("Can't remove property from object", property);
2611 signal_simple_error ("Object type has no removable properties", object);
2613 return ret ? Qt : Qnil;
2616 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2617 Return a property list of OBJECT's properties.
2618 For a symbol, this is equivalent to `symbol-plist'.
2619 OBJECT can be a symbol, string, extent, face, or glyph.
2620 Do not modify the returned property list directly;
2621 this may or may not have the desired effects. Use `put' instead.
2625 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2626 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2628 signal_simple_error ("Object type has no properties", object);
2635 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2638 error ("Stack overflow in equal");
2640 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2642 /* Note that (equal 20 20.0) should be nil */
2643 if (XTYPE (obj1) != XTYPE (obj2))
2645 if (LRECORDP (obj1))
2647 const struct lrecord_implementation
2648 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2649 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2651 return (imp1 == imp2) &&
2652 /* EQ-ness of the objects was noticed above */
2653 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2659 /* Note that we may be calling sub-objects that will use
2660 internal_equal() (instead of internal_old_equal()). Oh well.
2661 We will get an Ebola note if there's any possibility of confusion,
2662 but that seems unlikely. */
2665 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2668 error ("Stack overflow in equal");
2670 if (HACKEQ_UNSAFE (obj1, obj2))
2672 /* Note that (equal 20 20.0) should be nil */
2673 if (XTYPE (obj1) != XTYPE (obj2))
2676 return internal_equal (obj1, obj2, depth);
2679 DEFUN ("equal", Fequal, 2, 2, 0, /*
2680 Return t if two Lisp objects have similar structure and contents.
2681 They must have the same data type.
2682 Conses are compared by comparing the cars and the cdrs.
2683 Vectors and strings are compared element by element.
2684 Numbers are compared by value. Symbols must match exactly.
2688 return internal_equal (object1, object2, 0) ? Qt : Qnil;
2691 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2692 Return t if two Lisp objects have similar structure and contents.
2693 They must have the same data type.
2694 \(Note, however, that an exception is made for characters and integers;
2695 this is known as the "char-int confoundance disease." See `eq' and
2697 This function is provided only for byte-code compatibility with v19.
2702 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
2706 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2707 Destructively modify ARRAY by replacing each element with ITEM.
2708 ARRAY is a vector, bit vector, or string.
2713 if (STRINGP (array))
2715 Lisp_String *s = XSTRING (array);
2716 Bytecount old_bytecount = string_length (s);
2717 Bytecount new_bytecount;
2718 Bytecount item_bytecount;
2719 Bufbyte item_buf[MAX_EMCHAR_LEN];
2723 CHECK_CHAR_COERCE_INT (item);
2724 CHECK_LISP_WRITEABLE (array);
2726 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2727 new_bytecount = item_bytecount * string_char_length (s);
2729 resize_string (s, -1, new_bytecount - old_bytecount);
2731 for (p = string_data (s), end = p + new_bytecount;
2733 p += item_bytecount)
2734 memcpy (p, item_buf, item_bytecount);
2737 bump_string_modiff (array);
2739 else if (VECTORP (array))
2741 Lisp_Object *p = XVECTOR_DATA (array);
2742 size_t len = XVECTOR_LENGTH (array);
2743 CHECK_LISP_WRITEABLE (array);
2747 else if (BIT_VECTORP (array))
2749 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2750 size_t len = bit_vector_length (v);
2754 CHECK_LISP_WRITEABLE (array);
2756 set_bit_vector_bit (v, len, bit);
2760 array = wrong_type_argument (Qarrayp, array);
2767 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2769 Lisp_Object args[2];
2770 struct gcpro gcpro1;
2777 RETURN_UNGCPRO (bytecode_nconc2 (args));
2781 bytecode_nconc2 (Lisp_Object *args)
2785 if (CONSP (args[0]))
2787 /* (setcdr (last args[0]) args[1]) */
2788 Lisp_Object tortoise, hare;
2791 for (hare = tortoise = args[0], count = 0;
2792 CONSP (XCDR (hare));
2793 hare = XCDR (hare), count++)
2795 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2798 tortoise = XCDR (tortoise);
2799 if (EQ (hare, tortoise))
2800 signal_circular_list_error (args[0]);
2802 XCDR (hare) = args[1];
2805 else if (NILP (args[0]))
2811 args[0] = wrong_type_argument (args[0], Qlistp);
2816 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2817 Concatenate any number of lists by altering them.
2818 Only the last argument is not altered, and need not be a list.
2820 If the first argument is nil, there is no way to modify it by side
2821 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2822 changing the value of `foo'.
2824 (int nargs, Lisp_Object *args))
2827 struct gcpro gcpro1;
2829 /* The modus operandi in Emacs is "caller gc-protects args".
2830 However, nconc (particularly nconc2 ()) is called many times
2831 in Emacs on freshly created stuff (e.g. you see the idiom
2832 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2833 callers out by protecting the args ourselves to save them
2834 a lot of temporary-variable grief. */
2837 gcpro1.nvars = nargs;
2839 while (argnum < nargs)
2846 /* `val' is the first cons, which will be our return value. */
2847 /* `last_cons' will be the cons cell to mutate. */
2848 Lisp_Object last_cons = val;
2849 Lisp_Object tortoise = val;
2851 for (argnum++; argnum < nargs; argnum++)
2853 Lisp_Object next = args[argnum];
2855 if (CONSP (next) || argnum == nargs -1)
2857 /* (setcdr (last val) next) */
2861 CONSP (XCDR (last_cons));
2862 last_cons = XCDR (last_cons), count++)
2864 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2867 tortoise = XCDR (tortoise);
2868 if (EQ (last_cons, tortoise))
2869 signal_circular_list_error (args[argnum-1]);
2871 XCDR (last_cons) = next;
2873 else if (NILP (next))
2879 next = wrong_type_argument (Qlistp, next);
2883 RETURN_UNGCPRO (val);
2885 else if (NILP (val))
2887 else if (argnum == nargs - 1) /* last arg? */
2888 RETURN_UNGCPRO (val);
2891 args[argnum] = wrong_type_argument (Qlistp, val);
2895 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2899 /* This is the guts of several mapping functions.
2900 Apply FUNCTION to each element of SEQUENCE, one by one,
2901 storing the results into elements of VALS, a C vector of Lisp_Objects.
2902 LENI is the length of VALS, which should also be the length of SEQUENCE.
2904 If VALS is a null pointer, do not accumulate the results. */
2907 mapcar1 (size_t leni, Lisp_Object *vals,
2908 Lisp_Object function, Lisp_Object sequence)
2911 Lisp_Object args[2];
2912 struct gcpro gcpro1;
2922 if (LISTP (sequence))
2924 /* A devious `function' could either:
2925 - insert garbage into the list in front of us, causing XCDR to crash
2926 - amputate the list behind us using (setcdr), causing the remaining
2927 elts to lose their GCPRO status.
2929 if (vals != 0) we avoid this by copying the elts into the
2930 `vals' array. By a stroke of luck, `vals' is exactly large
2931 enough to hold the elts left to be traversed as well as the
2932 results computed so far.
2934 if (vals == 0) we don't have any free space available and
2935 don't want to eat up any more stack with alloca().
2936 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
2940 Lisp_Object *val = vals;
2943 LIST_LOOP_2 (elt, sequence)
2946 gcpro1.nvars = leni;
2948 for (i = 0; i < leni; i++)
2951 vals[i] = Ffuncall (2, args);
2956 Lisp_Object elt, tail;
2957 EMACS_INT len_unused;
2958 struct gcpro ngcpro1;
2963 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
2973 else if (VECTORP (sequence))
2975 Lisp_Object *objs = XVECTOR_DATA (sequence);
2977 for (i = 0; i < leni; i++)
2980 result = Ffuncall (2, args);
2981 if (vals) vals[gcpro1.nvars++] = result;
2984 else if (STRINGP (sequence))
2986 /* The string data of `sequence' might be relocated during GC. */
2987 Bytecount slen = XSTRING_LENGTH (sequence);
2988 Bufbyte *p = alloca_array (Bufbyte, slen);
2989 Bufbyte *end = p + slen;
2991 memcpy (p, XSTRING_DATA (sequence), slen);
2995 args[1] = make_char (charptr_emchar (p));
2997 result = Ffuncall (2, args);
2998 if (vals) vals[gcpro1.nvars++] = result;
3001 else if (BIT_VECTORP (sequence))
3003 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3005 for (i = 0; i < leni; i++)
3007 args[1] = make_int (bit_vector_bit (v, i));
3008 result = Ffuncall (2, args);
3009 if (vals) vals[gcpro1.nvars++] = result;
3013 abort (); /* unreachable, since Flength (sequence) did not get an error */
3019 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3020 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3021 In between each pair of results, insert SEPARATOR. Thus, using " " as
3022 SEPARATOR results in spaces between the values returned by FUNCTION.
3023 SEQUENCE may be a list, a vector, a bit vector, or a string.
3025 (function, sequence, separator))
3027 EMACS_INT len = XINT (Flength (sequence));
3030 EMACS_INT nargs = len + len - 1;
3032 if (len == 0) return build_string ("");
3034 args = alloca_array (Lisp_Object, nargs);
3036 mapcar1 (len, args, function, sequence);
3038 for (i = len - 1; i >= 0; i--)
3039 args[i + i] = args[i];
3041 for (i = 1; i < nargs; i += 2)
3042 args[i] = separator;
3044 return Fconcat (nargs, args);
3047 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3048 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3049 The result is a list of the same length as SEQUENCE.
3050 SEQUENCE may be a list, a vector, a bit vector, or a string.
3052 (function, sequence))
3054 size_t len = XINT (Flength (sequence));
3055 Lisp_Object *args = alloca_array (Lisp_Object, len);
3057 mapcar1 (len, args, function, sequence);
3059 return Flist (len, args);
3062 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3063 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3064 The result is a vector of the same length as SEQUENCE.
3065 SEQUENCE may be a list, a vector, a bit vector, or a string.
3067 (function, sequence))
3069 size_t len = XINT (Flength (sequence));
3070 Lisp_Object result = make_vector (len, Qnil);
3071 struct gcpro gcpro1;
3074 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3080 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3081 Apply FUNCTION to each element of SEQUENCE.
3082 SEQUENCE may be a list, a vector, a bit vector, or a string.
3083 This function is like `mapcar' but does not accumulate the results,
3084 which is more efficient if you do not use the results.
3086 The difference between this and `mapc' is that `mapc' supports all
3087 the spiffy Common Lisp arguments. You should normally use `mapc'.
3089 (function, sequence))
3091 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3099 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3100 Destructively replace the list OLD with NEW.
3101 This is like (copy-sequence NEW) except that it reuses the
3102 conses in OLD as much as possible. If OLD and NEW are the same
3103 length, no consing will take place.
3107 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
3109 EXTERNAL_LIST_LOOP (tail, new)
3111 if (!NILP (oldtail))
3113 CHECK_CONS (oldtail);
3114 XCAR (oldtail) = XCAR (tail);
3116 else if (!NILP (prevoldtail))
3118 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
3119 prevoldtail = XCDR (prevoldtail);
3122 old = oldtail = Fcons (XCAR (tail), Qnil);
3124 if (!NILP (oldtail))
3126 prevoldtail = oldtail;
3127 oldtail = XCDR (oldtail);
3131 if (!NILP (prevoldtail))
3132 XCDR (prevoldtail) = Qnil;
3140 /* #### this function doesn't belong in this file! */
3142 #ifdef HAVE_GETLOADAVG
3143 #ifdef HAVE_SYS_LOADAVG_H
3144 #include <sys/loadavg.h>
3147 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
3150 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3151 Return list of 1 minute, 5 minute and 15 minute load averages.
3152 Each of the three load averages is multiplied by 100,
3153 then converted to integer.
3155 When USE-FLOATS is non-nil, floats will be used instead of integers.
3156 These floats are not multiplied by 100.
3158 If the 5-minute or 15-minute load averages are not available, return a
3159 shortened list, containing only those averages which are available.
3161 On some systems, this won't work due to permissions on /dev/kmem,
3162 in which case you can't use this.
3167 int loads = getloadavg (load_ave, countof (load_ave));
3168 Lisp_Object ret = Qnil;
3171 error ("load-average not implemented for this operating system");
3173 signal_simple_error ("Could not get load-average",
3174 lisp_strerror (errno));
3178 Lisp_Object load = (NILP (use_floats) ?
3179 make_int ((int) (100.0 * load_ave[loads]))
3180 : make_float (load_ave[loads]));
3181 ret = Fcons (load, ret);
3187 Lisp_Object Vfeatures;
3189 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3190 Return non-nil if feature FEXP is present in this Emacs.
3191 Use this to conditionalize execution of lisp code based on the
3192 presence or absence of emacs or environment extensions.
3193 FEXP can be a symbol, a number, or a list.
3194 If it is a symbol, that symbol is looked up in the `features' variable,
3195 and non-nil will be returned if found.
3196 If it is a number, the function will return non-nil if this Emacs
3197 has an equal or greater version number than FEXP.
3198 If it is a list whose car is the symbol `and', it will return
3199 non-nil if all the features in its cdr are non-nil.
3200 If it is a list whose car is the symbol `or', it will return non-nil
3201 if any of the features in its cdr are non-nil.
3202 If it is a list whose car is the symbol `not', it will return
3203 non-nil if the feature is not present.
3208 => ; Non-nil on XEmacs.
3210 (featurep '(and xemacs gnus))
3211 => ; Non-nil on XEmacs with Gnus loaded.
3213 (featurep '(or tty-frames (and emacs 19.30)))
3214 => ; Non-nil if this Emacs supports TTY frames.
3216 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3217 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3219 (featurep '(and xemacs 21.02))
3220 => ; Non-nil on XEmacs 21.2 and later.
3222 NOTE: The advanced arguments of this function (anything other than a
3223 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3224 for supporting multiple Emacs variants, lobby Richard Stallman at
3225 <bug-gnu-emacs@gnu.org>.
3229 #ifndef FEATUREP_SYNTAX
3230 CHECK_SYMBOL (fexp);
3231 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3232 #else /* FEATUREP_SYNTAX */
3233 static double featurep_emacs_version;
3235 /* Brute force translation from Erik Naggum's lisp function. */
3238 /* Original definition */
3239 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3241 else if (INTP (fexp) || FLOATP (fexp))
3243 double d = extract_float (fexp);
3245 if (featurep_emacs_version == 0.0)
3247 featurep_emacs_version = XINT (Vemacs_major_version) +
3248 (XINT (Vemacs_minor_version) / 100.0);
3250 return featurep_emacs_version >= d ? Qt : Qnil;
3252 else if (CONSP (fexp))
3254 Lisp_Object tem = XCAR (fexp);
3260 negate = Fcar (tem);
3262 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3264 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3266 else if (EQ (tem, Qand))
3269 /* Use Fcar/Fcdr for error-checking. */
3270 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3274 return NILP (tem) ? Qt : Qnil;
3276 else if (EQ (tem, Qor))
3279 /* Use Fcar/Fcdr for error-checking. */
3280 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3284 return NILP (tem) ? Qnil : Qt;
3288 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3293 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3296 #endif /* FEATUREP_SYNTAX */
3298 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3299 Announce that FEATURE is a feature of the current Emacs.
3300 This function updates the value of the variable `features'.
3305 CHECK_SYMBOL (feature);
3306 if (!NILP (Vautoload_queue))
3307 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3308 tem = Fmemq (feature, Vfeatures);
3310 Vfeatures = Fcons (feature, Vfeatures);
3311 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3315 DEFUN ("require", Frequire, 1, 2, 0, /*
3316 If feature FEATURE is not loaded, load it from FILENAME.
3317 If FEATURE is not a member of the list `features', then the feature
3318 is not loaded; so load the file FILENAME.
3319 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3321 (feature, filename))
3324 CHECK_SYMBOL (feature);
3325 tem = Fmemq (feature, Vfeatures);
3326 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3331 int speccount = specpdl_depth ();
3333 /* Value saved here is to be restored into Vautoload_queue */
3334 record_unwind_protect (un_autoload, Vautoload_queue);
3335 Vautoload_queue = Qt;
3337 call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
3340 tem = Fmemq (feature, Vfeatures);
3342 error ("Required feature %s was not provided",
3343 string_data (XSYMBOL (feature)->name));
3345 /* Once loading finishes, don't undo it. */
3346 Vautoload_queue = Qt;
3347 return unbind_to (speccount, feature);
3351 /* base64 encode/decode functions.
3353 Originally based on code from GNU recode. Ported to FSF Emacs by
3354 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3355 subsequently heavily hacked by Hrvoje Niksic. */
3357 #define MIME_LINE_LENGTH 72
3359 #define IS_ASCII(Character) \
3361 #define IS_BASE64(Character) \
3362 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3364 /* Table of characters coding the 64 values. */
3365 static char base64_value_to_char[64] =
3367 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3368 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3369 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3370 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3371 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3372 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3373 '8', '9', '+', '/' /* 60-63 */
3376 /* Table of base64 values for first 128 characters. */
3377 static short base64_char_to_value[128] =
3379 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3380 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3381 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3382 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3383 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3384 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3385 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3386 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3387 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3388 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3389 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3390 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3391 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3394 /* The following diagram shows the logical steps by which three octets
3395 get transformed into four base64 characters.
3397 .--------. .--------. .--------.
3398 |aaaaaabb| |bbbbcccc| |ccdddddd|
3399 `--------' `--------' `--------'
3401 .--------+--------+--------+--------.
3402 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3403 `--------+--------+--------+--------'
3405 .--------+--------+--------+--------.
3406 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3407 `--------+--------+--------+--------'
3409 The octets are divided into 6 bit chunks, which are then encoded into
3410 base64 characters. */
3412 #define ADVANCE_INPUT(c, stream) \
3413 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3415 (signal_simple_error ("Non-ascii character in base64 input", \
3416 make_char (ec)), 0) \
3417 : (c = (Bufbyte)ec), 1))
3420 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3422 EMACS_INT counter = 0;
3430 if (!ADVANCE_INPUT (c, istream))
3433 /* Wrap line every 76 characters. */
3436 if (counter < MIME_LINE_LENGTH / 4)
3445 /* Process first byte of a triplet. */
3446 *e++ = base64_value_to_char[0x3f & c >> 2];
3447 value = (0x03 & c) << 4;
3449 /* Process second byte of a triplet. */
3450 if (!ADVANCE_INPUT (c, istream))
3452 *e++ = base64_value_to_char[value];
3458 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3459 value = (0x0f & c) << 2;
3461 /* Process third byte of a triplet. */
3462 if (!ADVANCE_INPUT (c, istream))
3464 *e++ = base64_value_to_char[value];
3469 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3470 *e++ = base64_value_to_char[0x3f & c];
3475 #undef ADVANCE_INPUT
3477 /* Get next character from the stream, except that non-base64
3478 characters are ignored. This is in accordance with rfc2045. EC
3479 should be an Emchar, so that it can hold -1 as the value for EOF. */
3480 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3481 ec = Lstream_get_emchar (stream); \
3483 /* IS_BASE64 may not be called with negative arguments so check for \
3485 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3489 #define STORE_BYTE(pos, val, ccnt) do { \
3490 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3495 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3499 EMACS_INT streampos = 0;
3504 unsigned long value;
3506 /* Process first byte of a quadruplet. */
3507 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3511 signal_simple_error ("Illegal `=' character while decoding base64",
3512 make_int (streampos));
3513 value = base64_char_to_value[ec] << 18;
3515 /* Process second byte of a quadruplet. */
3516 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3518 error ("Premature EOF while decoding base64");
3520 signal_simple_error ("Illegal `=' character while decoding base64",
3521 make_int (streampos));
3522 value |= base64_char_to_value[ec] << 12;
3523 STORE_BYTE (e, value >> 16, ccnt);
3525 /* Process third byte of a quadruplet. */
3526 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3528 error ("Premature EOF while decoding base64");
3532 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3534 error ("Premature EOF while decoding base64");
3536 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3537 make_int (streampos));
3541 value |= base64_char_to_value[ec] << 6;
3542 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3544 /* Process fourth byte of a quadruplet. */
3545 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3547 error ("Premature EOF while decoding base64");
3551 value |= base64_char_to_value[ec];
3552 STORE_BYTE (e, 0xff & value, ccnt);
3558 #undef ADVANCE_INPUT
3559 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3563 free_malloced_ptr (Lisp_Object unwind_obj)
3565 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3567 free_opaque_ptr (unwind_obj);
3571 /* Don't use alloca for regions larger than this, lest we overflow
3573 #define MAX_ALLOCA 65536
3575 /* We need to setup proper unwinding, because there is a number of
3576 ways these functions can blow up, and we don't want to have memory
3577 leaks in those cases. */
3578 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3579 size_t XOA_len = (len); \
3580 if (XOA_len > MAX_ALLOCA) \
3582 ptr = xnew_array (type, XOA_len); \
3583 record_unwind_protect (free_malloced_ptr, \
3584 make_opaque_ptr ((void *)ptr)); \
3587 ptr = alloca_array (type, XOA_len); \
3590 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3591 if ((len) > MAX_ALLOCA) \
3592 unbind_to (speccount, Qnil); \
3595 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3596 Base64-encode the region between START and END.
3597 Return the length of the encoded text.
3598 Optional third argument NO-LINE-BREAK means do not break long lines
3601 (start, end, no_line_break))
3604 Bytind encoded_length;
3605 Charcount allength, length;
3606 struct buffer *buf = current_buffer;
3607 Bufpos begv, zv, old_pt = BUF_PT (buf);
3609 int speccount = specpdl_depth();
3611 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3612 barf_if_buffer_read_only (buf, begv, zv);
3614 /* We need to allocate enough room for encoding the text.
3615 We need 33 1/3% more space, plus a newline every 76
3616 characters, and then we round up. */
3618 allength = length + length/3 + 1;
3619 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3621 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3622 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3623 base64 characters will be single-byte. */
3624 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3625 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3626 NILP (no_line_break));
3627 if (encoded_length > allength)
3629 Lstream_delete (XLSTREAM (input));
3631 /* Now we have encoded the region, so we insert the new contents
3632 and delete the old. (Insert first in order to preserve markers.) */
3633 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3634 XMALLOC_UNBIND (encoded, allength, speccount);
3635 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3637 /* Simulate FSF Emacs implementation of this function: if point was
3638 in the region, place it at the beginning. */
3639 if (old_pt >= begv && old_pt < zv)
3640 BUF_SET_PT (buf, begv);
3642 /* We return the length of the encoded text. */
3643 return make_int (encoded_length);
3646 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3647 Base64 encode STRING and return the result.
3648 Optional argument NO-LINE-BREAK means do not break long lines
3651 (string, no_line_break))
3653 Charcount allength, length;
3654 Bytind encoded_length;
3656 Lisp_Object input, result;
3657 int speccount = specpdl_depth();
3659 CHECK_STRING (string);
3661 length = XSTRING_CHAR_LENGTH (string);
3662 allength = length + length/3 + 1;
3663 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3665 input = make_lisp_string_input_stream (string, 0, -1);
3666 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3667 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3668 NILP (no_line_break));
3669 if (encoded_length > allength)
3671 Lstream_delete (XLSTREAM (input));
3672 result = make_string (encoded, encoded_length);
3673 XMALLOC_UNBIND (encoded, allength, speccount);
3677 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3678 Base64-decode the region between START and END.
3679 Return the length of the decoded text.
3680 If the region can't be decoded, return nil and don't modify the buffer.
3681 Characters out of the base64 alphabet are ignored.
3685 struct buffer *buf = current_buffer;
3686 Bufpos begv, zv, old_pt = BUF_PT (buf);
3688 Bytind decoded_length;
3689 Charcount length, cc_decoded_length;
3691 int speccount = specpdl_depth();
3693 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
3694 barf_if_buffer_read_only (buf, begv, zv);
3698 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3699 /* We need to allocate enough room for decoding the text. */
3700 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3701 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3702 if (decoded_length > length * MAX_EMCHAR_LEN)
3704 Lstream_delete (XLSTREAM (input));
3706 /* Now we have decoded the region, so we insert the new contents
3707 and delete the old. (Insert first in order to preserve markers.) */
3708 BUF_SET_PT (buf, begv);
3709 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3710 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3711 buffer_delete_range (buf, begv + cc_decoded_length,
3712 zv + cc_decoded_length, 0);
3714 /* Simulate FSF Emacs implementation of this function: if point was
3715 in the region, place it at the beginning. */
3716 if (old_pt >= begv && old_pt < zv)
3717 BUF_SET_PT (buf, begv);
3719 return make_int (cc_decoded_length);
3722 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3723 Base64-decode STRING and return the result.
3724 Characters out of the base64 alphabet are ignored.
3729 Bytind decoded_length;
3730 Charcount length, cc_decoded_length;
3731 Lisp_Object input, result;
3732 int speccount = specpdl_depth();
3734 CHECK_STRING (string);
3736 length = XSTRING_CHAR_LENGTH (string);
3737 /* We need to allocate enough room for decoding the text. */
3738 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3740 input = make_lisp_string_input_stream (string, 0, -1);
3741 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3742 &cc_decoded_length);
3743 if (decoded_length > length * MAX_EMCHAR_LEN)
3745 Lstream_delete (XLSTREAM (input));
3747 result = make_string (decoded, decoded_length);
3748 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3752 Lisp_Object Qyes_or_no_p;
3757 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3759 defsymbol (&Qstring_lessp, "string-lessp");
3760 defsymbol (&Qidentity, "identity");
3761 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3763 DEFSUBR (Fidentity);
3766 DEFSUBR (Fsafe_length);
3767 DEFSUBR (Fstring_equal);
3768 DEFSUBR (Fstring_lessp);
3769 DEFSUBR (Fstring_modified_tick);
3773 DEFSUBR (Fbvconcat);
3774 DEFSUBR (Fcopy_list);
3775 DEFSUBR (Fcopy_sequence);
3776 DEFSUBR (Fcopy_alist);
3777 DEFSUBR (Fcopy_tree);
3778 DEFSUBR (Fsubstring);
3785 DEFSUBR (Fnbutlast);
3787 DEFSUBR (Fold_member);
3789 DEFSUBR (Fold_memq);
3791 DEFSUBR (Fold_assoc);
3793 DEFSUBR (Fold_assq);
3795 DEFSUBR (Fold_rassoc);
3797 DEFSUBR (Fold_rassq);
3799 DEFSUBR (Fold_delete);
3801 DEFSUBR (Fold_delq);
3802 DEFSUBR (Fremassoc);
3804 DEFSUBR (Fremrassoc);
3805 DEFSUBR (Fremrassq);
3806 DEFSUBR (Fnreverse);
3809 DEFSUBR (Fplists_eq);
3810 DEFSUBR (Fplists_equal);
3811 DEFSUBR (Flax_plists_eq);
3812 DEFSUBR (Flax_plists_equal);
3813 DEFSUBR (Fplist_get);
3814 DEFSUBR (Fplist_put);
3815 DEFSUBR (Fplist_remprop);
3816 DEFSUBR (Fplist_member);
3817 DEFSUBR (Fcheck_valid_plist);
3818 DEFSUBR (Fvalid_plist_p);
3819 DEFSUBR (Fcanonicalize_plist);
3820 DEFSUBR (Flax_plist_get);
3821 DEFSUBR (Flax_plist_put);
3822 DEFSUBR (Flax_plist_remprop);
3823 DEFSUBR (Flax_plist_member);
3824 DEFSUBR (Fcanonicalize_lax_plist);
3825 DEFSUBR (Fdestructive_alist_to_plist);
3829 DEFSUBR (Fobject_plist);
3831 DEFSUBR (Fold_equal);
3832 DEFSUBR (Ffillarray);
3835 DEFSUBR (Fmapvector);
3836 DEFSUBR (Fmapc_internal);
3837 DEFSUBR (Fmapconcat);
3838 DEFSUBR (Freplace_list);
3839 DEFSUBR (Fload_average);
3840 DEFSUBR (Ffeaturep);
3843 DEFSUBR (Fbase64_encode_region);
3844 DEFSUBR (Fbase64_encode_string);
3845 DEFSUBR (Fbase64_decode_region);
3846 DEFSUBR (Fbase64_decode_string);
3850 init_provide_once (void)
3852 DEFVAR_LISP ("features", &Vfeatures /*
3853 A list of symbols which are the features of the executing emacs.
3854 Used by `featurep' and `require', and altered by `provide'.
3858 Fprovide (intern ("base64"));