1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
55 /* NOTE: This symbol is also used in lread.c */
56 #define FEATUREP_SYNTAX
58 Lisp_Object Qstring_lessp;
59 Lisp_Object Qidentity;
61 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
64 mark_bit_vector (Lisp_Object obj)
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
73 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
74 size_t len = bit_vector_length (v);
77 if (INTP (Vprint_length))
78 last = min (len, XINT (Vprint_length));
79 write_c_string ("#*", printcharfun);
80 for (i = 0; i < last; i++)
82 if (bit_vector_bit (v, i))
83 write_c_string ("1", printcharfun);
85 write_c_string ("0", printcharfun);
89 write_c_string ("...", printcharfun);
93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
95 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
96 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
98 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
99 !memcmp (v1->bits, v2->bits,
100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
105 bit_vector_hash (Lisp_Object obj, int depth)
107 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 return HASH2 (bit_vector_length (v),
109 memory_hash (v->bits,
110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
115 size_bit_vector (const void *lheader)
117 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
118 return offsetof (Lisp_Bit_Vector,
119 bits[BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))]);
122 static const struct lrecord_description bit_vector_description[] = {
123 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
128 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
129 mark_bit_vector, print_bit_vector, 0,
130 bit_vector_equal, bit_vector_hash,
131 bit_vector_description, size_bit_vector,
134 DEFUN ("identity", Fidentity, 1, 1, 0, /*
135 Return the argument unchanged.
142 extern long get_random (void);
143 extern void seed_random (long arg);
145 DEFUN ("random", Frandom, 0, 1, 0, /*
146 Return a pseudo-random number.
147 All integers representable in Lisp are equally likely.
148 On most systems, this is 28 bits' worth.
149 With positive integer argument N, return random number in interval [0,N).
150 With argument t, set the random number seed from the current time and pid.
155 unsigned long denominator;
158 seed_random (getpid () + time (NULL));
159 if (NATNUMP (limit) && !ZEROP (limit))
161 /* Try to take our random number from the higher bits of VAL,
162 not the lower, since (says Gentzel) the low bits of `random'
163 are less random than the higher ones. We do this by using the
164 quotient rather than the remainder. At the high end of the RNG
165 it's possible to get a quotient larger than limit; discarding
166 these values eliminates the bias that would otherwise appear
167 when using a large limit. */
168 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
170 val = get_random () / denominator;
171 while (val >= XINT (limit));
176 return make_int (val);
179 /* Random data-structure functions */
181 #ifdef LOSING_BYTECODE
183 /* #### Delete this shit */
185 /* Charcount is a misnomer here as we might be dealing with the
186 length of a vector or list, but emphasizes that we're not dealing
187 with Bytecounts in strings */
189 length_with_bytecode_hack (Lisp_Object seq)
191 if (!COMPILED_FUNCTIONP (seq))
192 return XINT (Flength (seq));
195 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
197 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
198 f->flags.domainp ? COMPILED_DOMAIN :
204 #endif /* LOSING_BYTECODE */
207 check_losing_bytecode (const char *function, Lisp_Object seq)
209 if (COMPILED_FUNCTIONP (seq))
212 "As of 20.3, `%s' no longer works with compiled-function objects",
216 DEFUN ("length", Flength, 1, 1, 0, /*
217 Return the length of vector, bit vector, list or string SEQUENCE.
222 if (STRINGP (sequence))
223 return make_int (XSTRING_CHAR_LENGTH (sequence));
224 else if (CONSP (sequence))
227 GET_EXTERNAL_LIST_LENGTH (sequence, len);
228 return make_int (len);
230 else if (VECTORP (sequence))
231 return make_int (XVECTOR_LENGTH (sequence));
232 else if (NILP (sequence))
234 else if (BIT_VECTORP (sequence))
235 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
238 check_losing_bytecode ("length", sequence);
239 sequence = wrong_type_argument (Qsequencep, sequence);
244 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
245 Return the length of a list, but avoid error or infinite loop.
246 This function never gets an error. If LIST is not really a list,
247 it returns 0. If LIST is circular, it returns a finite value
248 which is at least the number of distinct elements.
252 Lisp_Object hare, tortoise;
255 for (hare = tortoise = list, len = 0;
256 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
257 hare = XCDR (hare), len++)
260 tortoise = XCDR (tortoise);
263 return make_int (len);
266 /*** string functions. ***/
268 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
269 Return t if two strings have identical contents.
270 Case is significant. Text properties are ignored.
271 \(Under XEmacs, `equal' also ignores text properties and extents in
272 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
273 `equal' is the same as in XEmacs, in that respect.)
274 Symbols are also allowed; their print names are used instead.
279 Lisp_String *p1, *p2;
282 p1 = XSYMBOL (s1)->name;
290 p2 = XSYMBOL (s2)->name;
297 return (((len = string_length (p1)) == string_length (p2)) &&
298 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
302 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
303 Return t if first arg string is less than second in lexicographic order.
304 If I18N2 support (but not Mule support) was compiled in, ordering is
305 determined by the locale. (Case is significant for the default C locale.)
306 In all other cases, comparison is simply done on a character-by-
307 character basis using the numeric value of a character. (Note that
308 this may not produce particularly meaningful results under Mule if
309 characters from different charsets are being compared.)
311 Symbols are also allowed; their print names are used instead.
313 The reason that the I18N2 locale-specific collation is not used under
314 Mule is that the locale model of internationalization does not handle
315 multiple charsets and thus has no hope of working properly under Mule.
316 What we really should do is create a collation table over all built-in
317 charsets. This is extremely difficult to do from scratch, however.
319 Unicode is a good first step towards solving this problem. In fact,
320 it is quite likely that a collation table exists (or will exist) for
321 Unicode. When Unicode support is added to XEmacs/Mule, this problem
326 Lisp_String *p1, *p2;
331 p1 = XSYMBOL (s1)->name;
339 p2 = XSYMBOL (s2)->name;
346 end = string_char_length (p1);
347 len2 = string_char_length (p2);
351 #if defined (I18N2) && !defined (MULE)
352 /* There is no hope of this working under Mule. Even if we converted
353 the data into an external format so that strcoll() processed it
354 properly, it would still not work because strcoll() does not
355 handle multiple locales. This is the fundamental flaw in the
358 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
359 /* Compare strings using collation order of locale. */
360 /* Need to be tricky to handle embedded nulls. */
362 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
364 int val = strcoll ((char *) string_data (p1) + i,
365 (char *) string_data (p2) + i);
372 #else /* not I18N2, or MULE */
374 Bufbyte *ptr1 = string_data (p1);
375 Bufbyte *ptr2 = string_data (p2);
377 /* #### It is not really necessary to do this: We could compare
378 byte-by-byte and still get a reasonable comparison, since this
379 would compare characters with a charset in the same way. With
380 a little rearrangement of the leading bytes, we could make most
381 inter-charset comparisons work out the same, too; even if some
382 don't, this is not a big deal because inter-charset comparisons
383 aren't really well-defined anyway. */
384 for (i = 0; i < end; i++)
386 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
387 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
392 #endif /* not I18N2, or MULE */
393 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
394 won't work right in I18N2 case */
395 return end < len2 ? Qt : Qnil;
398 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
399 Return STRING's tick counter, incremented for each change to the string.
400 Each string has a tick counter which is incremented each time the contents
401 of the string are changed (e.g. with `aset'). It wraps around occasionally.
407 CHECK_STRING (string);
408 s = XSTRING (string);
409 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
410 return XCAR (s->plist);
416 bump_string_modiff (Lisp_Object str)
418 Lisp_String *s = XSTRING (str);
419 Lisp_Object *ptr = &s->plist;
422 /* #### remove the `string-translatable' property from the string,
425 /* skip over extent info if it's there */
426 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
428 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
429 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
431 *ptr = Fcons (make_int (1), *ptr);
435 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
436 static Lisp_Object concat (int nargs, Lisp_Object *args,
437 enum concat_target_type target_type,
441 concat2 (Lisp_Object s1, Lisp_Object s2)
446 return concat (2, args, c_string, 0);
450 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
456 return concat (3, args, c_string, 0);
460 vconcat2 (Lisp_Object s1, Lisp_Object s2)
465 return concat (2, args, c_vector, 0);
469 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
475 return concat (3, args, c_vector, 0);
478 DEFUN ("append", Fappend, 0, MANY, 0, /*
479 Concatenate all the arguments and make the result a list.
480 The result is a list whose elements are the elements of all the arguments.
481 Each argument may be a list, vector, bit vector, or string.
482 The last argument is not copied, just used as the tail of the new list.
485 (int nargs, Lisp_Object *args))
487 return concat (nargs, args, c_cons, 1);
490 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
491 Concatenate all the arguments and make the result a string.
492 The result is a string whose elements are the elements of all the arguments.
493 Each argument may be a string or a list or vector of characters.
495 As of XEmacs 21.0, this function does NOT accept individual integers
496 as arguments. Old code that relies on, for example, (concat "foo" 50)
497 returning "foo50" will fail. To fix such code, either apply
498 `int-to-string' to the integer argument, or use `format'.
500 (int nargs, Lisp_Object *args))
502 return concat (nargs, args, c_string, 0);
505 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
506 Concatenate all the arguments and make the result a vector.
507 The result is a vector whose elements are the elements of all the arguments.
508 Each argument may be a list, vector, bit vector, or string.
510 (int nargs, Lisp_Object *args))
512 return concat (nargs, args, c_vector, 0);
515 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
516 Concatenate all the arguments and make the result a bit vector.
517 The result is a bit vector whose elements are the elements of all the
518 arguments. Each argument may be a list, vector, bit vector, or string.
520 (int nargs, Lisp_Object *args))
522 return concat (nargs, args, c_bit_vector, 0);
525 /* Copy a (possibly dotted) list. LIST must be a cons.
526 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
528 copy_list (Lisp_Object list)
530 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
531 Lisp_Object last = list_copy;
532 Lisp_Object hare, tortoise;
535 for (tortoise = hare = XCDR (list), len = 1;
537 hare = XCDR (hare), len++)
539 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
542 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
545 tortoise = XCDR (tortoise);
546 if (EQ (tortoise, hare))
547 signal_circular_list_error (list);
553 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
554 Return a copy of list LIST, which may be a dotted list.
555 The elements of LIST are not copied; they are shared
561 if (NILP (list)) return list;
562 if (CONSP (list)) return copy_list (list);
564 list = wrong_type_argument (Qlistp, list);
568 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
569 Return a copy of list, vector, bit vector or string SEQUENCE.
570 The elements of a list or vector are not copied; they are shared
571 with the original. SEQUENCE may be a dotted list.
576 if (NILP (sequence)) return sequence;
577 if (CONSP (sequence)) return copy_list (sequence);
578 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
579 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
580 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
582 check_losing_bytecode ("copy-sequence", sequence);
583 sequence = wrong_type_argument (Qsequencep, sequence);
587 struct merge_string_extents_struct
590 Bytecount entry_offset;
591 Bytecount entry_length;
595 concat (int nargs, Lisp_Object *args,
596 enum concat_target_type target_type,
600 Lisp_Object tail = Qnil;
603 Lisp_Object last_tail;
605 struct merge_string_extents_struct *args_mse = 0;
606 Bufbyte *string_result = 0;
607 Bufbyte *string_result_ptr = 0;
610 /* The modus operandi in Emacs is "caller gc-protects args".
611 However, concat is called many times in Emacs on freshly
612 created stuff. So we help those callers out by protecting
613 the args ourselves to save them a lot of temporary-variable
617 gcpro1.nvars = nargs;
620 /* #### if the result is a string and any of the strings have a string
621 for the `string-translatable' property, then concat should also
622 concat the args but use the `string-translatable' strings, and store
623 the result in the returned string's `string-translatable' property. */
625 if (target_type == c_string)
626 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
628 /* In append, the last arg isn't treated like the others */
629 if (last_special && nargs > 0)
632 last_tail = args[nargs];
637 /* Check and coerce the arguments. */
638 for (argnum = 0; argnum < nargs; argnum++)
640 Lisp_Object seq = args[argnum];
643 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
645 #ifdef LOSING_BYTECODE
646 else if (COMPILED_FUNCTIONP (seq))
647 /* Urk! We allow this, for "compatibility"... */
650 #if 0 /* removed for XEmacs 21 */
652 /* This is too revolting to think about but maintains
653 compatibility with FSF (and lots and lots of old code). */
654 args[argnum] = Fnumber_to_string (seq);
658 check_losing_bytecode ("concat", seq);
659 args[argnum] = wrong_type_argument (Qsequencep, seq);
665 args_mse[argnum].string = seq;
667 args_mse[argnum].string = Qnil;
672 /* Charcount is a misnomer here as we might be dealing with the
673 length of a vector or list, but emphasizes that we're not dealing
674 with Bytecounts in strings */
675 Charcount total_length;
677 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
679 #ifdef LOSING_BYTECODE
680 Charcount thislen = length_with_bytecode_hack (args[argnum]);
682 Charcount thislen = XINT (Flength (args[argnum]));
684 total_length += thislen;
690 if (total_length == 0)
691 /* In append, if all but last arg are nil, return last arg */
692 RETURN_UNGCPRO (last_tail);
693 val = Fmake_list (make_int (total_length), Qnil);
696 val = make_vector (total_length, Qnil);
699 val = make_bit_vector (total_length, Qzero);
702 /* We don't make the string yet because we don't know the
703 actual number of bytes. This loop was formerly written
704 to call Fmake_string() here and then call set_string_char()
705 for each char. This seems logical enough but is waaaaaaaay
706 slow -- set_string_char() has to scan the whole string up
707 to the place where the substitution is called for in order
708 to find the place to change, and may have to do some
709 realloc()ing in order to make the char fit properly.
712 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
713 string_result_ptr = string_result;
722 tail = val, toindex = -1; /* -1 in toindex is flag we are
729 for (argnum = 0; argnum < nargs; argnum++)
731 Charcount thisleni = 0;
732 Charcount thisindex = 0;
733 Lisp_Object seq = args[argnum];
734 Bufbyte *string_source_ptr = 0;
735 Bufbyte *string_prev_result_ptr = string_result_ptr;
739 #ifdef LOSING_BYTECODE
740 thisleni = length_with_bytecode_hack (seq);
742 thisleni = XINT (Flength (seq));
746 string_source_ptr = XSTRING_DATA (seq);
752 /* We've come to the end of this arg, so exit. */
756 /* Fetch next element of `seq' arg into `elt' */
764 if (thisindex >= thisleni)
769 elt = make_char (charptr_emchar (string_source_ptr));
770 INC_CHARPTR (string_source_ptr);
772 else if (VECTORP (seq))
773 elt = XVECTOR_DATA (seq)[thisindex];
774 else if (BIT_VECTORP (seq))
775 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
778 elt = Felt (seq, make_int (thisindex));
782 /* Store into result */
785 /* toindex negative means we are making a list */
790 else if (VECTORP (val))
791 XVECTOR_DATA (val)[toindex++] = elt;
792 else if (BIT_VECTORP (val))
795 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
799 CHECK_CHAR_COERCE_INT (elt);
800 string_result_ptr += set_charptr_emchar (string_result_ptr,
806 args_mse[argnum].entry_offset =
807 string_prev_result_ptr - string_result;
808 args_mse[argnum].entry_length =
809 string_result_ptr - string_prev_result_ptr;
813 /* Now we finally make the string. */
814 if (target_type == c_string)
816 val = make_string (string_result, string_result_ptr - string_result);
817 for (argnum = 0; argnum < nargs; argnum++)
819 if (STRINGP (args_mse[argnum].string))
820 copy_string_extents (val, args_mse[argnum].string,
821 args_mse[argnum].entry_offset, 0,
822 args_mse[argnum].entry_length);
827 XCDR (prev) = last_tail;
829 RETURN_UNGCPRO (val);
832 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
833 Return a copy of ALIST.
834 This is an alist which represents the same mapping from objects to objects,
835 but does not share the alist structure with ALIST.
836 The objects mapped (cars and cdrs of elements of the alist)
838 Elements of ALIST that are not conses are also shared.
848 alist = concat (1, &alist, c_cons, 0);
849 for (tail = alist; CONSP (tail); tail = XCDR (tail))
851 Lisp_Object car = XCAR (tail);
854 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
859 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
860 Return a copy of a list and substructures.
861 The argument is copied, and any lists contained within it are copied
862 recursively. Circularities and shared substructures are not preserved.
863 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
871 rest = arg = Fcopy_sequence (arg);
874 Lisp_Object elt = XCAR (rest);
876 if (CONSP (elt) || VECTORP (elt))
877 XCAR (rest) = Fcopy_tree (elt, vecp);
878 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
879 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
883 else if (VECTORP (arg) && ! NILP (vecp))
885 int i = XVECTOR_LENGTH (arg);
887 arg = Fcopy_sequence (arg);
888 for (j = 0; j < i; j++)
890 Lisp_Object elt = XVECTOR_DATA (arg) [j];
892 if (CONSP (elt) || VECTORP (elt))
893 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
899 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
900 Return a substring of STRING, starting at index FROM and ending before TO.
901 TO may be nil or omitted; then the substring runs to the end of STRING.
902 If FROM or TO is negative, it counts from the end.
903 Relevant parts of the string-extent-data are copied in the new string.
907 Charcount ccfr, ccto;
911 CHECK_STRING (string);
913 get_string_range_char (string, from, to, &ccfr, &ccto,
914 GB_HISTORICAL_STRING_BEHAVIOR);
915 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
916 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
917 val = make_string (XSTRING_DATA (string) + bfr, blen);
918 /* Copy any applicable extent information into the new string: */
919 copy_string_extents (val, string, 0, bfr, blen);
923 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
924 Return the subsequence of SEQUENCE starting at START and ending before END.
925 END may be omitted; then the subsequence runs to the end of SEQUENCE.
926 If START or END is negative, it counts from the end.
927 The returned subsequence is always of the same type as SEQUENCE.
928 If SEQUENCE is a string, relevant parts of the string-extent-data
929 are copied to the new string.
931 (sequence, start, end))
935 if (STRINGP (sequence))
936 return Fsubstring (sequence, start, end);
938 len = XINT (Flength (sequence));
955 if (!(0 <= s && s <= e && e <= len))
956 args_out_of_range_3 (sequence, make_int (s), make_int (e));
958 if (VECTORP (sequence))
960 Lisp_Object result = make_vector (e - s, Qnil);
962 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
963 Lisp_Object *out_elts = XVECTOR_DATA (result);
965 for (i = s; i < e; i++)
966 out_elts[i - s] = in_elts[i];
969 else if (LISTP (sequence))
971 Lisp_Object result = Qnil;
974 sequence = Fnthcdr (make_int (s), sequence);
976 for (i = s; i < e; i++)
978 result = Fcons (Fcar (sequence), result);
979 sequence = Fcdr (sequence);
982 return Fnreverse (result);
984 else if (BIT_VECTORP (sequence))
986 Lisp_Object result = make_bit_vector (e - s, Qzero);
989 for (i = s; i < e; i++)
990 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
991 bit_vector_bit (XBIT_VECTOR (sequence), i));
995 abort (); /* unreachable, since Flength (sequence) did not get an error */
999 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1000 Take cdr N times on LIST, and return the result.
1005 REGISTER Lisp_Object tail = list;
1007 for (i = XINT (n); i; i--)
1011 else if (NILP (tail))
1015 tail = wrong_type_argument (Qlistp, tail);
1022 DEFUN ("nth", Fnth, 2, 2, 0, /*
1023 Return the Nth element of LIST.
1024 N counts from zero. If LIST is not that long, nil is returned.
1028 return Fcar (Fnthcdr (n, list));
1031 DEFUN ("elt", Felt, 2, 2, 0, /*
1032 Return element of SEQUENCE at index N.
1037 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1038 if (LISTP (sequence))
1040 Lisp_Object tem = Fnthcdr (n, sequence);
1041 /* #### Utterly, completely, fucking disgusting.
1042 * #### The whole point of "elt" is that it operates on
1043 * #### sequences, and does error- (bounds-) checking.
1049 /* This is The Way It Has Always Been. */
1052 /* This is The Way Mly and Cltl2 say It Should Be. */
1053 args_out_of_range (sequence, n);
1056 else if (STRINGP (sequence) ||
1057 VECTORP (sequence) ||
1058 BIT_VECTORP (sequence))
1059 return Faref (sequence, n);
1060 #ifdef LOSING_BYTECODE
1061 else if (COMPILED_FUNCTIONP (sequence))
1063 EMACS_INT idx = XINT (n);
1067 args_out_of_range (sequence, n);
1069 /* Utter perversity */
1071 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1074 case COMPILED_ARGLIST:
1075 return compiled_function_arglist (f);
1076 case COMPILED_INSTRUCTIONS:
1077 return compiled_function_instructions (f);
1078 case COMPILED_CONSTANTS:
1079 return compiled_function_constants (f);
1080 case COMPILED_STACK_DEPTH:
1081 return compiled_function_stack_depth (f);
1082 case COMPILED_DOC_STRING:
1083 return compiled_function_documentation (f);
1084 case COMPILED_DOMAIN:
1085 return compiled_function_domain (f);
1086 case COMPILED_INTERACTIVE:
1087 if (f->flags.interactivep)
1088 return compiled_function_interactive (f);
1089 /* if we return nil, can't tell interactive with no args
1090 from noninteractive. */
1097 #endif /* LOSING_BYTECODE */
1100 check_losing_bytecode ("elt", sequence);
1101 sequence = wrong_type_argument (Qsequencep, sequence);
1106 DEFUN ("last", Flast, 1, 2, 0, /*
1107 Return the tail of list LIST, of length N (default 1).
1108 LIST may be a dotted list, but not a circular list.
1109 Optional argument N must be a non-negative integer.
1110 If N is zero, then the atom that terminates the list is returned.
1111 If N is greater than the length of LIST, then LIST itself is returned.
1115 EMACS_INT int_n, count;
1116 Lisp_Object retval, tortoise, hare;
1128 for (retval = tortoise = hare = list, count = 0;
1131 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1134 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1137 tortoise = XCDR (tortoise);
1138 if (EQ (hare, tortoise))
1139 signal_circular_list_error (list);
1145 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1146 Modify LIST to remove the last N (default 1) elements.
1147 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1164 Lisp_Object last_cons = list;
1166 EXTERNAL_LIST_LOOP_1 (list)
1169 last_cons = XCDR (last_cons);
1175 XCDR (last_cons) = Qnil;
1180 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1181 Return a copy of LIST with the last N (default 1) elements removed.
1182 If LIST has N or fewer elements, nil is returned.
1199 Lisp_Object retval = Qnil;
1200 Lisp_Object tail = list;
1202 EXTERNAL_LIST_LOOP_1 (list)
1206 retval = Fcons (XCAR (tail), retval);
1211 return Fnreverse (retval);
1215 DEFUN ("member", Fmember, 2, 2, 0, /*
1216 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1217 The value is actually the tail of LIST whose car is ELT.
1221 Lisp_Object list_elt, tail;
1222 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1224 if (internal_equal (elt, list_elt, 0))
1230 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1231 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1232 The value is actually the tail of LIST whose car is ELT.
1233 This function is provided only for byte-code compatibility with v19.
1238 Lisp_Object list_elt, tail;
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 Lisp_Object list_elt, tail;
1254 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1256 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1262 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1263 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1264 The value is actually the tail of LIST whose car is ELT.
1265 This function is provided only for byte-code compatibility with v19.
1270 Lisp_Object list_elt, tail;
1271 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1273 if (HACKEQ_UNSAFE (elt, list_elt))
1280 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1282 Lisp_Object list_elt, tail;
1283 LIST_LOOP_3 (list_elt, list, tail)
1285 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1291 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1292 Return non-nil if KEY is `equal' to the car of an element of LIST.
1293 The value is actually the element of LIST whose car equals KEY.
1297 /* This function can GC. */
1298 Lisp_Object elt, elt_car, elt_cdr;
1299 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1301 if (internal_equal (key, elt_car, 0))
1307 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1308 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1309 The value is actually the element of LIST whose car equals KEY.
1313 /* This function can GC. */
1314 Lisp_Object elt, elt_car, elt_cdr;
1315 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1317 if (internal_old_equal (key, elt_car, 0))
1324 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1326 int speccount = specpdl_depth ();
1327 specbind (Qinhibit_quit, Qt);
1328 return unbind_to (speccount, Fassoc (key, list));
1331 DEFUN ("assq", Fassq, 2, 2, 0, /*
1332 Return non-nil if KEY is `eq' to the car of an element of LIST.
1333 The value is actually the element of LIST whose car is KEY.
1334 Elements of LIST that are not conses are ignored.
1338 Lisp_Object elt, elt_car, elt_cdr;
1339 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1341 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1347 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1348 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1349 The value is actually the element of LIST whose car is KEY.
1350 Elements of LIST that are not conses are ignored.
1351 This function is provided only for byte-code compatibility with v19.
1356 Lisp_Object elt, elt_car, elt_cdr;
1357 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1359 if (HACKEQ_UNSAFE (key, elt_car))
1365 /* Like Fassq but never report an error and do not allow quits.
1366 Use only on lists known never to be circular. */
1369 assq_no_quit (Lisp_Object key, Lisp_Object list)
1371 /* This cannot GC. */
1373 LIST_LOOP_2 (elt, list)
1375 Lisp_Object elt_car = XCAR (elt);
1376 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1382 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1383 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1384 The value is actually the element of LIST whose cdr equals KEY.
1388 Lisp_Object elt, elt_car, elt_cdr;
1389 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1391 if (internal_equal (key, elt_cdr, 0))
1397 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1398 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1399 The value is actually the element of LIST whose cdr equals KEY.
1403 Lisp_Object elt, elt_car, elt_cdr;
1404 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1406 if (internal_old_equal (key, elt_cdr, 0))
1412 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1413 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1414 The value is actually the element of LIST whose cdr is KEY.
1418 Lisp_Object elt, elt_car, elt_cdr;
1419 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1421 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1427 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1428 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1429 The value is actually the element of LIST whose cdr is KEY.
1433 Lisp_Object elt, elt_car, elt_cdr;
1434 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1436 if (HACKEQ_UNSAFE (key, elt_cdr))
1442 /* Like Frassq, but caller must ensure that LIST is properly
1443 nil-terminated and ebola-free. */
1445 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1448 LIST_LOOP_2 (elt, list)
1450 Lisp_Object elt_cdr = XCDR (elt);
1451 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1458 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1459 Delete by side effect any occurrences of ELT as a member of LIST.
1460 The modified LIST is returned. Comparison is done with `equal'.
1461 If the first member of LIST is ELT, there is no way to remove it by side
1462 effect; therefore, write `(setq foo (delete element foo))' to be sure
1463 of changing the value of `foo'.
1468 Lisp_Object list_elt;
1469 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1470 (internal_equal (elt, list_elt, 0)));
1474 DEFUN ("old-delete", Fold_delete, 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 `old-equal'.
1477 If the first member of LIST is ELT, there is no way to remove it by side
1478 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1479 of changing the value of `foo'.
1483 Lisp_Object list_elt;
1484 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1485 (internal_old_equal (elt, list_elt, 0)));
1489 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1490 Delete by side effect any occurrences of ELT as a member of LIST.
1491 The modified LIST is returned. Comparison is done with `eq'.
1492 If the first member of LIST is ELT, there is no way to remove it by side
1493 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1494 changing the value of `foo'.
1498 Lisp_Object list_elt;
1499 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1500 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1504 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1505 Delete by side effect any occurrences of ELT as a member of LIST.
1506 The modified LIST is returned. Comparison is done with `old-eq'.
1507 If the first member of LIST is ELT, there is no way to remove it by side
1508 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1509 changing the value of `foo'.
1513 Lisp_Object list_elt;
1514 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1515 (HACKEQ_UNSAFE (elt, list_elt)));
1519 /* Like Fdelq, but caller must ensure that LIST is properly
1520 nil-terminated and ebola-free. */
1523 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1525 Lisp_Object list_elt;
1526 LIST_LOOP_DELETE_IF (list_elt, list,
1527 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1531 /* Be VERY careful with this. This is like delq_no_quit() but
1532 also calls free_cons() on the removed conses. You must be SURE
1533 that no pointers to the freed conses remain around (e.g.
1534 someone else is pointing to part of the list). This function
1535 is useful on internal lists that are used frequently and where
1536 the actual list doesn't escape beyond known code bounds. */
1539 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1541 REGISTER Lisp_Object tail = list;
1542 REGISTER Lisp_Object prev = Qnil;
1544 while (!NILP (tail))
1546 REGISTER Lisp_Object tem = XCAR (tail);
1549 Lisp_Object cons_to_free = tail;
1553 XCDR (prev) = XCDR (tail);
1555 free_cons (XCONS (cons_to_free));
1566 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1567 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1568 The modified LIST is returned. If the first member of LIST has a car
1569 that is `equal' to KEY, there is no way to remove it by side effect;
1570 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1576 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1578 internal_equal (key, XCAR (elt), 0)));
1583 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1585 int speccount = specpdl_depth ();
1586 specbind (Qinhibit_quit, Qt);
1587 return unbind_to (speccount, Fremassoc (key, list));
1590 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1591 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1592 The modified LIST is returned. If the first member of LIST has a car
1593 that is `eq' to KEY, there is no way to remove it by side effect;
1594 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1600 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1602 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1606 /* no quit, no errors; be careful */
1609 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1612 LIST_LOOP_DELETE_IF (elt, list,
1614 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1618 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1619 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1620 The modified LIST is returned. If the first member of LIST has a car
1621 that is `equal' to VALUE, there is no way to remove it by side effect;
1622 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1628 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1630 internal_equal (value, XCDR (elt), 0)));
1634 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1635 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1636 The modified LIST is returned. If the first member of LIST has a car
1637 that is `eq' to VALUE, there is no way to remove it by side effect;
1638 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1644 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1646 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1650 /* Like Fremrassq, fast and unsafe; be careful */
1652 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1655 LIST_LOOP_DELETE_IF (elt, list,
1657 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1661 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1662 Reverse LIST by destructively modifying cdr pointers.
1663 Return the beginning of the reversed list.
1664 Also see: `reverse'.
1668 struct gcpro gcpro1, gcpro2;
1669 REGISTER Lisp_Object prev = Qnil;
1670 REGISTER Lisp_Object tail = list;
1672 /* We gcpro our args; see `nconc' */
1673 GCPRO2 (prev, tail);
1674 while (!NILP (tail))
1676 REGISTER Lisp_Object next;
1677 CONCHECK_CONS (tail);
1687 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1688 Reverse LIST, copying. Return the beginning of the reversed list.
1689 See also the function `nreverse', which is used more often.
1693 Lisp_Object reversed_list = Qnil;
1695 EXTERNAL_LIST_LOOP_2 (elt, list)
1697 reversed_list = Fcons (elt, reversed_list);
1699 return reversed_list;
1702 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1703 Lisp_Object lisp_arg,
1704 int (*pred_fn) (Lisp_Object, Lisp_Object,
1705 Lisp_Object lisp_arg));
1708 list_sort (Lisp_Object list,
1709 Lisp_Object lisp_arg,
1710 int (*pred_fn) (Lisp_Object, Lisp_Object,
1711 Lisp_Object lisp_arg))
1713 struct gcpro gcpro1, gcpro2, gcpro3;
1714 Lisp_Object back, tem;
1715 Lisp_Object front = list;
1716 Lisp_Object len = Flength (list);
1717 int length = XINT (len);
1722 XSETINT (len, (length / 2) - 1);
1723 tem = Fnthcdr (len, list);
1725 Fsetcdr (tem, Qnil);
1727 GCPRO3 (front, back, lisp_arg);
1728 front = list_sort (front, lisp_arg, pred_fn);
1729 back = list_sort (back, lisp_arg, pred_fn);
1731 return list_merge (front, back, lisp_arg, pred_fn);
1736 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1741 /* prevents the GC from happening in call2 */
1742 int speccount = specpdl_depth ();
1743 /* Emacs' GC doesn't actually relocate pointers, so this probably
1744 isn't strictly necessary */
1745 record_unwind_protect (restore_gc_inhibit,
1746 make_int (gc_currently_forbidden));
1747 gc_currently_forbidden = 1;
1748 tmp = call2 (pred, obj1, obj2);
1749 unbind_to (speccount, Qnil);
1757 DEFUN ("sort", Fsort, 2, 2, 0, /*
1758 Sort LIST, stably, comparing elements using PREDICATE.
1759 Returns the sorted list. LIST is modified by side effects.
1760 PREDICATE is called with two elements of LIST, and should return T
1761 if the first element is "less" than the second.
1765 return list_sort (list, pred, merge_pred_function);
1769 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1772 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1777 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1778 Lisp_Object lisp_arg,
1779 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1785 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1792 /* It is sufficient to protect org_l1 and org_l2.
1793 When l1 and l2 are updated, we copy the new values
1794 back into the org_ vars. */
1796 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1817 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1832 Fsetcdr (tail, tem);
1838 /************************************************************************/
1839 /* property-list functions */
1840 /************************************************************************/
1842 /* For properties of text, we need to do order-insensitive comparison of
1843 plists. That is, we need to compare two plists such that they are the
1844 same if they have the same set of keys, and equivalent values.
1845 So (a 1 b 2) would be equal to (b 2 a 1).
1847 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1848 LAXP means use `equal' for comparisons.
1851 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1852 int laxp, int depth)
1854 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1855 int la, lb, m, i, fill;
1856 Lisp_Object *keys, *vals;
1860 if (NILP (a) && NILP (b))
1863 Fcheck_valid_plist (a);
1864 Fcheck_valid_plist (b);
1866 la = XINT (Flength (a));
1867 lb = XINT (Flength (b));
1868 m = (la > lb ? la : lb);
1870 keys = alloca_array (Lisp_Object, m);
1871 vals = alloca_array (Lisp_Object, m);
1872 flags = alloca_array (char, m);
1874 /* First extract the pairs from A. */
1875 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1877 Lisp_Object k = XCAR (rest);
1878 Lisp_Object v = XCAR (XCDR (rest));
1879 /* Maybe be Ebolified. */
1880 if (nil_means_not_present && NILP (v)) continue;
1886 /* Now iterate over B, and stop if we find something that's not in A,
1887 or that doesn't match. As we match, mark them. */
1888 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1890 Lisp_Object k = XCAR (rest);
1891 Lisp_Object v = XCAR (XCDR (rest));
1892 /* Maybe be Ebolified. */
1893 if (nil_means_not_present && NILP (v)) continue;
1894 for (i = 0; i < fill; i++)
1896 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1899 /* We narrowly escaped being Ebolified here. */
1900 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1901 : !internal_equal (v, vals [i], depth))
1902 /* a property in B has a different value than in A */
1909 /* there are some properties in B that are not in A */
1912 /* Now check to see that all the properties in A were also in B */
1913 for (i = 0; i < fill; i++)
1924 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1925 Return non-nil if property lists A and B are `eq'.
1926 A property list is an alternating list of keywords and values.
1927 This function does order-insensitive comparisons of the property lists:
1928 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1929 Comparison between values is done using `eq'. See also `plists-equal'.
1930 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1931 a nil value is ignored. This feature is a virus that has infected
1932 old Lisp implementations, but should not be used except for backward
1935 (a, b, nil_means_not_present))
1937 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1941 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1942 Return non-nil if property lists A and B are `equal'.
1943 A property list is an alternating list of keywords and values. This
1944 function does order-insensitive comparisons of the property lists: For
1945 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1946 Comparison between values is done using `equal'. See also `plists-eq'.
1947 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1948 a nil value is ignored. This feature is a virus that has infected
1949 old Lisp implementations, but should not be used except for backward
1952 (a, b, nil_means_not_present))
1954 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1959 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1960 Return non-nil if lax property lists A and B are `eq'.
1961 A property list is an alternating list of keywords and values.
1962 This function does order-insensitive comparisons of the property lists:
1963 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1964 Comparison between values is done using `eq'. See also `plists-equal'.
1965 A lax property list is like a regular one except that comparisons between
1966 keywords is done using `equal' instead of `eq'.
1967 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1968 a nil value is ignored. This feature is a virus that has infected
1969 old Lisp implementations, but should not be used except for backward
1972 (a, b, nil_means_not_present))
1974 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1978 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1979 Return non-nil if lax property lists A and B are `equal'.
1980 A property list is an alternating list of keywords and values. This
1981 function does order-insensitive comparisons of the property lists: For
1982 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1983 Comparison between values is done using `equal'. See also `plists-eq'.
1984 A lax property list is like a regular one except that comparisons between
1985 keywords is done using `equal' instead of `eq'.
1986 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1987 a nil value is ignored. This feature is a virus that has infected
1988 old Lisp implementations, but should not be used except for backward
1991 (a, b, nil_means_not_present))
1993 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1997 /* Return the value associated with key PROPERTY in property list PLIST.
1998 Return nil if key not found. This function is used for internal
1999 property lists that cannot be directly manipulated by the user.
2003 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2007 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2009 if (EQ (XCAR (tail), property))
2010 return XCAR (XCDR (tail));
2016 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2017 internal_plist_get(). */
2020 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2025 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2027 if (EQ (XCAR (tail), property))
2029 XCAR (XCDR (tail)) = value;
2034 *plist = Fcons (property, Fcons (value, *plist));
2038 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2040 Lisp_Object tail, prev;
2042 for (tail = *plist, prev = Qnil;
2044 tail = XCDR (XCDR (tail)))
2046 if (EQ (XCAR (tail), property))
2049 *plist = XCDR (XCDR (tail));
2051 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2061 /* Called on a malformed property list. BADPLACE should be some
2062 place where truncating will form a good list -- i.e. we shouldn't
2063 result in a list with an odd length. */
2066 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2068 if (ERRB_EQ (errb, ERROR_ME))
2069 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2072 if (ERRB_EQ (errb, ERROR_ME_WARN))
2074 warn_when_safe_lispobj
2077 ("Malformed property list -- list has been truncated"),
2085 /* Called on a circular property list. BADPLACE should be some place
2086 where truncating will result in an even-length list, as above.
2087 If doesn't particularly matter where we truncate -- anywhere we
2088 truncate along the entire list will break the circularity, because
2089 it will create a terminus and the list currently doesn't have one.
2093 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2095 if (ERRB_EQ (errb, ERROR_ME))
2096 /* #### Eek, this will probably result in another error
2097 when PLIST is printed out */
2098 return Fsignal (Qcircular_property_list, list1 (*plist));
2101 if (ERRB_EQ (errb, ERROR_ME_WARN))
2103 warn_when_safe_lispobj
2106 ("Circular property list -- list has been truncated"),
2114 /* Advance the tortoise pointer by two (one iteration of a property-list
2115 loop) and the hare pointer by four and verify that no malformations
2116 or circularities exist. If so, return zero and store a value into
2117 RETVAL that should be returned by the calling function. Otherwise,
2118 return 1. See external_plist_get().
2122 advance_plist_pointers (Lisp_Object *plist,
2123 Lisp_Object **tortoise, Lisp_Object **hare,
2124 Error_behavior errb, Lisp_Object *retval)
2127 Lisp_Object *tortsave = *tortoise;
2129 /* Note that our "fixing" may be more brutal than necessary,
2130 but it's the user's own problem, not ours, if they went in and
2131 manually fucked up a plist. */
2133 for (i = 0; i < 2; i++)
2135 /* This is a standard iteration of a defensive-loop-checking
2136 loop. We just do it twice because we want to advance past
2137 both the property and its value.
2139 If the pointer indirection is confusing you, remember that
2140 one level of indirection on the hare and tortoise pointers
2141 is only due to pass-by-reference for this function. The other
2142 level is so that the plist can be fixed in place. */
2144 /* When we reach the end of a well-formed plist, **HARE is
2145 nil. In that case, we don't do anything at all except
2146 advance TORTOISE by one. Otherwise, we advance HARE
2147 by two (making sure it's OK to do so), then advance
2148 TORTOISE by one (it will always be OK to do so because
2149 the HARE is always ahead of the TORTOISE and will have
2150 already verified the path), then make sure TORTOISE and
2151 HARE don't contain the same non-nil object -- if the
2152 TORTOISE and the HARE ever meet, then obviously we're
2153 in a circularity, and if we're in a circularity, then
2154 the TORTOISE and the HARE can't cross paths without
2155 meeting, since the HARE only gains one step over the
2156 TORTOISE per iteration. */
2160 Lisp_Object *haresave = *hare;
2161 if (!CONSP (**hare))
2163 *retval = bad_bad_bunny (plist, haresave, errb);
2166 *hare = &XCDR (**hare);
2167 /* In a non-plist, we'd check here for a nil value for
2168 **HARE, which is OK (it just means the list has an
2169 odd number of elements). In a plist, it's not OK
2170 for the list to have an odd number of elements. */
2171 if (!CONSP (**hare))
2173 *retval = bad_bad_bunny (plist, haresave, errb);
2176 *hare = &XCDR (**hare);
2179 *tortoise = &XCDR (**tortoise);
2180 if (!NILP (**hare) && EQ (**tortoise, **hare))
2182 *retval = bad_bad_turtle (plist, tortsave, errb);
2190 /* Return the value of PROPERTY from PLIST, or Qunbound if
2191 property is not on the list.
2193 PLIST is a Lisp-accessible property list, meaning that it
2194 has to be checked for malformations and circularities.
2196 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2197 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2198 on finding a malformation or a circularity, it issues a warning and
2199 attempts to silently fix the problem.
2201 A pointer to PLIST is passed in so that PLIST can be successfully
2202 "fixed" even if the error is at the beginning of the plist. */
2205 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2206 int laxp, Error_behavior errb)
2208 Lisp_Object *tortoise = plist;
2209 Lisp_Object *hare = plist;
2211 while (!NILP (*tortoise))
2213 Lisp_Object *tortsave = tortoise;
2216 /* We do the standard tortoise/hare march. We isolate the
2217 grungy stuff to do this in advance_plist_pointers(), though.
2218 To us, all this function does is advance the tortoise
2219 pointer by two and the hare pointer by four and make sure
2220 everything's OK. We first advance the pointers and then
2221 check if a property matched; this ensures that our
2222 check for a matching property is safe. */
2224 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2227 if (!laxp ? EQ (XCAR (*tortsave), property)
2228 : internal_equal (XCAR (*tortsave), property, 0))
2229 return XCAR (XCDR (*tortsave));
2235 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2236 malformed or circular plist. Analogous to external_plist_get(). */
2239 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2240 Lisp_Object value, int laxp, Error_behavior errb)
2242 Lisp_Object *tortoise = plist;
2243 Lisp_Object *hare = plist;
2245 while (!NILP (*tortoise))
2247 Lisp_Object *tortsave = tortoise;
2251 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2254 if (!laxp ? EQ (XCAR (*tortsave), property)
2255 : internal_equal (XCAR (*tortsave), property, 0))
2257 XCAR (XCDR (*tortsave)) = value;
2262 *plist = Fcons (property, Fcons (value, *plist));
2266 external_remprop (Lisp_Object *plist, Lisp_Object property,
2267 int laxp, Error_behavior errb)
2269 Lisp_Object *tortoise = plist;
2270 Lisp_Object *hare = plist;
2272 while (!NILP (*tortoise))
2274 Lisp_Object *tortsave = tortoise;
2278 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2281 if (!laxp ? EQ (XCAR (*tortsave), property)
2282 : internal_equal (XCAR (*tortsave), property, 0))
2284 /* Now you see why it's so convenient to have that level
2286 *tortsave = XCDR (XCDR (*tortsave));
2294 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2295 Extract a value from a property list.
2296 PLIST is a property list, which is a list of the form
2297 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2298 corresponding to the given PROP, or DEFAULT if PROP is not
2299 one of the properties on the list.
2301 (plist, prop, default_))
2303 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2304 return UNBOUNDP (val) ? default_ : val;
2307 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2308 Change value in PLIST of PROP to VAL.
2309 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2310 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2311 If PROP is already a property on the list, its value is set to VAL,
2312 otherwise the new PROP VAL pair is added. The new plist is returned;
2313 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2314 The PLIST is modified by side effects.
2318 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2322 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2323 Remove from PLIST the property PROP and its value.
2324 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2325 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2326 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2327 the new value. The PLIST is modified by side effects.
2331 external_remprop (&plist, prop, 0, ERROR_ME);
2335 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2336 Return t if PROP has a value specified in PLIST.
2340 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2341 return UNBOUNDP (val) ? Qnil : Qt;
2344 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2345 Given a plist, signal an error if there is anything wrong with it.
2346 This means that it's a malformed or circular plist.
2350 Lisp_Object *tortoise;
2356 while (!NILP (*tortoise))
2361 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2369 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2370 Given a plist, return non-nil if its format is correct.
2371 If it returns nil, `check-valid-plist' will signal an error when given
2372 the plist; that means it's a malformed or circular plist.
2376 Lisp_Object *tortoise;
2381 while (!NILP (*tortoise))
2386 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2394 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2395 Destructively remove any duplicate entries from a plist.
2396 In such cases, the first entry applies.
2398 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2399 a nil value is removed. This feature is a virus that has infected
2400 old Lisp implementations, but should not be used except for backward
2403 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2404 return value may not be EQ to the passed-in value, so make sure to
2405 `setq' the value back into where it came from.
2407 (plist, nil_means_not_present))
2409 Lisp_Object head = plist;
2411 Fcheck_valid_plist (plist);
2413 while (!NILP (plist))
2415 Lisp_Object prop = Fcar (plist);
2416 Lisp_Object next = Fcdr (plist);
2418 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2419 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2421 if (EQ (head, plist))
2423 plist = Fcdr (next);
2426 /* external_remprop returns 1 if it removed any property.
2427 We have to loop till it didn't remove anything, in case
2428 the property occurs many times. */
2429 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2431 plist = Fcdr (next);
2437 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2438 Extract a value from a lax property list.
2440 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2441 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2442 using `equal' instead of `eq'. This function returns the value
2443 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2444 properties on the list.
2446 (lax_plist, prop, default_))
2448 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2449 return UNBOUNDP (val) ? default_ : val;
2452 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2453 Change value in LAX-PLIST of PROP to VAL.
2454 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2455 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2456 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2457 any object. If PROP is already a property on the list, its value is
2458 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2459 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2460 use the new value. The LAX-PLIST is modified by side effects.
2462 (lax_plist, prop, val))
2464 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2468 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2469 Remove from LAX-PLIST the property PROP and its value.
2470 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2471 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2472 using `equal' instead of `eq'. PROP is usually a symbol. The new
2473 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2474 sure to use the new value. The LAX-PLIST is modified by side effects.
2478 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2482 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2483 Return t if PROP has a value specified in LAX-PLIST.
2484 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2485 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2486 using `equal' instead of `eq'.
2490 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2493 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2494 Destructively remove any duplicate entries from a lax plist.
2495 In such cases, the first entry applies.
2497 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2498 a nil value is removed. This feature is a virus that has infected
2499 old Lisp implementations, but should not be used except for backward
2502 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2503 return value may not be EQ to the passed-in value, so make sure to
2504 `setq' the value back into where it came from.
2506 (lax_plist, nil_means_not_present))
2508 Lisp_Object head = lax_plist;
2510 Fcheck_valid_plist (lax_plist);
2512 while (!NILP (lax_plist))
2514 Lisp_Object prop = Fcar (lax_plist);
2515 Lisp_Object next = Fcdr (lax_plist);
2517 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2518 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2520 if (EQ (head, lax_plist))
2522 lax_plist = Fcdr (next);
2525 /* external_remprop returns 1 if it removed any property.
2526 We have to loop till it didn't remove anything, in case
2527 the property occurs many times. */
2528 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2530 lax_plist = Fcdr (next);
2536 /* In C because the frame props stuff uses it */
2538 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2539 Convert association list ALIST into the equivalent property-list form.
2540 The plist is returned. This converts from
2542 \((a . 1) (b . 2) (c . 3))
2548 The original alist is destroyed in the process of constructing the plist.
2549 See also `alist-to-plist'.
2553 Lisp_Object head = alist;
2554 while (!NILP (alist))
2556 /* remember the alist element. */
2557 Lisp_Object el = Fcar (alist);
2559 Fsetcar (alist, Fcar (el));
2560 Fsetcar (el, Fcdr (el));
2561 Fsetcdr (el, Fcdr (alist));
2562 Fsetcdr (alist, el);
2563 alist = Fcdr (Fcdr (alist));
2569 DEFUN ("get", Fget, 2, 3, 0, /*
2570 Return the value of OBJECT's PROPERTY property.
2571 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2572 If there is no such property, return optional third arg DEFAULT
2573 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2574 face, or glyph. See also `put', `remprop', and `object-plist'.
2576 (object, property, default_))
2578 /* Various places in emacs call Fget() and expect it not to quit,
2582 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2583 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2585 signal_simple_error ("Object type has no properties", object);
2587 return UNBOUNDP (val) ? default_ : val;
2590 DEFUN ("put", Fput, 3, 3, 0, /*
2591 Set OBJECT's PROPERTY to VALUE.
2592 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2593 OBJECT can be a symbol, face, extent, or string.
2594 For a string, no properties currently have predefined meanings.
2595 For the predefined properties for extents, see `set-extent-property'.
2596 For the predefined properties for faces, see `set-face-property'.
2597 See also `get', `remprop', and `object-plist'.
2599 (object, property, value))
2601 CHECK_LISP_WRITEABLE (object);
2603 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2605 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2606 (object, property, value))
2607 signal_simple_error ("Can't set property on object", property);
2610 signal_simple_error ("Object type has no settable properties", object);
2615 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2616 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2617 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2618 if the property list was actually modified (i.e. if PROPERTY was present
2619 in the property list). See also `get', `put', and `object-plist'.
2625 CHECK_LISP_WRITEABLE (object);
2627 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2629 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2631 signal_simple_error ("Can't remove property from object", property);
2634 signal_simple_error ("Object type has no removable properties", object);
2636 return ret ? Qt : Qnil;
2639 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2640 Return a property list of OBJECT's properties.
2641 For a symbol, this is equivalent to `symbol-plist'.
2642 OBJECT can be a symbol, string, extent, face, or glyph.
2643 Do not modify the returned property list directly;
2644 this may or may not have the desired effects. Use `put' instead.
2648 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2649 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2651 signal_simple_error ("Object type has no properties", object);
2658 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2661 error ("Stack overflow in equal");
2663 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2665 /* Note that (equal 20 20.0) should be nil */
2666 if (XTYPE (obj1) != XTYPE (obj2))
2668 if (LRECORDP (obj1))
2670 const struct lrecord_implementation
2671 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2672 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2674 return (imp1 == imp2) &&
2675 /* EQ-ness of the objects was noticed above */
2676 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2682 /* Note that we may be calling sub-objects that will use
2683 internal_equal() (instead of internal_old_equal()). Oh well.
2684 We will get an Ebola note if there's any possibility of confusion,
2685 but that seems unlikely. */
2688 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2691 error ("Stack overflow in equal");
2693 if (HACKEQ_UNSAFE (obj1, obj2))
2695 /* Note that (equal 20 20.0) should be nil */
2696 if (XTYPE (obj1) != XTYPE (obj2))
2699 return internal_equal (obj1, obj2, depth);
2702 DEFUN ("equal", Fequal, 2, 2, 0, /*
2703 Return t if two Lisp objects have similar structure and contents.
2704 They must have the same data type.
2705 Conses are compared by comparing the cars and the cdrs.
2706 Vectors and strings are compared element by element.
2707 Numbers are compared by value. Symbols must match exactly.
2711 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2714 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2715 Return t if two Lisp objects have similar structure and contents.
2716 They must have the same data type.
2717 \(Note, however, that an exception is made for characters and integers;
2718 this is known as the "char-int confoundance disease." See `eq' and
2720 This function is provided only for byte-code compatibility with v19.
2725 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2729 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2730 Destructively modify ARRAY by replacing each element with ITEM.
2731 ARRAY is a vector, bit vector, or string.
2736 if (STRINGP (array))
2738 Lisp_String *s = XSTRING (array);
2739 Bytecount old_bytecount = string_length (s);
2740 Bytecount new_bytecount;
2741 Bytecount item_bytecount;
2742 Bufbyte item_buf[MAX_EMCHAR_LEN];
2746 CHECK_CHAR_COERCE_INT (item);
2747 CHECK_LISP_WRITEABLE (array);
2749 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2750 new_bytecount = item_bytecount * string_char_length (s);
2752 resize_string (s, -1, new_bytecount - old_bytecount);
2754 for (p = string_data (s), end = p + new_bytecount;
2756 p += item_bytecount)
2757 memcpy (p, item_buf, item_bytecount);
2760 bump_string_modiff (array);
2762 else if (VECTORP (array))
2764 Lisp_Object *p = XVECTOR_DATA (array);
2765 int len = XVECTOR_LENGTH (array);
2766 CHECK_LISP_WRITEABLE (array);
2770 else if (BIT_VECTORP (array))
2772 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2773 int len = bit_vector_length (v);
2776 CHECK_LISP_WRITEABLE (array);
2779 set_bit_vector_bit (v, len, bit);
2783 array = wrong_type_argument (Qarrayp, array);
2790 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2792 Lisp_Object args[2];
2793 struct gcpro gcpro1;
2800 RETURN_UNGCPRO (bytecode_nconc2 (args));
2804 bytecode_nconc2 (Lisp_Object *args)
2808 if (CONSP (args[0]))
2810 /* (setcdr (last args[0]) args[1]) */
2811 Lisp_Object tortoise, hare;
2814 for (hare = tortoise = args[0], count = 0;
2815 CONSP (XCDR (hare));
2816 hare = XCDR (hare), count++)
2818 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2821 tortoise = XCDR (tortoise);
2822 if (EQ (hare, tortoise))
2823 signal_circular_list_error (args[0]);
2825 XCDR (hare) = args[1];
2828 else if (NILP (args[0]))
2834 args[0] = wrong_type_argument (args[0], Qlistp);
2839 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2840 Concatenate any number of lists by altering them.
2841 Only the last argument is not altered, and need not be a list.
2843 If the first argument is nil, there is no way to modify it by side
2844 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2845 changing the value of `foo'.
2847 (int nargs, Lisp_Object *args))
2850 struct gcpro gcpro1;
2852 /* The modus operandi in Emacs is "caller gc-protects args".
2853 However, nconc (particularly nconc2 ()) is called many times
2854 in Emacs on freshly created stuff (e.g. you see the idiom
2855 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2856 callers out by protecting the args ourselves to save them
2857 a lot of temporary-variable grief. */
2860 gcpro1.nvars = nargs;
2862 while (argnum < nargs)
2869 /* `val' is the first cons, which will be our return value. */
2870 /* `last_cons' will be the cons cell to mutate. */
2871 Lisp_Object last_cons = val;
2872 Lisp_Object tortoise = val;
2874 for (argnum++; argnum < nargs; argnum++)
2876 Lisp_Object next = args[argnum];
2878 if (CONSP (next) || argnum == nargs -1)
2880 /* (setcdr (last val) next) */
2884 CONSP (XCDR (last_cons));
2885 last_cons = XCDR (last_cons), count++)
2887 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2890 tortoise = XCDR (tortoise);
2891 if (EQ (last_cons, tortoise))
2892 signal_circular_list_error (args[argnum-1]);
2894 XCDR (last_cons) = next;
2896 else if (NILP (next))
2902 next = wrong_type_argument (Qlistp, next);
2906 RETURN_UNGCPRO (val);
2908 else if (NILP (val))
2910 else if (argnum == nargs - 1) /* last arg? */
2911 RETURN_UNGCPRO (val);
2914 args[argnum] = wrong_type_argument (Qlistp, val);
2918 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2922 /* This is the guts of several mapping functions.
2923 Apply FUNCTION to each element of SEQUENCE, one by one,
2924 storing the results into elements of VALS, a C vector of Lisp_Objects.
2925 LENI is the length of VALS, which should also be the length of SEQUENCE.
2927 If VALS is a null pointer, do not accumulate the results. */
2930 mapcar1 (size_t leni, Lisp_Object *vals,
2931 Lisp_Object function, Lisp_Object sequence)
2934 Lisp_Object args[2];
2936 struct gcpro gcpro1;
2946 if (LISTP (sequence))
2948 /* A devious `function' could either:
2949 - insert garbage into the list in front of us, causing XCDR to crash
2950 - amputate the list behind us using (setcdr), causing the remaining
2951 elts to lose their GCPRO status.
2953 if (vals != 0) we avoid this by copying the elts into the
2954 `vals' array. By a stroke of luck, `vals' is exactly large
2955 enough to hold the elts left to be traversed as well as the
2956 results computed so far.
2958 if (vals == 0) we don't have any free space available and
2959 don't want to eat up any more stack with alloca().
2960 So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
2964 Lisp_Object *val = vals;
2967 LIST_LOOP_2 (elt, sequence)
2970 gcpro1.nvars = leni;
2972 for (i = 0; i < leni; i++)
2975 vals[i] = Ffuncall (2, args);
2980 Lisp_Object elt, tail;
2981 struct gcpro ngcpro1;
2986 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2996 else if (VECTORP (sequence))
2998 Lisp_Object *objs = XVECTOR_DATA (sequence);
2999 for (i = 0; i < leni; i++)
3002 result = Ffuncall (2, args);
3003 if (vals) vals[gcpro1.nvars++] = result;
3006 else if (STRINGP (sequence))
3008 /* The string data of `sequence' might be relocated during GC. */
3009 Bytecount slen = XSTRING_LENGTH (sequence);
3010 Bufbyte *p = alloca_array (Bufbyte, slen);
3011 Bufbyte *end = p + slen;
3013 memcpy (p, XSTRING_DATA (sequence), slen);
3017 args[1] = make_char (charptr_emchar (p));
3019 result = Ffuncall (2, args);
3020 if (vals) vals[gcpro1.nvars++] = result;
3023 else if (BIT_VECTORP (sequence))
3025 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3026 for (i = 0; i < leni; i++)
3028 args[1] = make_int (bit_vector_bit (v, i));
3029 result = Ffuncall (2, args);
3030 if (vals) vals[gcpro1.nvars++] = result;
3034 abort (); /* unreachable, since Flength (sequence) did not get an error */
3040 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3041 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3042 In between each pair of results, insert SEPARATOR. Thus, using " " as
3043 SEPARATOR results in spaces between the values returned by FUNCTION.
3044 SEQUENCE may be a list, a vector, a bit vector, or a string.
3046 (function, sequence, separator))
3048 size_t len = XINT (Flength (sequence));
3051 int nargs = len + len - 1;
3053 if (len == 0) return build_string ("");
3055 args = alloca_array (Lisp_Object, nargs);
3057 mapcar1 (len, args, function, sequence);
3059 for (i = len - 1; i >= 0; i--)
3060 args[i + i] = args[i];
3062 for (i = 1; i < nargs; i += 2)
3063 args[i] = separator;
3065 return Fconcat (nargs, args);
3068 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3069 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3070 The result is a list of the same length as SEQUENCE.
3071 SEQUENCE may be a list, a vector, a bit vector, or a string.
3073 (function, sequence))
3075 size_t len = XINT (Flength (sequence));
3076 Lisp_Object *args = alloca_array (Lisp_Object, len);
3078 mapcar1 (len, args, function, sequence);
3080 return Flist (len, args);
3083 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3084 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3085 The result is a vector of the same length as SEQUENCE.
3086 SEQUENCE may be a list, a vector, a bit vector, or a string.
3088 (function, sequence))
3090 size_t len = XINT (Flength (sequence));
3091 Lisp_Object result = make_vector (len, Qnil);
3092 struct gcpro gcpro1;
3095 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3101 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3102 Apply FUNCTION to each element of SEQUENCE.
3103 SEQUENCE may be a list, a vector, a bit vector, or a string.
3104 This function is like `mapcar' but does not accumulate the results,
3105 which is more efficient if you do not use the results.
3107 The difference between this and `mapc' is that `mapc' supports all
3108 the spiffy Common Lisp arguments. You should normally use `mapc'.
3110 (function, sequence))
3112 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3118 /* #### this function doesn't belong in this file! */
3120 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3121 Return list of 1 minute, 5 minute and 15 minute load averages.
3122 Each of the three load averages is multiplied by 100,
3123 then converted to integer.
3125 When USE-FLOATS is non-nil, floats will be used instead of integers.
3126 These floats are not multiplied by 100.
3128 If the 5-minute or 15-minute load averages are not available, return a
3129 shortened list, containing only those averages which are available.
3131 On some systems, this won't work due to permissions on /dev/kmem,
3132 in which case you can't use this.
3137 int loads = getloadavg (load_ave, countof (load_ave));
3138 Lisp_Object ret = Qnil;
3141 error ("load-average not implemented for this operating system");
3143 signal_simple_error ("Could not get load-average",
3144 lisp_strerror (errno));
3148 Lisp_Object load = (NILP (use_floats) ?
3149 make_int ((int) (100.0 * load_ave[loads]))
3150 : make_float (load_ave[loads]));
3151 ret = Fcons (load, ret);
3157 Lisp_Object Vfeatures;
3159 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3160 Return non-nil if feature FEXP is present in this Emacs.
3161 Use this to conditionalize execution of lisp code based on the
3162 presence or absence of emacs or environment extensions.
3163 FEXP can be a symbol, a number, or a list.
3164 If it is a symbol, that symbol is looked up in the `features' variable,
3165 and non-nil will be returned if found.
3166 If it is a number, the function will return non-nil if this Emacs
3167 has an equal or greater version number than FEXP.
3168 If it is a list whose car is the symbol `and', it will return
3169 non-nil if all the features in its cdr are non-nil.
3170 If it is a list whose car is the symbol `or', it will return non-nil
3171 if any of the features in its cdr are non-nil.
3172 If it is a list whose car is the symbol `not', it will return
3173 non-nil if the feature is not present.
3178 => ; Non-nil on XEmacs.
3180 (featurep '(and xemacs gnus))
3181 => ; Non-nil on XEmacs with Gnus loaded.
3183 (featurep '(or tty-frames (and emacs 19.30)))
3184 => ; Non-nil if this Emacs supports TTY frames.
3186 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3187 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3189 NOTE: The advanced arguments of this function (anything other than a
3190 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3191 for supporting multiple Emacs variants, lobby Richard Stallman at
3192 <bug-gnu-emacs@prep.ai.mit.edu>.
3196 #ifndef FEATUREP_SYNTAX
3197 CHECK_SYMBOL (fexp);
3198 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3199 #else /* FEATUREP_SYNTAX */
3200 static double featurep_emacs_version;
3202 /* Brute force translation from Erik Naggum's lisp function. */
3205 /* Original definition */
3206 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3208 else if (INTP (fexp) || FLOATP (fexp))
3210 double d = extract_float (fexp);
3212 if (featurep_emacs_version == 0.0)
3214 featurep_emacs_version = XINT (Vemacs_major_version) +
3215 (XINT (Vemacs_minor_version) / 100.0);
3217 return featurep_emacs_version >= d ? Qt : Qnil;
3219 else if (CONSP (fexp))
3221 Lisp_Object tem = XCAR (fexp);
3227 negate = Fcar (tem);
3229 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3231 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3233 else if (EQ (tem, Qand))
3236 /* Use Fcar/Fcdr for error-checking. */
3237 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3241 return NILP (tem) ? Qt : Qnil;
3243 else if (EQ (tem, Qor))
3246 /* Use Fcar/Fcdr for error-checking. */
3247 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3251 return NILP (tem) ? Qnil : Qt;
3255 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3260 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3263 #endif /* FEATUREP_SYNTAX */
3265 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3266 Announce that FEATURE is a feature of the current Emacs.
3267 This function updates the value of the variable `features'.
3272 CHECK_SYMBOL (feature);
3273 if (!NILP (Vautoload_queue))
3274 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3275 tem = Fmemq (feature, Vfeatures);
3277 Vfeatures = Fcons (feature, Vfeatures);
3278 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3282 DEFUN ("require", Frequire, 1, 2, 0, /*
3283 If feature FEATURE is not loaded, load it from FILENAME.
3284 If FEATURE is not a member of the list `features', then the feature
3285 is not loaded; so load the file FILENAME.
3286 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3288 (feature, file_name))
3291 CHECK_SYMBOL (feature);
3292 tem = Fmemq (feature, Vfeatures);
3293 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3298 int speccount = specpdl_depth ();
3300 /* Value saved here is to be restored into Vautoload_queue */
3301 record_unwind_protect (un_autoload, Vautoload_queue);
3302 Vautoload_queue = Qt;
3304 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3307 tem = Fmemq (feature, Vfeatures);
3309 error ("Required feature %s was not provided",
3310 string_data (XSYMBOL (feature)->name));
3312 /* Once loading finishes, don't undo it. */
3313 Vautoload_queue = Qt;
3314 return unbind_to (speccount, feature);
3318 /* base64 encode/decode functions.
3320 Originally based on code from GNU recode. Ported to FSF Emacs by
3321 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3322 subsequently heavily hacked by Hrvoje Niksic. */
3324 #define MIME_LINE_LENGTH 72
3326 #define IS_ASCII(Character) \
3328 #define IS_BASE64(Character) \
3329 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3331 /* Table of characters coding the 64 values. */
3332 static char base64_value_to_char[64] =
3334 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3335 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3336 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3337 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3338 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3339 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3340 '8', '9', '+', '/' /* 60-63 */
3343 /* Table of base64 values for first 128 characters. */
3344 static short base64_char_to_value[128] =
3346 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3347 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3348 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3349 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3350 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3351 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3352 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3353 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3354 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3355 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3356 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3357 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3358 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3361 /* The following diagram shows the logical steps by which three octets
3362 get transformed into four base64 characters.
3364 .--------. .--------. .--------.
3365 |aaaaaabb| |bbbbcccc| |ccdddddd|
3366 `--------' `--------' `--------'
3368 .--------+--------+--------+--------.
3369 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3370 `--------+--------+--------+--------'
3372 .--------+--------+--------+--------.
3373 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3374 `--------+--------+--------+--------'
3376 The octets are divided into 6 bit chunks, which are then encoded into
3377 base64 characters. */
3379 #define ADVANCE_INPUT(c, stream) \
3380 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3382 (signal_simple_error ("Non-ascii character in base64 input", \
3383 make_char (ec)), 0) \
3384 : (c = (Bufbyte)ec), 1))
3387 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3389 EMACS_INT counter = 0;
3397 if (!ADVANCE_INPUT (c, istream))
3400 /* Wrap line every 76 characters. */
3403 if (counter < MIME_LINE_LENGTH / 4)
3412 /* Process first byte of a triplet. */
3413 *e++ = base64_value_to_char[0x3f & c >> 2];
3414 value = (0x03 & c) << 4;
3416 /* Process second byte of a triplet. */
3417 if (!ADVANCE_INPUT (c, istream))
3419 *e++ = base64_value_to_char[value];
3425 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3426 value = (0x0f & c) << 2;
3428 /* Process third byte of a triplet. */
3429 if (!ADVANCE_INPUT (c, istream))
3431 *e++ = base64_value_to_char[value];
3436 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3437 *e++ = base64_value_to_char[0x3f & c];
3442 #undef ADVANCE_INPUT
3444 /* Get next character from the stream, except that non-base64
3445 characters are ignored. This is in accordance with rfc2045. EC
3446 should be an Emchar, so that it can hold -1 as the value for EOF. */
3447 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3448 ec = Lstream_get_emchar (stream); \
3450 /* IS_BASE64 may not be called with negative arguments so check for \
3452 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3456 #define STORE_BYTE(pos, val, ccnt) do { \
3457 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3462 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3466 EMACS_INT streampos = 0;
3471 unsigned long value;
3473 /* Process first byte of a quadruplet. */
3474 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3478 signal_simple_error ("Illegal `=' character while decoding base64",
3479 make_int (streampos));
3480 value = base64_char_to_value[ec] << 18;
3482 /* Process second byte of a quadruplet. */
3483 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3485 error ("Premature EOF while decoding base64");
3487 signal_simple_error ("Illegal `=' character while decoding base64",
3488 make_int (streampos));
3489 value |= base64_char_to_value[ec] << 12;
3490 STORE_BYTE (e, value >> 16, ccnt);
3492 /* Process third byte of a quadruplet. */
3493 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3495 error ("Premature EOF while decoding base64");
3499 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3501 error ("Premature EOF while decoding base64");
3503 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3504 make_int (streampos));
3508 value |= base64_char_to_value[ec] << 6;
3509 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3511 /* Process fourth byte of a quadruplet. */
3512 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3514 error ("Premature EOF while decoding base64");
3518 value |= base64_char_to_value[ec];
3519 STORE_BYTE (e, 0xff & value, ccnt);
3525 #undef ADVANCE_INPUT
3526 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3530 free_malloced_ptr (Lisp_Object unwind_obj)
3532 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3534 free_opaque_ptr (unwind_obj);
3538 /* Don't use alloca for regions larger than this, lest we overflow
3540 #define MAX_ALLOCA 65536
3542 /* We need to setup proper unwinding, because there is a number of
3543 ways these functions can blow up, and we don't want to have memory
3544 leaks in those cases. */
3545 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3546 size_t XOA_len = (len); \
3547 if (XOA_len > MAX_ALLOCA) \
3549 ptr = xnew_array (type, XOA_len); \
3550 record_unwind_protect (free_malloced_ptr, \
3551 make_opaque_ptr ((void *)ptr)); \
3554 ptr = alloca_array (type, XOA_len); \
3557 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3558 if ((len) > MAX_ALLOCA) \
3559 unbind_to (speccount, Qnil); \
3562 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3563 Base64-encode the region between BEG and END.
3564 Return the length of the encoded text.
3565 Optional third argument NO-LINE-BREAK means do not break long lines
3568 (beg, end, no_line_break))
3571 Bytind encoded_length;
3572 Charcount allength, length;
3573 struct buffer *buf = current_buffer;
3574 Bufpos begv, zv, old_pt = BUF_PT (buf);
3576 int speccount = specpdl_depth();
3578 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3579 barf_if_buffer_read_only (buf, begv, zv);
3581 /* We need to allocate enough room for encoding the text.
3582 We need 33 1/3% more space, plus a newline every 76
3583 characters, and then we round up. */
3585 allength = length + length/3 + 1;
3586 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3588 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3589 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3590 base64 characters will be single-byte. */
3591 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3592 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3593 NILP (no_line_break));
3594 if (encoded_length > allength)
3596 Lstream_delete (XLSTREAM (input));
3598 /* Now we have encoded the region, so we insert the new contents
3599 and delete the old. (Insert first in order to preserve markers.) */
3600 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3601 XMALLOC_UNBIND (encoded, allength, speccount);
3602 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3604 /* Simulate FSF Emacs implementation of this function: if point was
3605 in the region, place it at the beginning. */
3606 if (old_pt >= begv && old_pt < zv)
3607 BUF_SET_PT (buf, begv);
3609 /* We return the length of the encoded text. */
3610 return make_int (encoded_length);
3613 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3614 Base64 encode STRING and return the result.
3616 (string, no_line_break))
3618 Charcount allength, length;
3619 Bytind encoded_length;
3621 Lisp_Object input, result;
3622 int speccount = specpdl_depth();
3624 CHECK_STRING (string);
3626 length = XSTRING_CHAR_LENGTH (string);
3627 allength = length + length/3 + 1;
3628 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3630 input = make_lisp_string_input_stream (string, 0, -1);
3631 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3632 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3633 NILP (no_line_break));
3634 if (encoded_length > allength)
3636 Lstream_delete (XLSTREAM (input));
3637 result = make_string (encoded, encoded_length);
3638 XMALLOC_UNBIND (encoded, allength, speccount);
3642 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3643 Base64-decode the region between BEG and END.
3644 Return the length of the decoded text.
3645 If the region can't be decoded, return nil and don't modify the buffer.
3646 Characters out of the base64 alphabet are ignored.
3650 struct buffer *buf = current_buffer;
3651 Bufpos begv, zv, old_pt = BUF_PT (buf);
3653 Bytind decoded_length;
3654 Charcount length, cc_decoded_length;
3656 int speccount = specpdl_depth();
3658 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3659 barf_if_buffer_read_only (buf, begv, zv);
3663 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3664 /* We need to allocate enough room for decoding the text. */
3665 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3666 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3667 if (decoded_length > length * MAX_EMCHAR_LEN)
3669 Lstream_delete (XLSTREAM (input));
3671 /* Now we have decoded the region, so we insert the new contents
3672 and delete the old. (Insert first in order to preserve markers.) */
3673 BUF_SET_PT (buf, begv);
3674 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3675 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3676 buffer_delete_range (buf, begv + cc_decoded_length,
3677 zv + cc_decoded_length, 0);
3679 /* Simulate FSF Emacs implementation of this function: if point was
3680 in the region, place it at the beginning. */
3681 if (old_pt >= begv && old_pt < zv)
3682 BUF_SET_PT (buf, begv);
3684 return make_int (cc_decoded_length);
3687 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3688 Base64-decode STRING and return the result.
3689 Characters out of the base64 alphabet are ignored.
3694 Bytind decoded_length;
3695 Charcount length, cc_decoded_length;
3696 Lisp_Object input, result;
3697 int speccount = specpdl_depth();
3699 CHECK_STRING (string);
3701 length = XSTRING_CHAR_LENGTH (string);
3702 /* We need to allocate enough room for decoding the text. */
3703 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3705 input = make_lisp_string_input_stream (string, 0, -1);
3706 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3707 &cc_decoded_length);
3708 if (decoded_length > length * MAX_EMCHAR_LEN)
3710 Lstream_delete (XLSTREAM (input));
3712 result = make_string (decoded, decoded_length);
3713 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3717 Lisp_Object Qyes_or_no_p;
3722 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3724 defsymbol (&Qstring_lessp, "string-lessp");
3725 defsymbol (&Qidentity, "identity");
3726 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3728 DEFSUBR (Fidentity);
3731 DEFSUBR (Fsafe_length);
3732 DEFSUBR (Fstring_equal);
3733 DEFSUBR (Fstring_lessp);
3734 DEFSUBR (Fstring_modified_tick);
3738 DEFSUBR (Fbvconcat);
3739 DEFSUBR (Fcopy_list);
3740 DEFSUBR (Fcopy_sequence);
3741 DEFSUBR (Fcopy_alist);
3742 DEFSUBR (Fcopy_tree);
3743 DEFSUBR (Fsubstring);
3750 DEFSUBR (Fnbutlast);
3752 DEFSUBR (Fold_member);
3754 DEFSUBR (Fold_memq);
3756 DEFSUBR (Fold_assoc);
3758 DEFSUBR (Fold_assq);
3760 DEFSUBR (Fold_rassoc);
3762 DEFSUBR (Fold_rassq);
3764 DEFSUBR (Fold_delete);
3766 DEFSUBR (Fold_delq);
3767 DEFSUBR (Fremassoc);
3769 DEFSUBR (Fremrassoc);
3770 DEFSUBR (Fremrassq);
3771 DEFSUBR (Fnreverse);
3774 DEFSUBR (Fplists_eq);
3775 DEFSUBR (Fplists_equal);
3776 DEFSUBR (Flax_plists_eq);
3777 DEFSUBR (Flax_plists_equal);
3778 DEFSUBR (Fplist_get);
3779 DEFSUBR (Fplist_put);
3780 DEFSUBR (Fplist_remprop);
3781 DEFSUBR (Fplist_member);
3782 DEFSUBR (Fcheck_valid_plist);
3783 DEFSUBR (Fvalid_plist_p);
3784 DEFSUBR (Fcanonicalize_plist);
3785 DEFSUBR (Flax_plist_get);
3786 DEFSUBR (Flax_plist_put);
3787 DEFSUBR (Flax_plist_remprop);
3788 DEFSUBR (Flax_plist_member);
3789 DEFSUBR (Fcanonicalize_lax_plist);
3790 DEFSUBR (Fdestructive_alist_to_plist);
3794 DEFSUBR (Fobject_plist);
3796 DEFSUBR (Fold_equal);
3797 DEFSUBR (Ffillarray);
3800 DEFSUBR (Fmapvector);
3801 DEFSUBR (Fmapc_internal);
3802 DEFSUBR (Fmapconcat);
3803 DEFSUBR (Fload_average);
3804 DEFSUBR (Ffeaturep);
3807 DEFSUBR (Fbase64_encode_region);
3808 DEFSUBR (Fbase64_encode_string);
3809 DEFSUBR (Fbase64_decode_region);
3810 DEFSUBR (Fbase64_decode_string);
3814 init_provide_once (void)
3816 DEFVAR_LISP ("features", &Vfeatures /*
3817 A list of symbols which are the features of the executing emacs.
3818 Used by `featurep' and `require', and altered by `provide'.
3822 Fprovide (intern ("base64"));