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, void (*markobj) (Lisp_Object))
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
73 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
74 int len = bit_vector_length (v);
77 if (INTP (Vprint_length))
78 last = min (len, XINT (Vprint_length));
79 write_c_string ("#*", printcharfun);
80 for (i = 0; i < last; i++)
82 if (bit_vector_bit (v, i))
83 write_c_string ("1", printcharfun);
85 write_c_string ("0", printcharfun);
89 write_c_string ("...", printcharfun);
93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
95 struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
96 struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
98 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
99 !memcmp (v1->bits, v2->bits,
100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
105 bit_vector_hash (Lisp_Object obj, int depth)
107 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 return HASH2 (bit_vector_length (v),
109 memory_hash (v->bits,
110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
114 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
115 mark_bit_vector, print_bit_vector, 0,
116 bit_vector_equal, bit_vector_hash, 0,
117 struct Lisp_Bit_Vector);
119 DEFUN ("identity", Fidentity, 1, 1, 0, /*
120 Return the argument unchanged.
127 extern long get_random (void);
128 extern void seed_random (long arg);
130 DEFUN ("random", Frandom, 0, 1, 0, /*
131 Return a pseudo-random number.
132 All integers representable in Lisp are equally likely.
133 On most systems, this is 28 bits' worth.
134 With positive integer argument N, return random number in interval [0,N).
135 With argument t, set the random number seed from the current time and pid.
140 unsigned long denominator;
143 seed_random (getpid () + time (NULL));
144 if (NATNUMP (limit) && !ZEROP (limit))
146 /* Try to take our random number from the higher bits of VAL,
147 not the lower, since (says Gentzel) the low bits of `random'
148 are less random than the higher ones. We do this by using the
149 quotient rather than the remainder. At the high end of the RNG
150 it's possible to get a quotient larger than limit; discarding
151 these values eliminates the bias that would otherwise appear
152 when using a large limit. */
153 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
155 val = get_random () / denominator;
156 while (val >= XINT (limit));
161 return make_int (val);
164 /* Random data-structure functions */
166 #ifdef LOSING_BYTECODE
168 /* #### Delete this shit */
170 /* Charcount is a misnomer here as we might be dealing with the
171 length of a vector or list, but emphasizes that we're not dealing
172 with Bytecounts in strings */
174 length_with_bytecode_hack (Lisp_Object seq)
176 if (!COMPILED_FUNCTIONP (seq))
177 return XINT (Flength (seq));
180 struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
182 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
183 f->flags.domainp ? COMPILED_DOMAIN :
189 #endif /* LOSING_BYTECODE */
192 check_losing_bytecode (CONST char *function, Lisp_Object seq)
194 if (COMPILED_FUNCTIONP (seq))
197 "As of 20.3, `%s' no longer works with compiled-function objects",
201 DEFUN ("length", Flength, 1, 1, 0, /*
202 Return the length of vector, bit vector, list or string SEQUENCE.
207 if (STRINGP (sequence))
208 return make_int (XSTRING_CHAR_LENGTH (sequence));
209 else if (CONSP (sequence))
212 GET_EXTERNAL_LIST_LENGTH (sequence, len);
213 return make_int (len);
215 else if (VECTORP (sequence))
216 return make_int (XVECTOR_LENGTH (sequence));
217 else if (NILP (sequence))
219 else if (BIT_VECTORP (sequence))
220 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
223 check_losing_bytecode ("length", sequence);
224 sequence = wrong_type_argument (Qsequencep, sequence);
229 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
230 Return the length of a list, but avoid error or infinite loop.
231 This function never gets an error. If LIST is not really a list,
232 it returns 0. If LIST is circular, it returns a finite value
233 which is at least the number of distinct elements.
237 Lisp_Object hare, tortoise;
240 for (hare = tortoise = list, len = 0;
241 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
242 hare = XCDR (hare), len++)
245 tortoise = XCDR (tortoise);
248 return make_int (len);
251 /*** string functions. ***/
253 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
254 Return t if two strings have identical contents.
255 Case is significant. Text properties are ignored.
256 \(Under XEmacs, `equal' also ignores text properties and extents in
257 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
258 `equal' is the same as in XEmacs, in that respect.)
259 Symbols are also allowed; their print names are used instead.
264 struct Lisp_String *p1, *p2;
267 p1 = XSYMBOL (s1)->name;
275 p2 = XSYMBOL (s2)->name;
282 return (((len = string_length (p1)) == string_length (p2)) &&
283 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
287 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
288 Return t if first arg string is less than second in lexicographic order.
289 If I18N2 support (but not Mule support) was compiled in, ordering is
290 determined by the locale. (Case is significant for the default C locale.)
291 In all other cases, comparison is simply done on a character-by-
292 character basis using the numeric value of a character. (Note that
293 this may not produce particularly meaningful results under Mule if
294 characters from different charsets are being compared.)
296 Symbols are also allowed; their print names are used instead.
298 The reason that the I18N2 locale-specific collation is not used under
299 Mule is that the locale model of internationalization does not handle
300 multiple charsets and thus has no hope of working properly under Mule.
301 What we really should do is create a collation table over all built-in
302 charsets. This is extremely difficult to do from scratch, however.
304 Unicode is a good first step towards solving this problem. In fact,
305 it is quite likely that a collation table exists (or will exist) for
306 Unicode. When Unicode support is added to XEmacs/Mule, this problem
311 struct Lisp_String *p1, *p2;
316 p1 = XSYMBOL (s1)->name;
324 p2 = XSYMBOL (s2)->name;
331 end = string_char_length (p1);
332 len2 = string_char_length (p2);
336 #if defined (I18N2) && !defined (MULE)
337 /* There is no hope of this working under Mule. Even if we converted
338 the data into an external format so that strcoll() processed it
339 properly, it would still not work because strcoll() does not
340 handle multiple locales. This is the fundamental flaw in the
343 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
344 /* Compare strings using collation order of locale. */
345 /* Need to be tricky to handle embedded nulls. */
347 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
349 int val = strcoll ((char *) string_data (p1) + i,
350 (char *) string_data (p2) + i);
357 #else /* not I18N2, or MULE */
359 Bufbyte *ptr1 = string_data (p1);
360 Bufbyte *ptr2 = string_data (p2);
362 /* #### It is not really necessary to do this: We could compare
363 byte-by-byte and still get a reasonable comparison, since this
364 would compare characters with a charset in the same way. With
365 a little rearrangement of the leading bytes, we could make most
366 inter-charset comparisons work out the same, too; even if some
367 don't, this is not a big deal because inter-charset comparisons
368 aren't really well-defined anyway. */
369 for (i = 0; i < end; i++)
371 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
372 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
377 #endif /* not I18N2, or MULE */
378 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
379 won't work right in I18N2 case */
380 return end < len2 ? Qt : Qnil;
383 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
384 Return STRING's tick counter, incremented for each change to the string.
385 Each string has a tick counter which is incremented each time the contents
386 of the string are changed (e.g. with `aset'). It wraps around occasionally.
390 struct Lisp_String *s;
392 CHECK_STRING (string);
393 s = XSTRING (string);
394 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
395 return XCAR (s->plist);
401 bump_string_modiff (Lisp_Object str)
403 struct Lisp_String *s = XSTRING (str);
404 Lisp_Object *ptr = &s->plist;
407 /* #### remove the `string-translatable' property from the string,
410 /* skip over extent info if it's there */
411 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
413 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
414 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
416 *ptr = Fcons (make_int (1), *ptr);
420 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
421 static Lisp_Object concat (int nargs, Lisp_Object *args,
422 enum concat_target_type target_type,
426 concat2 (Lisp_Object s1, Lisp_Object s2)
431 return concat (2, args, c_string, 0);
435 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
441 return concat (3, args, c_string, 0);
445 vconcat2 (Lisp_Object s1, Lisp_Object s2)
450 return concat (2, args, c_vector, 0);
454 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
460 return concat (3, args, c_vector, 0);
463 DEFUN ("append", Fappend, 0, MANY, 0, /*
464 Concatenate all the arguments and make the result a list.
465 The result is a list whose elements are the elements of all the arguments.
466 Each argument may be a list, vector, bit vector, or string.
467 The last argument is not copied, just used as the tail of the new list.
470 (int nargs, Lisp_Object *args))
472 return concat (nargs, args, c_cons, 1);
475 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
476 Concatenate all the arguments and make the result a string.
477 The result is a string whose elements are the elements of all the arguments.
478 Each argument may be a string or a list or vector of characters.
480 As of XEmacs 21.0, this function does NOT accept individual integers
481 as arguments. Old code that relies on, for example, (concat "foo" 50)
482 returning "foo50" will fail. To fix such code, either apply
483 `int-to-string' to the integer argument, or use `format'.
485 (int nargs, Lisp_Object *args))
487 return concat (nargs, args, c_string, 0);
490 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
491 Concatenate all the arguments and make the result a vector.
492 The result is a vector whose elements are the elements of all the arguments.
493 Each argument may be a list, vector, bit vector, or string.
495 (int nargs, Lisp_Object *args))
497 return concat (nargs, args, c_vector, 0);
500 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
501 Concatenate all the arguments and make the result a bit vector.
502 The result is a bit vector whose elements are the elements of all the
503 arguments. Each argument may be a list, vector, bit vector, or string.
505 (int nargs, Lisp_Object *args))
507 return concat (nargs, args, c_bit_vector, 0);
510 /* Copy a (possibly dotted) list. LIST must be a cons.
511 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
513 copy_list (Lisp_Object list)
515 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
516 Lisp_Object last = list_copy;
517 Lisp_Object hare, tortoise;
520 for (tortoise = hare = XCDR (list), len = 1;
522 hare = XCDR (hare), len++)
524 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
527 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
530 tortoise = XCDR (tortoise);
531 if (EQ (tortoise, hare))
532 signal_circular_list_error (list);
538 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
539 Return a copy of list LIST, which may be a dotted list.
540 The elements of LIST are not copied; they are shared
546 if (NILP (list)) return list;
547 if (CONSP (list)) return copy_list (list);
549 list = wrong_type_argument (Qlistp, list);
553 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
554 Return a copy of list, vector, bit vector or string SEQUENCE.
555 The elements of a list or vector are not copied; they are shared
556 with the original. SEQUENCE may be a dotted list.
561 if (NILP (sequence)) return sequence;
562 if (CONSP (sequence)) return copy_list (sequence);
563 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
564 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
565 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
567 check_losing_bytecode ("copy-sequence", sequence);
568 sequence = wrong_type_argument (Qsequencep, sequence);
572 struct merge_string_extents_struct
575 Bytecount entry_offset;
576 Bytecount entry_length;
580 concat (int nargs, Lisp_Object *args,
581 enum concat_target_type target_type,
585 Lisp_Object tail = Qnil;
588 Lisp_Object last_tail;
590 struct merge_string_extents_struct *args_mse = 0;
591 Bufbyte *string_result = 0;
592 Bufbyte *string_result_ptr = 0;
595 /* The modus operandi in Emacs is "caller gc-protects args".
596 However, concat is called many times in Emacs on freshly
597 created stuff. So we help those callers out by protecting
598 the args ourselves to save them a lot of temporary-variable
602 gcpro1.nvars = nargs;
605 /* #### if the result is a string and any of the strings have a string
606 for the `string-translatable' property, then concat should also
607 concat the args but use the `string-translatable' strings, and store
608 the result in the returned string's `string-translatable' property. */
610 if (target_type == c_string)
611 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
613 /* In append, the last arg isn't treated like the others */
614 if (last_special && nargs > 0)
617 last_tail = args[nargs];
622 /* Check and coerce the arguments. */
623 for (argnum = 0; argnum < nargs; argnum++)
625 Lisp_Object seq = args[argnum];
628 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
630 #ifdef LOSING_BYTECODE
631 else if (COMPILED_FUNCTIONP (seq))
632 /* Urk! We allow this, for "compatibility"... */
635 #if 0 /* removed for XEmacs 21 */
637 /* This is too revolting to think about but maintains
638 compatibility with FSF (and lots and lots of old code). */
639 args[argnum] = Fnumber_to_string (seq);
643 check_losing_bytecode ("concat", seq);
644 args[argnum] = wrong_type_argument (Qsequencep, seq);
650 args_mse[argnum].string = seq;
652 args_mse[argnum].string = Qnil;
657 /* Charcount is a misnomer here as we might be dealing with the
658 length of a vector or list, but emphasizes that we're not dealing
659 with Bytecounts in strings */
660 Charcount total_length;
662 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
664 #ifdef LOSING_BYTECODE
665 Charcount thislen = length_with_bytecode_hack (args[argnum]);
667 Charcount thislen = XINT (Flength (args[argnum]));
669 total_length += thislen;
675 if (total_length == 0)
676 /* In append, if all but last arg are nil, return last arg */
677 RETURN_UNGCPRO (last_tail);
678 val = Fmake_list (make_int (total_length), Qnil);
681 val = make_vector (total_length, Qnil);
684 val = make_bit_vector (total_length, Qzero);
687 /* We don't make the string yet because we don't know the
688 actual number of bytes. This loop was formerly written
689 to call Fmake_string() here and then call set_string_char()
690 for each char. This seems logical enough but is waaaaaaaay
691 slow -- set_string_char() has to scan the whole string up
692 to the place where the substitution is called for in order
693 to find the place to change, and may have to do some
694 realloc()ing in order to make the char fit properly.
697 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
698 string_result_ptr = string_result;
707 tail = val, toindex = -1; /* -1 in toindex is flag we are
714 for (argnum = 0; argnum < nargs; argnum++)
716 Charcount thisleni = 0;
717 Charcount thisindex = 0;
718 Lisp_Object seq = args[argnum];
719 Bufbyte *string_source_ptr = 0;
720 Bufbyte *string_prev_result_ptr = string_result_ptr;
724 #ifdef LOSING_BYTECODE
725 thisleni = length_with_bytecode_hack (seq);
727 thisleni = XINT (Flength (seq));
731 string_source_ptr = XSTRING_DATA (seq);
737 /* We've come to the end of this arg, so exit. */
741 /* Fetch next element of `seq' arg into `elt' */
749 if (thisindex >= thisleni)
754 elt = make_char (charptr_emchar (string_source_ptr));
755 INC_CHARPTR (string_source_ptr);
757 else if (VECTORP (seq))
758 elt = XVECTOR_DATA (seq)[thisindex];
759 else if (BIT_VECTORP (seq))
760 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
763 elt = Felt (seq, make_int (thisindex));
767 /* Store into result */
770 /* toindex negative means we are making a list */
775 else if (VECTORP (val))
776 XVECTOR_DATA (val)[toindex++] = elt;
777 else if (BIT_VECTORP (val))
780 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
784 CHECK_CHAR_COERCE_INT (elt);
785 string_result_ptr += set_charptr_emchar (string_result_ptr,
791 args_mse[argnum].entry_offset =
792 string_prev_result_ptr - string_result;
793 args_mse[argnum].entry_length =
794 string_result_ptr - string_prev_result_ptr;
798 /* Now we finally make the string. */
799 if (target_type == c_string)
801 val = make_string (string_result, string_result_ptr - string_result);
802 for (argnum = 0; argnum < nargs; argnum++)
804 if (STRINGP (args_mse[argnum].string))
805 copy_string_extents (val, args_mse[argnum].string,
806 args_mse[argnum].entry_offset, 0,
807 args_mse[argnum].entry_length);
812 XCDR (prev) = last_tail;
814 RETURN_UNGCPRO (val);
817 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
818 Return a copy of ALIST.
819 This is an alist which represents the same mapping from objects to objects,
820 but does not share the alist structure with ALIST.
821 The objects mapped (cars and cdrs of elements of the alist)
823 Elements of ALIST that are not conses are also shared.
833 alist = concat (1, &alist, c_cons, 0);
834 for (tail = alist; CONSP (tail); tail = XCDR (tail))
836 Lisp_Object car = XCAR (tail);
839 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
844 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
845 Return a copy of a list and substructures.
846 The argument is copied, and any lists contained within it are copied
847 recursively. Circularities and shared substructures are not preserved.
848 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
856 rest = arg = Fcopy_sequence (arg);
859 Lisp_Object elt = XCAR (rest);
861 if (CONSP (elt) || VECTORP (elt))
862 XCAR (rest) = Fcopy_tree (elt, vecp);
863 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
864 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
868 else if (VECTORP (arg) && ! NILP (vecp))
870 int i = XVECTOR_LENGTH (arg);
872 arg = Fcopy_sequence (arg);
873 for (j = 0; j < i; j++)
875 Lisp_Object elt = XVECTOR_DATA (arg) [j];
877 if (CONSP (elt) || VECTORP (elt))
878 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
884 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
885 Return a substring of STRING, starting at index FROM and ending before TO.
886 TO may be nil or omitted; then the substring runs to the end of STRING.
887 If FROM or TO is negative, it counts from the end.
888 Relevant parts of the string-extent-data are copied in the new string.
892 Charcount ccfr, ccto;
896 CHECK_STRING (string);
898 get_string_range_char (string, from, to, &ccfr, &ccto,
899 GB_HISTORICAL_STRING_BEHAVIOR);
900 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
901 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
902 val = make_string (XSTRING_DATA (string) + bfr, blen);
903 /* Copy any applicable extent information into the new string: */
904 copy_string_extents (val, string, 0, bfr, blen);
908 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
909 Return a subsequence of SEQ, starting at index FROM and ending before TO.
910 TO may be nil or omitted; then the subsequence runs to the end of SEQ.
911 If FROM or TO is negative, it counts from the end.
912 The resulting subsequence is always the same type as the original
914 If SEQ is a string, relevant parts of the string-extent-data are copied
922 return Fsubstring (seq, from, to);
924 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
926 check_losing_bytecode ("subseq", seq);
927 seq = wrong_type_argument (Qsequencep, seq);
930 len = XINT (Flength (seq));
947 if (!(0 <= f && f <= t && t <= len))
948 args_out_of_range_3 (seq, make_int (f), make_int (t));
952 Lisp_Object result = make_vector (t - f, Qnil);
954 Lisp_Object *in_elts = XVECTOR_DATA (seq);
955 Lisp_Object *out_elts = XVECTOR_DATA (result);
957 for (i = f; i < t; i++)
958 out_elts[i - f] = in_elts[i];
964 Lisp_Object result = Qnil;
967 seq = Fnthcdr (make_int (f), seq);
969 for (i = f; i < t; i++)
971 result = Fcons (Fcar (seq), result);
975 return Fnreverse (result);
980 Lisp_Object result = make_bit_vector (t - f, Qzero);
983 for (i = f; i < t; i++)
984 set_bit_vector_bit (XBIT_VECTOR (result), i - f,
985 bit_vector_bit (XBIT_VECTOR (seq), i));
991 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
992 Take cdr N times on LIST, and return the result.
997 REGISTER Lisp_Object tail = list;
999 for (i = XINT (n); i; i--)
1003 else if (NILP (tail))
1007 tail = wrong_type_argument (Qlistp, tail);
1014 DEFUN ("nth", Fnth, 2, 2, 0, /*
1015 Return the Nth element of LIST.
1016 N counts from zero. If LIST is not that long, nil is returned.
1020 return Fcar (Fnthcdr (n, list));
1023 DEFUN ("elt", Felt, 2, 2, 0, /*
1024 Return element of SEQUENCE at index N.
1029 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1030 if (LISTP (sequence))
1032 Lisp_Object tem = Fnthcdr (n, sequence);
1033 /* #### Utterly, completely, fucking disgusting.
1034 * #### The whole point of "elt" is that it operates on
1035 * #### sequences, and does error- (bounds-) checking.
1041 /* This is The Way It Has Always Been. */
1044 /* This is The Way Mly and Cltl2 say It Should Be. */
1045 args_out_of_range (sequence, n);
1048 else if (STRINGP (sequence) ||
1049 VECTORP (sequence) ||
1050 BIT_VECTORP (sequence))
1051 return Faref (sequence, n);
1052 #ifdef LOSING_BYTECODE
1053 else if (COMPILED_FUNCTIONP (sequence))
1059 args_out_of_range (sequence, n);
1061 /* Utter perversity */
1063 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1066 case COMPILED_ARGLIST:
1067 return compiled_function_arglist (f);
1068 case COMPILED_INSTRUCTIONS:
1069 return compiled_function_instructions (f);
1070 case COMPILED_CONSTANTS:
1071 return compiled_function_constants (f);
1072 case COMPILED_STACK_DEPTH:
1073 return compiled_function_stack_depth (f);
1074 case COMPILED_DOC_STRING:
1075 return compiled_function_documentation (f);
1076 case COMPILED_DOMAIN:
1077 return compiled_function_domain (f);
1078 case COMPILED_INTERACTIVE:
1079 if (f->flags.interactivep)
1080 return compiled_function_interactive (f);
1081 /* if we return nil, can't tell interactive with no args
1082 from noninteractive. */
1089 #endif /* LOSING_BYTECODE */
1092 check_losing_bytecode ("elt", sequence);
1093 sequence = wrong_type_argument (Qsequencep, sequence);
1098 DEFUN ("last", Flast, 1, 2, 0, /*
1099 Return the tail of list LIST, of length N (default 1).
1100 LIST may be a dotted list, but not a circular list.
1101 Optional argument N must be a non-negative integer.
1102 If N is zero, then the atom that terminates the list is returned.
1103 If N is greater than the length of LIST, then LIST itself is returned.
1108 Lisp_Object retval, tortoise, hare;
1120 for (retval = tortoise = hare = list, count = 0;
1123 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1126 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1129 tortoise = XCDR (tortoise);
1130 if (EQ (hare, tortoise))
1131 signal_circular_list_error (list);
1137 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1138 Modify LIST to remove the last N (default 1) elements.
1139 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1156 Lisp_Object last_cons = list;
1158 EXTERNAL_LIST_LOOP_1 (list)
1161 last_cons = XCDR (last_cons);
1167 XCDR (last_cons) = Qnil;
1172 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1173 Return a copy of LIST with the last N (default 1) elements removed.
1174 If LIST has N or fewer elements, nil is returned.
1191 Lisp_Object retval = Qnil;
1192 Lisp_Object tail = list;
1194 EXTERNAL_LIST_LOOP_1 (list)
1198 retval = Fcons (XCAR (tail), retval);
1203 return Fnreverse (retval);
1207 DEFUN ("member", Fmember, 2, 2, 0, /*
1208 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1209 The value is actually the tail of LIST whose car is ELT.
1213 Lisp_Object list_elt, tail;
1214 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1216 if (internal_equal (elt, list_elt, 0))
1222 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1223 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1224 The value is actually the tail of LIST whose car is ELT.
1225 This function is provided only for byte-code compatibility with v19.
1230 Lisp_Object list_elt, tail;
1231 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1233 if (internal_old_equal (elt, list_elt, 0))
1239 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1240 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1241 The value is actually the tail of LIST whose car is ELT.
1245 Lisp_Object list_elt, tail;
1246 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1248 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1254 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1255 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1256 The value is actually the tail of LIST whose car is ELT.
1257 This function is provided only for byte-code compatibility with v19.
1262 Lisp_Object list_elt, tail;
1263 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1265 if (HACKEQ_UNSAFE (elt, list_elt))
1272 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1274 Lisp_Object list_elt, tail;
1275 LIST_LOOP_3 (list_elt, list, tail)
1277 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1283 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1284 Return non-nil if KEY is `equal' to the car of an element of LIST.
1285 The value is actually the element of LIST whose car equals KEY.
1289 /* This function can GC. */
1290 Lisp_Object elt, elt_car, elt_cdr;
1291 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1293 if (internal_equal (key, elt_car, 0))
1299 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1300 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1301 The value is actually the element of LIST whose car equals KEY.
1305 /* This function can GC. */
1306 Lisp_Object elt, elt_car, elt_cdr;
1307 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1309 if (internal_old_equal (key, elt_car, 0))
1316 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1318 int speccount = specpdl_depth ();
1319 specbind (Qinhibit_quit, Qt);
1320 return unbind_to (speccount, Fassoc (key, list));
1323 DEFUN ("assq", Fassq, 2, 2, 0, /*
1324 Return non-nil if KEY is `eq' to the car of an element of LIST.
1325 The value is actually the element of LIST whose car is KEY.
1326 Elements of LIST that are not conses are ignored.
1330 Lisp_Object elt, elt_car, elt_cdr;
1331 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1333 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1339 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1340 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1341 The value is actually the element of LIST whose car is KEY.
1342 Elements of LIST that are not conses are ignored.
1343 This function is provided only for byte-code compatibility with v19.
1348 Lisp_Object elt, elt_car, elt_cdr;
1349 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1351 if (HACKEQ_UNSAFE (key, elt_car))
1357 /* Like Fassq but never report an error and do not allow quits.
1358 Use only on lists known never to be circular. */
1361 assq_no_quit (Lisp_Object key, Lisp_Object list)
1363 /* This cannot GC. */
1365 LIST_LOOP_2 (elt, list)
1367 Lisp_Object elt_car = XCAR (elt);
1368 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1374 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1375 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1376 The value is actually the element of LIST whose cdr equals KEY.
1380 Lisp_Object elt, elt_car, elt_cdr;
1381 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1383 if (internal_equal (key, elt_cdr, 0))
1389 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1390 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1391 The value is actually the element of LIST whose cdr equals KEY.
1395 Lisp_Object elt, elt_car, elt_cdr;
1396 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1398 if (internal_old_equal (key, elt_cdr, 0))
1404 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1405 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1406 The value is actually the element of LIST whose cdr is KEY.
1410 Lisp_Object elt, elt_car, elt_cdr;
1411 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1413 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1419 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1420 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1421 The value is actually the element of LIST whose cdr is KEY.
1425 Lisp_Object elt, elt_car, elt_cdr;
1426 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1428 if (HACKEQ_UNSAFE (key, elt_cdr))
1434 /* Like Frassq, but caller must ensure that LIST is properly
1435 nil-terminated and ebola-free. */
1437 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1440 LIST_LOOP_2 (elt, list)
1442 Lisp_Object elt_cdr = XCDR (elt);
1443 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1450 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1451 Delete by side effect any occurrences of ELT as a member of LIST.
1452 The modified LIST is returned. Comparison is done with `equal'.
1453 If the first member of LIST is ELT, there is no way to remove it by side
1454 effect; therefore, write `(setq foo (delete element foo))' to be sure
1455 of changing the value of `foo'.
1460 Lisp_Object list_elt;
1461 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1462 (internal_equal (elt, list_elt, 0)));
1466 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1467 Delete by side effect any occurrences of ELT as a member of LIST.
1468 The modified LIST is returned. Comparison is done with `old-equal'.
1469 If the first member of LIST is ELT, there is no way to remove it by side
1470 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1471 of changing the value of `foo'.
1475 Lisp_Object list_elt;
1476 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1477 (internal_old_equal (elt, list_elt, 0)));
1481 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1482 Delete by side effect any occurrences of ELT as a member of LIST.
1483 The modified LIST is returned. Comparison is done with `eq'.
1484 If the first member of LIST is ELT, there is no way to remove it by side
1485 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1486 changing the value of `foo'.
1490 Lisp_Object list_elt;
1491 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1492 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1496 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1497 Delete by side effect any occurrences of ELT as a member of LIST.
1498 The modified LIST is returned. Comparison is done with `old-eq'.
1499 If the first member of LIST is ELT, there is no way to remove it by side
1500 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1501 changing the value of `foo'.
1505 Lisp_Object list_elt;
1506 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1507 (HACKEQ_UNSAFE (elt, list_elt)));
1511 /* Like Fdelq, but caller must ensure that LIST is properly
1512 nil-terminated and ebola-free. */
1515 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1517 Lisp_Object list_elt;
1518 LIST_LOOP_DELETE_IF (list_elt, list,
1519 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1523 /* Be VERY careful with this. This is like delq_no_quit() but
1524 also calls free_cons() on the removed conses. You must be SURE
1525 that no pointers to the freed conses remain around (e.g.
1526 someone else is pointing to part of the list). This function
1527 is useful on internal lists that are used frequently and where
1528 the actual list doesn't escape beyond known code bounds. */
1531 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1533 REGISTER Lisp_Object tail = list;
1534 REGISTER Lisp_Object prev = Qnil;
1536 while (!NILP (tail))
1538 REGISTER Lisp_Object tem = XCAR (tail);
1541 Lisp_Object cons_to_free = tail;
1545 XCDR (prev) = XCDR (tail);
1547 free_cons (XCONS (cons_to_free));
1558 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1559 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1560 The modified LIST is returned. If the first member of LIST has a car
1561 that is `equal' to KEY, there is no way to remove it by side effect;
1562 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1568 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1570 internal_equal (key, XCAR (elt), 0)));
1575 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1577 int speccount = specpdl_depth ();
1578 specbind (Qinhibit_quit, Qt);
1579 return unbind_to (speccount, Fremassoc (key, list));
1582 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1583 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1584 The modified LIST is returned. If the first member of LIST has a car
1585 that is `eq' to KEY, there is no way to remove it by side effect;
1586 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1592 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1594 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1598 /* no quit, no errors; be careful */
1601 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1604 LIST_LOOP_DELETE_IF (elt, list,
1606 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1610 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1611 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1612 The modified LIST is returned. If the first member of LIST has a car
1613 that is `equal' to VALUE, there is no way to remove it by side effect;
1614 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1620 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1622 internal_equal (value, XCDR (elt), 0)));
1626 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1627 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1628 The modified LIST is returned. If the first member of LIST has a car
1629 that is `eq' to VALUE, there is no way to remove it by side effect;
1630 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1636 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1638 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1642 /* Like Fremrassq, fast and unsafe; be careful */
1644 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1647 LIST_LOOP_DELETE_IF (elt, list,
1649 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1653 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1654 Reverse LIST by destructively modifying cdr pointers.
1655 Return the beginning of the reversed list.
1656 Also see: `reverse'.
1660 struct gcpro gcpro1, gcpro2;
1661 REGISTER Lisp_Object prev = Qnil;
1662 REGISTER Lisp_Object tail = list;
1664 /* We gcpro our args; see `nconc' */
1665 GCPRO2 (prev, tail);
1666 while (!NILP (tail))
1668 REGISTER Lisp_Object next;
1669 CONCHECK_CONS (tail);
1679 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1680 Reverse LIST, copying. Return the beginning of the reversed list.
1681 See also the function `nreverse', which is used more often.
1685 Lisp_Object reversed_list = Qnil;
1687 EXTERNAL_LIST_LOOP_2 (elt, list)
1689 reversed_list = Fcons (elt, reversed_list);
1691 return reversed_list;
1694 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1695 Lisp_Object lisp_arg,
1696 int (*pred_fn) (Lisp_Object, Lisp_Object,
1697 Lisp_Object lisp_arg));
1700 list_sort (Lisp_Object list,
1701 Lisp_Object lisp_arg,
1702 int (*pred_fn) (Lisp_Object, Lisp_Object,
1703 Lisp_Object lisp_arg))
1705 struct gcpro gcpro1, gcpro2, gcpro3;
1706 Lisp_Object back, tem;
1707 Lisp_Object front = list;
1708 Lisp_Object len = Flength (list);
1709 int length = XINT (len);
1714 XSETINT (len, (length / 2) - 1);
1715 tem = Fnthcdr (len, list);
1717 Fsetcdr (tem, Qnil);
1719 GCPRO3 (front, back, lisp_arg);
1720 front = list_sort (front, lisp_arg, pred_fn);
1721 back = list_sort (back, lisp_arg, pred_fn);
1723 return list_merge (front, back, lisp_arg, pred_fn);
1728 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1733 /* prevents the GC from happening in call2 */
1734 int speccount = specpdl_depth ();
1735 /* Emacs' GC doesn't actually relocate pointers, so this probably
1736 isn't strictly necessary */
1737 record_unwind_protect (restore_gc_inhibit,
1738 make_int (gc_currently_forbidden));
1739 gc_currently_forbidden = 1;
1740 tmp = call2 (pred, obj1, obj2);
1741 unbind_to (speccount, Qnil);
1749 DEFUN ("sort", Fsort, 2, 2, 0, /*
1750 Sort LIST, stably, comparing elements using PREDICATE.
1751 Returns the sorted list. LIST is modified by side effects.
1752 PREDICATE is called with two elements of LIST, and should return T
1753 if the first element is "less" than the second.
1757 return list_sort (list, pred, merge_pred_function);
1761 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1764 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1769 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1770 Lisp_Object lisp_arg,
1771 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1777 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1784 /* It is sufficient to protect org_l1 and org_l2.
1785 When l1 and l2 are updated, we copy the new values
1786 back into the org_ vars. */
1788 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1809 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1824 Fsetcdr (tail, tem);
1830 /************************************************************************/
1831 /* property-list functions */
1832 /************************************************************************/
1834 /* For properties of text, we need to do order-insensitive comparison of
1835 plists. That is, we need to compare two plists such that they are the
1836 same if they have the same set of keys, and equivalent values.
1837 So (a 1 b 2) would be equal to (b 2 a 1).
1839 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1840 LAXP means use `equal' for comparisons.
1843 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1844 int laxp, int depth)
1846 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
1847 int la, lb, m, i, fill;
1848 Lisp_Object *keys, *vals;
1852 if (NILP (a) && NILP (b))
1855 Fcheck_valid_plist (a);
1856 Fcheck_valid_plist (b);
1858 la = XINT (Flength (a));
1859 lb = XINT (Flength (b));
1860 m = (la > lb ? la : lb);
1862 keys = alloca_array (Lisp_Object, m);
1863 vals = alloca_array (Lisp_Object, m);
1864 flags = alloca_array (char, m);
1866 /* First extract the pairs from A. */
1867 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1869 Lisp_Object k = XCAR (rest);
1870 Lisp_Object v = XCAR (XCDR (rest));
1871 /* Maybe be Ebolified. */
1872 if (nil_means_not_present && NILP (v)) continue;
1878 /* Now iterate over B, and stop if we find something that's not in A,
1879 or that doesn't match. As we match, mark them. */
1880 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1882 Lisp_Object k = XCAR (rest);
1883 Lisp_Object v = XCAR (XCDR (rest));
1884 /* Maybe be Ebolified. */
1885 if (nil_means_not_present && NILP (v)) continue;
1886 for (i = 0; i < fill; i++)
1888 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1891 /* We narrowly escaped being Ebolified here. */
1892 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1893 : !internal_equal (v, vals [i], depth)))
1894 /* a property in B has a different value than in A */
1901 /* there are some properties in B that are not in A */
1904 /* Now check to see that all the properties in A were also in B */
1905 for (i = 0; i < fill; i++)
1916 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1917 Return non-nil if property lists A and B are `eq'.
1918 A property list is an alternating list of keywords and values.
1919 This function does order-insensitive comparisons of the property lists:
1920 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1921 Comparison between values is done using `eq'. See also `plists-equal'.
1922 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1923 a nil value is ignored. This feature is a virus that has infected
1924 old Lisp implementations, but should not be used except for backward
1927 (a, b, nil_means_not_present))
1929 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1933 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1934 Return non-nil if property lists A and B are `equal'.
1935 A property list is an alternating list of keywords and values. This
1936 function does order-insensitive comparisons of the property lists: For
1937 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1938 Comparison between values is done using `equal'. See also `plists-eq'.
1939 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1940 a nil value is ignored. This feature is a virus that has infected
1941 old Lisp implementations, but should not be used except for backward
1944 (a, b, nil_means_not_present))
1946 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1951 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1952 Return non-nil if lax property lists A and B are `eq'.
1953 A property list is an alternating list of keywords and values.
1954 This function does order-insensitive comparisons of the property lists:
1955 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1956 Comparison between values is done using `eq'. See also `plists-equal'.
1957 A lax property list is like a regular one except that comparisons between
1958 keywords is done using `equal' instead of `eq'.
1959 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1960 a nil value is ignored. This feature is a virus that has infected
1961 old Lisp implementations, but should not be used except for backward
1964 (a, b, nil_means_not_present))
1966 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1970 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1971 Return non-nil if lax property lists A and B are `equal'.
1972 A property list is an alternating list of keywords and values. This
1973 function does order-insensitive comparisons of the property lists: For
1974 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1975 Comparison between values is done using `equal'. See also `plists-eq'.
1976 A lax property list is like a regular one except that comparisons between
1977 keywords is done using `equal' instead of `eq'.
1978 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1979 a nil value is ignored. This feature is a virus that has infected
1980 old Lisp implementations, but should not be used except for backward
1983 (a, b, nil_means_not_present))
1985 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1989 /* Return the value associated with key PROPERTY in property list PLIST.
1990 Return nil if key not found. This function is used for internal
1991 property lists that cannot be directly manipulated by the user.
1995 internal_plist_get (Lisp_Object plist, Lisp_Object property)
1999 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2001 if (EQ (XCAR (tail), property))
2002 return XCAR (XCDR (tail));
2008 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2009 internal_plist_get(). */
2012 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2017 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2019 if (EQ (XCAR (tail), property))
2021 XCAR (XCDR (tail)) = value;
2026 *plist = Fcons (property, Fcons (value, *plist));
2030 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2032 Lisp_Object tail, prev;
2034 for (tail = *plist, prev = Qnil;
2036 tail = XCDR (XCDR (tail)))
2038 if (EQ (XCAR (tail), property))
2041 *plist = XCDR (XCDR (tail));
2043 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2053 /* Called on a malformed property list. BADPLACE should be some
2054 place where truncating will form a good list -- i.e. we shouldn't
2055 result in a list with an odd length. */
2058 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2060 if (ERRB_EQ (errb, ERROR_ME))
2061 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2064 if (ERRB_EQ (errb, ERROR_ME_WARN))
2066 warn_when_safe_lispobj
2069 ("Malformed property list -- list has been truncated"),
2077 /* Called on a circular property list. BADPLACE should be some place
2078 where truncating will result in an even-length list, as above.
2079 If doesn't particularly matter where we truncate -- anywhere we
2080 truncate along the entire list will break the circularity, because
2081 it will create a terminus and the list currently doesn't have one.
2085 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2087 if (ERRB_EQ (errb, ERROR_ME))
2088 /* #### Eek, this will probably result in another error
2089 when PLIST is printed out */
2090 return Fsignal (Qcircular_property_list, list1 (*plist));
2093 if (ERRB_EQ (errb, ERROR_ME_WARN))
2095 warn_when_safe_lispobj
2098 ("Circular property list -- list has been truncated"),
2106 /* Advance the tortoise pointer by two (one iteration of a property-list
2107 loop) and the hare pointer by four and verify that no malformations
2108 or circularities exist. If so, return zero and store a value into
2109 RETVAL that should be returned by the calling function. Otherwise,
2110 return 1. See external_plist_get().
2114 advance_plist_pointers (Lisp_Object *plist,
2115 Lisp_Object **tortoise, Lisp_Object **hare,
2116 Error_behavior errb, Lisp_Object *retval)
2119 Lisp_Object *tortsave = *tortoise;
2121 /* Note that our "fixing" may be more brutal than necessary,
2122 but it's the user's own problem, not ours, if they went in and
2123 manually fucked up a plist. */
2125 for (i = 0; i < 2; i++)
2127 /* This is a standard iteration of a defensive-loop-checking
2128 loop. We just do it twice because we want to advance past
2129 both the property and its value.
2131 If the pointer indirection is confusing you, remember that
2132 one level of indirection on the hare and tortoise pointers
2133 is only due to pass-by-reference for this function. The other
2134 level is so that the plist can be fixed in place. */
2136 /* When we reach the end of a well-formed plist, **HARE is
2137 nil. In that case, we don't do anything at all except
2138 advance TORTOISE by one. Otherwise, we advance HARE
2139 by two (making sure it's OK to do so), then advance
2140 TORTOISE by one (it will always be OK to do so because
2141 the HARE is always ahead of the TORTOISE and will have
2142 already verified the path), then make sure TORTOISE and
2143 HARE don't contain the same non-nil object -- if the
2144 TORTOISE and the HARE ever meet, then obviously we're
2145 in a circularity, and if we're in a circularity, then
2146 the TORTOISE and the HARE can't cross paths without
2147 meeting, since the HARE only gains one step over the
2148 TORTOISE per iteration. */
2152 Lisp_Object *haresave = *hare;
2153 if (!CONSP (**hare))
2155 *retval = bad_bad_bunny (plist, haresave, errb);
2158 *hare = &XCDR (**hare);
2159 /* In a non-plist, we'd check here for a nil value for
2160 **HARE, which is OK (it just means the list has an
2161 odd number of elements). In a plist, it's not OK
2162 for the list to have an odd number of elements. */
2163 if (!CONSP (**hare))
2165 *retval = bad_bad_bunny (plist, haresave, errb);
2168 *hare = &XCDR (**hare);
2171 *tortoise = &XCDR (**tortoise);
2172 if (!NILP (**hare) && EQ (**tortoise, **hare))
2174 *retval = bad_bad_turtle (plist, tortsave, errb);
2182 /* Return the value of PROPERTY from PLIST, or Qunbound if
2183 property is not on the list.
2185 PLIST is a Lisp-accessible property list, meaning that it
2186 has to be checked for malformations and circularities.
2188 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2189 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2190 on finding a malformation or a circularity, it issues a warning and
2191 attempts to silently fix the problem.
2193 A pointer to PLIST is passed in so that PLIST can be successfully
2194 "fixed" even if the error is at the beginning of the plist. */
2197 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2198 int laxp, Error_behavior errb)
2200 Lisp_Object *tortoise = plist;
2201 Lisp_Object *hare = plist;
2203 while (!NILP (*tortoise))
2205 Lisp_Object *tortsave = tortoise;
2208 /* We do the standard tortoise/hare march. We isolate the
2209 grungy stuff to do this in advance_plist_pointers(), though.
2210 To us, all this function does is advance the tortoise
2211 pointer by two and the hare pointer by four and make sure
2212 everything's OK. We first advance the pointers and then
2213 check if a property matched; this ensures that our
2214 check for a matching property is safe. */
2216 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2219 if (!laxp ? EQ (XCAR (*tortsave), property)
2220 : internal_equal (XCAR (*tortsave), property, 0))
2221 return XCAR (XCDR (*tortsave));
2227 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2228 malformed or circular plist. Analogous to external_plist_get(). */
2231 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2232 Lisp_Object value, int laxp, Error_behavior errb)
2234 Lisp_Object *tortoise = plist;
2235 Lisp_Object *hare = plist;
2237 while (!NILP (*tortoise))
2239 Lisp_Object *tortsave = tortoise;
2243 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2246 if (!laxp ? EQ (XCAR (*tortsave), property)
2247 : internal_equal (XCAR (*tortsave), property, 0))
2249 XCAR (XCDR (*tortsave)) = value;
2254 *plist = Fcons (property, Fcons (value, *plist));
2258 external_remprop (Lisp_Object *plist, Lisp_Object property,
2259 int laxp, Error_behavior errb)
2261 Lisp_Object *tortoise = plist;
2262 Lisp_Object *hare = plist;
2264 while (!NILP (*tortoise))
2266 Lisp_Object *tortsave = tortoise;
2270 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2273 if (!laxp ? EQ (XCAR (*tortsave), property)
2274 : internal_equal (XCAR (*tortsave), property, 0))
2276 /* Now you see why it's so convenient to have that level
2278 *tortsave = XCDR (XCDR (*tortsave));
2286 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2287 Extract a value from a property list.
2288 PLIST is a property list, which is a list of the form
2289 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2290 corresponding to the given PROP, or DEFAULT if PROP is not
2291 one of the properties on the list.
2293 (plist, prop, default_))
2295 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2296 return UNBOUNDP (val) ? default_ : val;
2299 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2300 Change value in PLIST of PROP to VAL.
2301 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2302 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2303 If PROP is already a property on the list, its value is set to VAL,
2304 otherwise the new PROP VAL pair is added. The new plist is returned;
2305 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2306 The PLIST is modified by side effects.
2310 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2314 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2315 Remove from PLIST the property PROP and its value.
2316 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2317 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2318 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2319 the new value. The PLIST is modified by side effects.
2323 external_remprop (&plist, prop, 0, ERROR_ME);
2327 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2328 Return t if PROP has a value specified in PLIST.
2332 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2333 return UNBOUNDP (val) ? Qnil : Qt;
2336 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2337 Given a plist, signal an error if there is anything wrong with it.
2338 This means that it's a malformed or circular plist.
2342 Lisp_Object *tortoise;
2348 while (!NILP (*tortoise))
2353 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2361 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2362 Given a plist, return non-nil if its format is correct.
2363 If it returns nil, `check-valid-plist' will signal an error when given
2364 the plist; that means it's a malformed or circular plist or has non-symbols
2369 Lisp_Object *tortoise;
2374 while (!NILP (*tortoise))
2379 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2387 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2388 Destructively remove any duplicate entries from a plist.
2389 In such cases, the first entry applies.
2391 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2392 a nil value is removed. This feature is a virus that has infected
2393 old Lisp implementations, but should not be used except for backward
2396 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2397 return value may not be EQ to the passed-in value, so make sure to
2398 `setq' the value back into where it came from.
2400 (plist, nil_means_not_present))
2402 Lisp_Object head = plist;
2404 Fcheck_valid_plist (plist);
2406 while (!NILP (plist))
2408 Lisp_Object prop = Fcar (plist);
2409 Lisp_Object next = Fcdr (plist);
2411 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2412 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2414 if (EQ (head, plist))
2416 plist = Fcdr (next);
2419 /* external_remprop returns 1 if it removed any property.
2420 We have to loop till it didn't remove anything, in case
2421 the property occurs many times. */
2422 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2424 plist = Fcdr (next);
2430 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2431 Extract a value from a lax property list.
2433 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2434 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2435 using `equal' instead of `eq'. This function returns the value
2436 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2437 properties on the list.
2439 (lax_plist, prop, default_))
2441 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2447 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2448 Change value in LAX-PLIST of PROP to VAL.
2449 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2450 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2451 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2452 any object. If PROP is already a property on the list, its value is
2453 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2454 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2455 use the new value. The LAX-PLIST is modified by side effects.
2457 (lax_plist, prop, val))
2459 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2463 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2464 Remove from LAX-PLIST the property PROP and its value.
2465 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2466 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2467 using `equal' instead of `eq'. PROP is usually a symbol. The new
2468 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2469 sure to use the new value. The LAX-PLIST is modified by side effects.
2473 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2477 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2478 Return t if PROP has a value specified in LAX-PLIST.
2479 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2480 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2481 using `equal' instead of `eq'.
2485 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2488 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2489 Destructively remove any duplicate entries from a lax plist.
2490 In such cases, the first entry applies.
2492 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2493 a nil value is removed. This feature is a virus that has infected
2494 old Lisp implementations, but should not be used except for backward
2497 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2498 return value may not be EQ to the passed-in value, so make sure to
2499 `setq' the value back into where it came from.
2501 (lax_plist, nil_means_not_present))
2503 Lisp_Object head = lax_plist;
2505 Fcheck_valid_plist (lax_plist);
2507 while (!NILP (lax_plist))
2509 Lisp_Object prop = Fcar (lax_plist);
2510 Lisp_Object next = Fcdr (lax_plist);
2512 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2513 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2515 if (EQ (head, lax_plist))
2517 lax_plist = Fcdr (next);
2520 /* external_remprop returns 1 if it removed any property.
2521 We have to loop till it didn't remove anything, in case
2522 the property occurs many times. */
2523 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2525 lax_plist = Fcdr (next);
2531 /* In C because the frame props stuff uses it */
2533 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2534 Convert association list ALIST into the equivalent property-list form.
2535 The plist is returned. This converts from
2537 \((a . 1) (b . 2) (c . 3))
2543 The original alist is destroyed in the process of constructing the plist.
2544 See also `alist-to-plist'.
2548 Lisp_Object head = alist;
2549 while (!NILP (alist))
2551 /* remember the alist element. */
2552 Lisp_Object el = Fcar (alist);
2554 Fsetcar (alist, Fcar (el));
2555 Fsetcar (el, Fcdr (el));
2556 Fsetcdr (el, Fcdr (alist));
2557 Fsetcdr (alist, el);
2558 alist = Fcdr (Fcdr (alist));
2564 /* Symbol plists are directly accessible, so we need to protect against
2565 invalid property list structure */
2568 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2570 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2572 return UNBOUNDP (val) ? default_ : val;
2576 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2578 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2582 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2584 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2587 /* We store the string's extent info as the first element of the string's
2588 property list; and the string's MODIFF as the first or second element
2589 of the string's property list (depending on whether the extent info
2590 is present), but only if the string has been modified. This is ugly
2591 but it reduces the memory allocated for the string in the vast
2592 majority of cases, where the string is never modified and has no
2596 static Lisp_Object *
2597 string_plist_ptr (struct Lisp_String *s)
2599 Lisp_Object *ptr = &s->plist;
2601 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2603 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2609 string_getprop (struct Lisp_String *s, Lisp_Object property,
2610 Lisp_Object default_)
2612 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2614 return UNBOUNDP (val) ? default_ : val;
2618 string_putprop (struct Lisp_String *s, Lisp_Object property,
2621 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2625 string_remprop (struct Lisp_String *s, Lisp_Object property)
2627 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2631 string_plist (struct Lisp_String *s)
2633 return *string_plist_ptr (s);
2636 DEFUN ("get", Fget, 2, 3, 0, /*
2637 Return the value of OBJECT's PROPNAME property.
2638 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
2639 If there is no such property, return optional third arg DEFAULT
2640 \(which defaults to `nil'). OBJECT can be a symbol, face, extent,
2641 or string. See also `put', `remprop', and `object-plist'.
2643 (object, propname, default_))
2645 /* Various places in emacs call Fget() and expect it not to quit,
2648 /* It's easiest to treat symbols specially because they may not
2650 if (SYMBOLP (object))
2651 return symbol_getprop (object, propname, default_);
2652 else if (STRINGP (object))
2653 return string_getprop (XSTRING (object), propname, default_);
2654 else if (LRECORDP (object))
2656 CONST struct lrecord_implementation *imp
2657 = XRECORD_LHEADER_IMPLEMENTATION (object);
2662 Lisp_Object val = (imp->getprop) (object, propname);
2671 signal_simple_error ("Object type has no properties", object);
2672 return Qnil; /* Not reached */
2676 DEFUN ("put", Fput, 3, 3, 0, /*
2677 Store OBJECT's PROPNAME property with value VALUE.
2678 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
2679 symbol, face, extent, or string.
2681 For a string, no properties currently have predefined meanings.
2682 For the predefined properties for extents, see `set-extent-property'.
2683 For the predefined properties for faces, see `set-face-property'.
2685 See also `get', `remprop', and `object-plist'.
2687 (object, propname, value))
2689 CHECK_SYMBOL (propname);
2690 CHECK_LISP_WRITEABLE (object);
2692 if (SYMBOLP (object))
2693 symbol_putprop (object, propname, value);
2694 else if (STRINGP (object))
2695 string_putprop (XSTRING (object), propname, value);
2696 else if (LRECORDP (object))
2698 CONST struct lrecord_implementation
2699 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2702 if (! (imp->putprop) (object, propname, value))
2703 signal_simple_error ("Can't set property on object", propname);
2711 signal_simple_error ("Object type has no settable properties", object);
2718 pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
2720 Fput (sym, prop, Fpurecopy (val));
2723 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2724 Remove from OBJECT's property list the property PROPNAME and its
2725 value. OBJECT can be a symbol, face, extent, or string. Returns
2726 non-nil if the property list was actually changed (i.e. if PROPNAME
2727 was present in the property list). See also `get', `put', and
2734 CHECK_SYMBOL (propname);
2735 CHECK_LISP_WRITEABLE (object);
2737 if (SYMBOLP (object))
2738 retval = symbol_remprop (object, propname);
2739 else if (STRINGP (object))
2740 retval = string_remprop (XSTRING (object), propname);
2741 else if (LRECORDP (object))
2743 CONST struct lrecord_implementation
2744 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2747 retval = (imp->remprop) (object, propname);
2749 signal_simple_error ("Can't remove property from object",
2758 signal_simple_error ("Object type has no removable properties", object);
2761 return retval ? Qt : Qnil;
2764 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2765 Return a property list of OBJECT's props.
2766 For a symbol this is equivalent to `symbol-plist'.
2767 Do not modify the property list directly; this may or may not have
2768 the desired effects. (In particular, for a property with a special
2769 interpretation, this will probably have no effect at all.)
2773 if (SYMBOLP (object))
2774 return Fsymbol_plist (object);
2775 else if (STRINGP (object))
2776 return string_plist (XSTRING (object));
2777 else if (LRECORDP (object))
2779 CONST struct lrecord_implementation
2780 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2782 return (imp->plist) (object);
2784 signal_simple_error ("Object type has no properties", object);
2787 signal_simple_error ("Object type has no properties", object);
2794 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2797 error ("Stack overflow in equal");
2799 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2801 /* Note that (equal 20 20.0) should be nil */
2802 if (XTYPE (obj1) != XTYPE (obj2))
2804 if (LRECORDP (obj1))
2806 CONST struct lrecord_implementation
2807 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2808 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2810 return (imp1 == imp2) &&
2811 /* EQ-ness of the objects was noticed above */
2812 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2818 /* Note that we may be calling sub-objects that will use
2819 internal_equal() (instead of internal_old_equal()). Oh well.
2820 We will get an Ebola note if there's any possibility of confusion,
2821 but that seems unlikely. */
2824 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2827 error ("Stack overflow in equal");
2829 if (HACKEQ_UNSAFE (obj1, obj2))
2831 /* Note that (equal 20 20.0) should be nil */
2832 if (XTYPE (obj1) != XTYPE (obj2))
2835 return internal_equal (obj1, obj2, depth);
2838 DEFUN ("equal", Fequal, 2, 2, 0, /*
2839 Return t if two Lisp objects have similar structure and contents.
2840 They must have the same data type.
2841 Conses are compared by comparing the cars and the cdrs.
2842 Vectors and strings are compared element by element.
2843 Numbers are compared by value. Symbols must match exactly.
2847 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2850 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2851 Return t if two Lisp objects have similar structure and contents.
2852 They must have the same data type.
2853 \(Note, however, that an exception is made for characters and integers;
2854 this is known as the "char-int confoundance disease." See `eq' and
2856 This function is provided only for byte-code compatibility with v19.
2861 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2865 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2866 Store each element of ARRAY with ITEM.
2867 ARRAY is a vector, bit vector, or string.
2872 if (STRINGP (array))
2875 struct Lisp_String *s = XSTRING (array);
2876 Charcount len = string_char_length (s);
2878 CHECK_CHAR_COERCE_INT (item);
2879 CHECK_LISP_WRITEABLE (array);
2880 charval = XCHAR (item);
2881 for (i = 0; i < len; i++)
2882 set_string_char (s, i, charval);
2883 bump_string_modiff (array);
2885 else if (VECTORP (array))
2887 Lisp_Object *p = XVECTOR_DATA (array);
2888 int len = XVECTOR_LENGTH (array);
2889 CHECK_LISP_WRITEABLE (array);
2893 else if (BIT_VECTORP (array))
2895 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2896 int len = bit_vector_length (v);
2899 CHECK_LISP_WRITEABLE (array);
2902 set_bit_vector_bit (v, len, bit);
2906 array = wrong_type_argument (Qarrayp, array);
2913 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2915 Lisp_Object args[2];
2916 struct gcpro gcpro1;
2923 RETURN_UNGCPRO (bytecode_nconc2 (args));
2927 bytecode_nconc2 (Lisp_Object *args)
2931 if (CONSP (args[0]))
2933 /* (setcdr (last args[0]) args[1]) */
2934 Lisp_Object tortoise, hare;
2937 for (hare = tortoise = args[0], count = 0;
2938 CONSP (XCDR (hare));
2939 hare = XCDR (hare), count++)
2941 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2944 tortoise = XCDR (tortoise);
2945 if (EQ (hare, tortoise))
2946 signal_circular_list_error (args[0]);
2948 XCDR (hare) = args[1];
2951 else if (NILP (args[0]))
2957 args[0] = wrong_type_argument (args[0], Qlistp);
2962 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2963 Concatenate any number of lists by altering them.
2964 Only the last argument is not altered, and need not be a list.
2966 If the first argument is nil, there is no way to modify it by side
2967 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2968 changing the value of `foo'.
2970 (int nargs, Lisp_Object *args))
2973 struct gcpro gcpro1;
2975 /* The modus operandi in Emacs is "caller gc-protects args".
2976 However, nconc (particularly nconc2 ()) is called many times
2977 in Emacs on freshly created stuff (e.g. you see the idiom
2978 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2979 callers out by protecting the args ourselves to save them
2980 a lot of temporary-variable grief. */
2983 gcpro1.nvars = nargs;
2985 while (argnum < nargs)
2992 /* `val' is the first cons, which will be our return value. */
2993 /* `last_cons' will be the cons cell to mutate. */
2994 Lisp_Object last_cons = val;
2995 Lisp_Object tortoise = val;
2997 for (argnum++; argnum < nargs; argnum++)
2999 Lisp_Object next = args[argnum];
3001 if (CONSP (next) || argnum == nargs -1)
3003 /* (setcdr (last val) next) */
3007 CONSP (XCDR (last_cons));
3008 last_cons = XCDR (last_cons), count++)
3010 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3013 tortoise = XCDR (tortoise);
3014 if (EQ (last_cons, tortoise))
3015 signal_circular_list_error (args[argnum-1]);
3017 XCDR (last_cons) = next;
3019 else if (NILP (next))
3025 next = wrong_type_argument (Qlistp, next);
3029 RETURN_UNGCPRO (val);
3031 else if (NILP (val))
3033 else if (argnum == nargs - 1) /* last arg? */
3034 RETURN_UNGCPRO (val);
3037 args[argnum] = wrong_type_argument (Qlistp, val);
3041 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3045 /* This is the guts of all mapping functions.
3046 Apply fn to each element of seq, one by one,
3047 storing the results into elements of vals, a C vector of Lisp_Objects.
3048 leni is the length of vals, which should also be the length of seq.
3050 If VALS is a null pointer, do not accumulate the results. */
3053 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3056 Lisp_Object args[2];
3058 struct gcpro gcpro1;
3070 for (i = 0; i < leni; i++)
3072 args[1] = XCAR (seq);
3074 result = Ffuncall (2, args);
3075 if (vals) vals[gcpro1.nvars++] = result;
3078 else if (VECTORP (seq))
3080 Lisp_Object *objs = XVECTOR_DATA (seq);
3081 for (i = 0; i < leni; i++)
3084 result = Ffuncall (2, args);
3085 if (vals) vals[gcpro1.nvars++] = result;
3088 else if (STRINGP (seq))
3090 Bufbyte *p = XSTRING_DATA (seq);
3091 for (i = 0; i < leni; i++)
3093 args[1] = make_char (charptr_emchar (p));
3095 result = Ffuncall (2, args);
3096 if (vals) vals[gcpro1.nvars++] = result;
3099 else if (BIT_VECTORP (seq))
3101 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3102 for (i = 0; i < leni; i++)
3104 args[1] = make_int (bit_vector_bit (v, i));
3105 result = Ffuncall (2, args);
3106 if (vals) vals[gcpro1.nvars++] = result;
3110 abort(); /* cannot get here since Flength(seq) did not get an error */
3116 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3117 Apply FN to each element of SEQ, and concat the results as strings.
3118 In between each pair of results, stick in SEP.
3119 Thus, " " as SEP results in spaces between the values returned by FN.
3123 size_t len = XINT (Flength (seq));
3126 struct gcpro gcpro1;
3127 int nargs = len + len - 1;
3129 if (nargs < 0) return build_string ("");
3131 args = alloca_array (Lisp_Object, nargs);
3134 mapcar1 (len, args, fn, seq);
3137 for (i = len - 1; i >= 0; i--)
3138 args[i + i] = args[i];
3140 for (i = 1; i < nargs; i += 2)
3143 return Fconcat (nargs, args);
3146 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3147 Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3148 The result is a list just as long as SEQUENCE.
3149 SEQUENCE may be a list, a vector, a bit vector, or a string.
3153 size_t len = XINT (Flength (seq));
3154 Lisp_Object *args = alloca_array (Lisp_Object, len);
3156 mapcar1 (len, args, fn, seq);
3158 return Flist (len, args);
3161 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3162 Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
3163 The result is a vector of the same length as SEQUENCE.
3164 SEQUENCE may be a list, a vector or a string.
3168 size_t len = XINT (Flength (seq));
3169 Lisp_Object result = make_vector (len, Qnil);
3170 struct gcpro gcpro1;
3173 mapcar1 (len, XVECTOR_DATA (result), fn, seq);
3179 DEFUN ("mapc", Fmapc, 2, 2, 0, /*
3180 Apply FUNCTION to each element of SEQUENCE.
3181 SEQUENCE may be a list, a vector, a bit vector, or a string.
3182 This function is like `mapcar' but does not accumulate the results,
3183 which is more efficient if you do not use the results.
3187 mapcar1 (XINT (Flength (seq)), 0, fn, seq);
3193 /* #### this function doesn't belong in this file! */
3195 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3196 Return list of 1 minute, 5 minute and 15 minute load averages.
3197 Each of the three load averages is multiplied by 100,
3198 then converted to integer.
3200 When USE-FLOATS is non-nil, floats will be used instead of integers.
3201 These floats are not multiplied by 100.
3203 If the 5-minute or 15-minute load averages are not available, return a
3204 shortened list, containing only those averages which are available.
3206 On some systems, this won't work due to permissions on /dev/kmem,
3207 in which case you can't use this.
3212 int loads = getloadavg (load_ave, countof (load_ave));
3213 Lisp_Object ret = Qnil;
3216 error ("load-average not implemented for this operating system");
3218 signal_simple_error ("Could not get load-average",
3219 lisp_strerror (errno));
3223 Lisp_Object load = (NILP (use_floats) ?
3224 make_int ((int) (100.0 * load_ave[loads]))
3225 : make_float (load_ave[loads]));
3226 ret = Fcons (load, ret);
3232 Lisp_Object Vfeatures;
3234 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3235 Return non-nil if feature FEXP is present in this Emacs.
3236 Use this to conditionalize execution of lisp code based on the
3237 presence or absence of emacs or environment extensions.
3238 FEXP can be a symbol, a number, or a list.
3239 If it is a symbol, that symbol is looked up in the `features' variable,
3240 and non-nil will be returned if found.
3241 If it is a number, the function will return non-nil if this Emacs
3242 has an equal or greater version number than FEXP.
3243 If it is a list whose car is the symbol `and', it will return
3244 non-nil if all the features in its cdr are non-nil.
3245 If it is a list whose car is the symbol `or', it will return non-nil
3246 if any of the features in its cdr are non-nil.
3247 If it is a list whose car is the symbol `not', it will return
3248 non-nil if the feature is not present.
3253 => ; Non-nil on XEmacs.
3255 (featurep '(and xemacs gnus))
3256 => ; Non-nil on XEmacs with Gnus loaded.
3258 (featurep '(or tty-frames (and emacs 19.30)))
3259 => ; Non-nil if this Emacs supports TTY frames.
3261 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3262 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3264 NOTE: The advanced arguments of this function (anything other than a
3265 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3266 for supporting multiple Emacs variants, lobby Richard Stallman at
3267 <bug-gnu-emacs@prep.ai.mit.edu>.
3271 #ifndef FEATUREP_SYNTAX
3272 CHECK_SYMBOL (fexp);
3273 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3274 #else /* FEATUREP_SYNTAX */
3275 static double featurep_emacs_version;
3277 /* Brute force translation from Erik Naggum's lisp function. */
3280 /* Original definition */
3281 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3283 else if (INTP (fexp) || FLOATP (fexp))
3285 double d = extract_float (fexp);
3287 if (featurep_emacs_version == 0.0)
3289 featurep_emacs_version = XINT (Vemacs_major_version) +
3290 (XINT (Vemacs_minor_version) / 100.0);
3292 return featurep_emacs_version >= d ? Qt : Qnil;
3294 else if (CONSP (fexp))
3296 Lisp_Object tem = XCAR (fexp);
3302 negate = Fcar (tem);
3304 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3306 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3308 else if (EQ (tem, Qand))
3311 /* Use Fcar/Fcdr for error-checking. */
3312 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3316 return NILP (tem) ? Qt : Qnil;
3318 else if (EQ (tem, Qor))
3321 /* Use Fcar/Fcdr for error-checking. */
3322 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3326 return NILP (tem) ? Qnil : Qt;
3330 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3335 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3338 #endif /* FEATUREP_SYNTAX */
3340 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3341 Announce that FEATURE is a feature of the current Emacs.
3342 This function updates the value of the variable `features'.
3347 CHECK_SYMBOL (feature);
3348 if (!NILP (Vautoload_queue))
3349 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3350 tem = Fmemq (feature, Vfeatures);
3352 Vfeatures = Fcons (feature, Vfeatures);
3353 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3357 DEFUN ("require", Frequire, 1, 2, 0, /*
3358 If feature FEATURE is not loaded, load it from FILENAME.
3359 If FEATURE is not a member of the list `features', then the feature
3360 is not loaded; so load the file FILENAME.
3361 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3363 (feature, file_name))
3366 CHECK_SYMBOL (feature);
3367 tem = Fmemq (feature, Vfeatures);
3368 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3373 int speccount = specpdl_depth ();
3375 /* Value saved here is to be restored into Vautoload_queue */
3376 record_unwind_protect (un_autoload, Vautoload_queue);
3377 Vautoload_queue = Qt;
3379 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3382 tem = Fmemq (feature, Vfeatures);
3384 error ("Required feature %s was not provided",
3385 string_data (XSYMBOL (feature)->name));
3387 /* Once loading finishes, don't undo it. */
3388 Vautoload_queue = Qt;
3389 return unbind_to (speccount, feature);
3393 /* base64 encode/decode functions.
3395 Originally based on code from GNU recode. Ported to FSF Emacs by
3396 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3397 subsequently heavily hacked by Hrvoje Niksic. */
3399 #define MIME_LINE_LENGTH 72
3401 #define IS_ASCII(Character) \
3403 #define IS_BASE64(Character) \
3404 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3406 /* Table of characters coding the 64 values. */
3407 static char base64_value_to_char[64] =
3409 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3410 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3411 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3412 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3413 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3414 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3415 '8', '9', '+', '/' /* 60-63 */
3418 /* Table of base64 values for first 128 characters. */
3419 static short base64_char_to_value[128] =
3421 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3422 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3423 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3424 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3425 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3426 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3427 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3428 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3429 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3430 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3431 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3432 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3433 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3436 /* The following diagram shows the logical steps by which three octets
3437 get transformed into four base64 characters.
3439 .--------. .--------. .--------.
3440 |aaaaaabb| |bbbbcccc| |ccdddddd|
3441 `--------' `--------' `--------'
3443 .--------+--------+--------+--------.
3444 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3445 `--------+--------+--------+--------'
3447 .--------+--------+--------+--------.
3448 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3449 `--------+--------+--------+--------'
3451 The octets are divided into 6 bit chunks, which are then encoded into
3452 base64 characters. */
3454 #define ADVANCE_INPUT(c, stream) \
3455 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3457 (signal_simple_error ("Non-ascii character in base64 input", \
3458 make_char (ec)), 0) \
3459 : (c = (Bufbyte)ec), 1))
3462 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3464 EMACS_INT counter = 0;
3472 if (!ADVANCE_INPUT (c, istream))
3475 /* Wrap line every 76 characters. */
3478 if (counter < MIME_LINE_LENGTH / 4)
3487 /* Process first byte of a triplet. */
3488 *e++ = base64_value_to_char[0x3f & c >> 2];
3489 value = (0x03 & c) << 4;
3491 /* Process second byte of a triplet. */
3492 if (!ADVANCE_INPUT (c, istream))
3494 *e++ = base64_value_to_char[value];
3500 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3501 value = (0x0f & c) << 2;
3503 /* Process third byte of a triplet. */
3504 if (!ADVANCE_INPUT (c, istream))
3506 *e++ = base64_value_to_char[value];
3511 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3512 *e++ = base64_value_to_char[0x3f & c];
3517 #undef ADVANCE_INPUT
3519 /* Get next character from the stream, except that non-base64
3520 characters are ignored. This is in accordance with rfc2045. EC
3521 should be an Emchar, so that it can hold -1 as the value for EOF. */
3522 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3523 ec = Lstream_get_emchar (stream); \
3525 /* IS_BASE64 may not be called with negative arguments so check for \
3527 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3531 #define STORE_BYTE(pos, val, ccnt) do { \
3532 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3537 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3541 EMACS_INT streampos = 0;
3546 unsigned long value;
3548 /* Process first byte of a quadruplet. */
3549 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3553 signal_simple_error ("Illegal `=' character while decoding base64",
3554 make_int (streampos));
3555 value = base64_char_to_value[ec] << 18;
3557 /* Process second byte of a quadruplet. */
3558 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3560 error ("Premature EOF while decoding base64");
3562 signal_simple_error ("Illegal `=' character while decoding base64",
3563 make_int (streampos));
3564 value |= base64_char_to_value[ec] << 12;
3565 STORE_BYTE (e, value >> 16, ccnt);
3567 /* Process third byte of a quadruplet. */
3568 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3570 error ("Premature EOF while decoding base64");
3574 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3576 error ("Premature EOF while decoding base64");
3578 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3579 make_int (streampos));
3583 value |= base64_char_to_value[ec] << 6;
3584 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3586 /* Process fourth byte of a quadruplet. */
3587 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3589 error ("Premature EOF while decoding base64");
3593 value |= base64_char_to_value[ec];
3594 STORE_BYTE (e, 0xff & value, ccnt);
3600 #undef ADVANCE_INPUT
3601 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3605 free_malloced_ptr (Lisp_Object unwind_obj)
3607 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3609 free_opaque_ptr (unwind_obj);
3613 /* Don't use alloca for regions larger than this, lest we overflow
3615 #define MAX_ALLOCA 65536
3617 /* We need to setup proper unwinding, because there is a number of
3618 ways these functions can blow up, and we don't want to have memory
3619 leaks in those cases. */
3620 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3621 size_t XOA_len = (len); \
3622 if (XOA_len > MAX_ALLOCA) \
3624 ptr = xnew_array (type, XOA_len); \
3625 record_unwind_protect (free_malloced_ptr, \
3626 make_opaque_ptr ((void *)ptr)); \
3629 ptr = alloca_array (type, XOA_len); \
3632 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3633 if ((len) > MAX_ALLOCA) \
3634 unbind_to (speccount, Qnil); \
3637 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3638 Base64-encode the region between BEG and END.
3639 Return the length of the encoded text.
3640 Optional third argument NO-LINE-BREAK means do not break long lines
3643 (beg, end, no_line_break))
3646 Bytind encoded_length;
3647 Charcount allength, length;
3648 struct buffer *buf = current_buffer;
3649 Bufpos begv, zv, old_pt = BUF_PT (buf);
3651 int speccount = specpdl_depth();
3653 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3654 barf_if_buffer_read_only (buf, begv, zv);
3656 /* We need to allocate enough room for encoding the text.
3657 We need 33 1/3% more space, plus a newline every 76
3658 characters, and then we round up. */
3660 allength = length + length/3 + 1;
3661 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3663 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3664 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3665 base64 characters will be single-byte. */
3666 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3667 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3668 NILP (no_line_break));
3669 if (encoded_length > allength)
3671 Lstream_delete (XLSTREAM (input));
3673 /* Now we have encoded the region, so we insert the new contents
3674 and delete the old. (Insert first in order to preserve markers.) */
3675 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3676 XMALLOC_UNBIND (encoded, allength, speccount);
3677 buffer_delete_range (buf, begv + encoded_length, zv + encoded_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 /* We return the length of the encoded text. */
3685 return make_int (encoded_length);
3688 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3689 Base64 encode STRING and return the result.
3691 (string, no_line_break))
3693 Charcount allength, length;
3694 Bytind encoded_length;
3696 Lisp_Object input, result;
3697 int speccount = specpdl_depth();
3699 CHECK_STRING (string);
3701 length = XSTRING_CHAR_LENGTH (string);
3702 allength = length + length/3 + 1;
3703 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3705 input = make_lisp_string_input_stream (string, 0, -1);
3706 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3707 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3708 NILP (no_line_break));
3709 if (encoded_length > allength)
3711 Lstream_delete (XLSTREAM (input));
3712 result = make_string (encoded, encoded_length);
3713 XMALLOC_UNBIND (encoded, allength, speccount);
3717 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3718 Base64-decode the region between BEG and END.
3719 Return the length of the decoded text.
3720 If the region can't be decoded, return nil and don't modify the buffer.
3721 Characters out of the base64 alphabet are ignored.
3725 struct buffer *buf = current_buffer;
3726 Bufpos begv, zv, old_pt = BUF_PT (buf);
3728 Bytind decoded_length;
3729 Charcount length, cc_decoded_length;
3731 int speccount = specpdl_depth();
3733 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3734 barf_if_buffer_read_only (buf, begv, zv);
3738 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3739 /* We need to allocate enough room for decoding the text. */
3740 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3741 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3742 if (decoded_length > length * MAX_EMCHAR_LEN)
3744 Lstream_delete (XLSTREAM (input));
3746 /* Now we have decoded the region, so we insert the new contents
3747 and delete the old. (Insert first in order to preserve markers.) */
3748 BUF_SET_PT (buf, begv);
3749 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3750 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3751 buffer_delete_range (buf, begv + cc_decoded_length,
3752 zv + cc_decoded_length, 0);
3754 /* Simulate FSF Emacs implementation of this function: if point was
3755 in the region, place it at the beginning. */
3756 if (old_pt >= begv && old_pt < zv)
3757 BUF_SET_PT (buf, begv);
3759 return make_int (cc_decoded_length);
3762 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3763 Base64-decode STRING and return the result.
3764 Characters out of the base64 alphabet are ignored.
3769 Bytind decoded_length;
3770 Charcount length, cc_decoded_length;
3771 Lisp_Object input, result;
3772 int speccount = specpdl_depth();
3774 CHECK_STRING (string);
3776 length = XSTRING_CHAR_LENGTH (string);
3777 /* We need to allocate enough room for decoding the text. */
3778 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3780 input = make_lisp_string_input_stream (string, 0, -1);
3781 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3782 &cc_decoded_length);
3783 if (decoded_length > length * MAX_EMCHAR_LEN)
3785 Lstream_delete (XLSTREAM (input));
3787 result = make_string (decoded, decoded_length);
3788 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3792 Lisp_Object Qyes_or_no_p;
3797 defsymbol (&Qstring_lessp, "string-lessp");
3798 defsymbol (&Qidentity, "identity");
3799 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3801 DEFSUBR (Fidentity);
3804 DEFSUBR (Fsafe_length);
3805 DEFSUBR (Fstring_equal);
3806 DEFSUBR (Fstring_lessp);
3807 DEFSUBR (Fstring_modified_tick);
3811 DEFSUBR (Fbvconcat);
3812 DEFSUBR (Fcopy_list);
3813 DEFSUBR (Fcopy_sequence);
3814 DEFSUBR (Fcopy_alist);
3815 DEFSUBR (Fcopy_tree);
3816 DEFSUBR (Fsubstring);
3823 DEFSUBR (Fnbutlast);
3825 DEFSUBR (Fold_member);
3827 DEFSUBR (Fold_memq);
3829 DEFSUBR (Fold_assoc);
3831 DEFSUBR (Fold_assq);
3833 DEFSUBR (Fold_rassoc);
3835 DEFSUBR (Fold_rassq);
3837 DEFSUBR (Fold_delete);
3839 DEFSUBR (Fold_delq);
3840 DEFSUBR (Fremassoc);
3842 DEFSUBR (Fremrassoc);
3843 DEFSUBR (Fremrassq);
3844 DEFSUBR (Fnreverse);
3847 DEFSUBR (Fplists_eq);
3848 DEFSUBR (Fplists_equal);
3849 DEFSUBR (Flax_plists_eq);
3850 DEFSUBR (Flax_plists_equal);
3851 DEFSUBR (Fplist_get);
3852 DEFSUBR (Fplist_put);
3853 DEFSUBR (Fplist_remprop);
3854 DEFSUBR (Fplist_member);
3855 DEFSUBR (Fcheck_valid_plist);
3856 DEFSUBR (Fvalid_plist_p);
3857 DEFSUBR (Fcanonicalize_plist);
3858 DEFSUBR (Flax_plist_get);
3859 DEFSUBR (Flax_plist_put);
3860 DEFSUBR (Flax_plist_remprop);
3861 DEFSUBR (Flax_plist_member);
3862 DEFSUBR (Fcanonicalize_lax_plist);
3863 DEFSUBR (Fdestructive_alist_to_plist);
3867 DEFSUBR (Fobject_plist);
3869 DEFSUBR (Fold_equal);
3870 DEFSUBR (Ffillarray);
3873 DEFSUBR (Fmapvector);
3875 DEFSUBR (Fmapconcat);
3876 DEFSUBR (Fload_average);
3877 DEFSUBR (Ffeaturep);
3880 DEFSUBR (Fbase64_encode_region);
3881 DEFSUBR (Fbase64_encode_string);
3882 DEFSUBR (Fbase64_decode_region);
3883 DEFSUBR (Fbase64_decode_string);
3887 init_provide_once (void)
3889 DEFVAR_LISP ("features", &Vfeatures /*
3890 A list of symbols which are the features of the executing emacs.
3891 Used by `featurep' and `require', and altered by `provide'.
3895 Fprovide (intern ("base64"));