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,
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
342 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
343 /* Compare strings using collation order of locale. */
344 /* Need to be tricky to handle embedded nulls. */
346 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
348 int val = strcoll ((char *) string_data (p1) + i,
349 (char *) string_data (p2) + i);
355 #else /* not I18N2, or MULE */
356 /* #### It is not really necessary to do this: We could compare
357 byte-by-byte and still get a reasonable comparison, since this
358 would compare characters with a charset in the same way.
359 With a little rearrangement of the leading bytes, we could
360 make most inter-charset comparisons work out the same, too;
361 even if some don't, this is not a big deal because inter-charset
362 comparisons aren't really well-defined anyway. */
363 for (i = 0; i < end; i++)
365 if (string_char (p1, i) != string_char (p2, i))
366 return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
368 #endif /* not I18N2, or MULE */
369 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
370 won't work right in I18N2 case */
371 return end < len2 ? Qt : Qnil;
374 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
375 Return STRING's tick counter, incremented for each change to the string.
376 Each string has a tick counter which is incremented each time the contents
377 of the string are changed (e.g. with `aset'). It wraps around occasionally.
381 struct Lisp_String *s;
383 CHECK_STRING (string);
384 s = XSTRING (string);
385 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
386 return XCAR (s->plist);
392 bump_string_modiff (Lisp_Object str)
394 struct Lisp_String *s = XSTRING (str);
395 Lisp_Object *ptr = &s->plist;
398 /* #### remove the `string-translatable' property from the string,
401 /* skip over extent info if it's there */
402 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
404 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
405 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
407 *ptr = Fcons (make_int (1), *ptr);
411 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
412 static Lisp_Object concat (int nargs, Lisp_Object *args,
413 enum concat_target_type target_type,
417 concat2 (Lisp_Object s1, Lisp_Object s2)
422 return concat (2, args, c_string, 0);
426 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
432 return concat (3, args, c_string, 0);
436 vconcat2 (Lisp_Object s1, Lisp_Object s2)
441 return concat (2, args, c_vector, 0);
445 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
451 return concat (3, args, c_vector, 0);
454 DEFUN ("append", Fappend, 0, MANY, 0, /*
455 Concatenate all the arguments and make the result a list.
456 The result is a list whose elements are the elements of all the arguments.
457 Each argument may be a list, vector, bit vector, or string.
458 The last argument is not copied, just used as the tail of the new list.
461 (int nargs, Lisp_Object *args))
463 return concat (nargs, args, c_cons, 1);
466 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
467 Concatenate all the arguments and make the result a string.
468 The result is a string whose elements are the elements of all the arguments.
469 Each argument may be a string or a list or vector of characters.
471 As of XEmacs 21.0, this function does NOT accept individual integers
472 as arguments. Old code that relies on, for example, (concat "foo" 50)
473 returning "foo50" will fail. To fix such code, either apply
474 `int-to-string' to the integer argument, or use `format'.
476 (int nargs, Lisp_Object *args))
478 return concat (nargs, args, c_string, 0);
481 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
482 Concatenate all the arguments and make the result a vector.
483 The result is a vector whose elements are the elements of all the arguments.
484 Each argument may be a list, vector, bit vector, or string.
486 (int nargs, Lisp_Object *args))
488 return concat (nargs, args, c_vector, 0);
491 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
492 Concatenate all the arguments and make the result a bit vector.
493 The result is a bit vector whose elements are the elements of all the
494 arguments. Each argument may be a list, vector, bit vector, or string.
496 (int nargs, Lisp_Object *args))
498 return concat (nargs, args, c_bit_vector, 0);
501 /* Copy a (possibly dotted) list. LIST must be a cons.
502 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
504 copy_list (Lisp_Object list)
506 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
507 Lisp_Object last = list_copy;
508 Lisp_Object hare, tortoise;
511 for (tortoise = hare = XCDR (list), len = 1;
513 hare = XCDR (hare), len++)
515 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
518 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
521 tortoise = XCDR (tortoise);
522 if (EQ (tortoise, hare))
523 signal_circular_list_error (list);
529 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
530 Return a copy of list LIST, which may be a dotted list.
531 The elements of LIST are not copied; they are shared
537 if (NILP (list)) return list;
538 if (CONSP (list)) return copy_list (list);
540 list = wrong_type_argument (Qlistp, list);
544 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
545 Return a copy of list, vector, bit vector or string SEQUENCE.
546 The elements of a list or vector are not copied; they are shared
547 with the original. SEQUENCE may be a dotted list.
552 if (NILP (sequence)) return sequence;
553 if (CONSP (sequence)) return copy_list (sequence);
554 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
555 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
556 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
558 check_losing_bytecode ("copy-sequence", sequence);
559 sequence = wrong_type_argument (Qsequencep, sequence);
563 struct merge_string_extents_struct
566 Bytecount entry_offset;
567 Bytecount entry_length;
571 concat (int nargs, Lisp_Object *args,
572 enum concat_target_type target_type,
576 Lisp_Object tail = Qnil;
579 Lisp_Object last_tail;
581 struct merge_string_extents_struct *args_mse = 0;
582 Bufbyte *string_result = 0;
583 Bufbyte *string_result_ptr = 0;
586 /* The modus operandi in Emacs is "caller gc-protects args".
587 However, concat is called many times in Emacs on freshly
588 created stuff. So we help those callers out by protecting
589 the args ourselves to save them a lot of temporary-variable
593 gcpro1.nvars = nargs;
596 /* #### if the result is a string and any of the strings have a string
597 for the `string-translatable' property, then concat should also
598 concat the args but use the `string-translatable' strings, and store
599 the result in the returned string's `string-translatable' property. */
601 if (target_type == c_string)
602 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
604 /* In append, the last arg isn't treated like the others */
605 if (last_special && nargs > 0)
608 last_tail = args[nargs];
613 /* Check and coerce the arguments. */
614 for (argnum = 0; argnum < nargs; argnum++)
616 Lisp_Object seq = args[argnum];
619 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
621 #ifdef LOSING_BYTECODE
622 else if (COMPILED_FUNCTIONP (seq))
623 /* Urk! We allow this, for "compatibility"... */
626 #if 0 /* removed for XEmacs 21 */
628 /* This is too revolting to think about but maintains
629 compatibility with FSF (and lots and lots of old code). */
630 args[argnum] = Fnumber_to_string (seq);
634 check_losing_bytecode ("concat", seq);
635 args[argnum] = wrong_type_argument (Qsequencep, seq);
641 args_mse[argnum].string = seq;
643 args_mse[argnum].string = Qnil;
648 /* Charcount is a misnomer here as we might be dealing with the
649 length of a vector or list, but emphasizes that we're not dealing
650 with Bytecounts in strings */
651 Charcount total_length;
653 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
655 #ifdef LOSING_BYTECODE
656 Charcount thislen = length_with_bytecode_hack (args[argnum]);
658 Charcount thislen = XINT (Flength (args[argnum]));
660 total_length += thislen;
666 if (total_length == 0)
667 /* In append, if all but last arg are nil, return last arg */
668 RETURN_UNGCPRO (last_tail);
669 val = Fmake_list (make_int (total_length), Qnil);
672 val = make_vector (total_length, Qnil);
675 val = make_bit_vector (total_length, Qzero);
678 /* We don't make the string yet because we don't know the
679 actual number of bytes. This loop was formerly written
680 to call Fmake_string() here and then call set_string_char()
681 for each char. This seems logical enough but is waaaaaaaay
682 slow -- set_string_char() has to scan the whole string up
683 to the place where the substitution is called for in order
684 to find the place to change, and may have to do some
685 realloc()ing in order to make the char fit properly.
688 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
689 string_result_ptr = string_result;
698 tail = val, toindex = -1; /* -1 in toindex is flag we are
705 for (argnum = 0; argnum < nargs; argnum++)
707 Charcount thisleni = 0;
708 Charcount thisindex = 0;
709 Lisp_Object seq = args[argnum];
710 Bufbyte *string_source_ptr = 0;
711 Bufbyte *string_prev_result_ptr = string_result_ptr;
715 #ifdef LOSING_BYTECODE
716 thisleni = length_with_bytecode_hack (seq);
718 thisleni = XINT (Flength (seq));
722 string_source_ptr = XSTRING_DATA (seq);
728 /* We've come to the end of this arg, so exit. */
732 /* Fetch next element of `seq' arg into `elt' */
740 if (thisindex >= thisleni)
745 elt = make_char (charptr_emchar (string_source_ptr));
746 INC_CHARPTR (string_source_ptr);
748 else if (VECTORP (seq))
749 elt = XVECTOR_DATA (seq)[thisindex];
750 else if (BIT_VECTORP (seq))
751 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
754 elt = Felt (seq, make_int (thisindex));
758 /* Store into result */
761 /* toindex negative means we are making a list */
766 else if (VECTORP (val))
767 XVECTOR_DATA (val)[toindex++] = elt;
768 else if (BIT_VECTORP (val))
771 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
775 CHECK_CHAR_COERCE_INT (elt);
776 string_result_ptr += set_charptr_emchar (string_result_ptr,
782 args_mse[argnum].entry_offset =
783 string_prev_result_ptr - string_result;
784 args_mse[argnum].entry_length =
785 string_result_ptr - string_prev_result_ptr;
789 /* Now we finally make the string. */
790 if (target_type == c_string)
792 val = make_string (string_result, string_result_ptr - string_result);
793 for (argnum = 0; argnum < nargs; argnum++)
795 if (STRINGP (args_mse[argnum].string))
796 copy_string_extents (val, args_mse[argnum].string,
797 args_mse[argnum].entry_offset, 0,
798 args_mse[argnum].entry_length);
803 XCDR (prev) = last_tail;
805 RETURN_UNGCPRO (val);
808 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
809 Return a copy of ALIST.
810 This is an alist which represents the same mapping from objects to objects,
811 but does not share the alist structure with ALIST.
812 The objects mapped (cars and cdrs of elements of the alist)
814 Elements of ALIST that are not conses are also shared.
824 alist = concat (1, &alist, c_cons, 0);
825 for (tail = alist; CONSP (tail); tail = XCDR (tail))
827 Lisp_Object car = XCAR (tail);
830 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
835 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
836 Return a copy of a list and substructures.
837 The argument is copied, and any lists contained within it are copied
838 recursively. Circularities and shared substructures are not preserved.
839 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
847 rest = arg = Fcopy_sequence (arg);
850 Lisp_Object elt = XCAR (rest);
852 if (CONSP (elt) || VECTORP (elt))
853 XCAR (rest) = Fcopy_tree (elt, vecp);
854 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
855 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
859 else if (VECTORP (arg) && ! NILP (vecp))
861 int i = XVECTOR_LENGTH (arg);
863 arg = Fcopy_sequence (arg);
864 for (j = 0; j < i; j++)
866 Lisp_Object elt = XVECTOR_DATA (arg) [j];
868 if (CONSP (elt) || VECTORP (elt))
869 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
875 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
876 Return a substring of STRING, starting at index FROM and ending before TO.
877 TO may be nil or omitted; then the substring runs to the end of STRING.
878 If FROM or TO is negative, it counts from the end.
879 Relevant parts of the string-extent-data are copied in the new string.
883 Charcount ccfr, ccto;
887 CHECK_STRING (string);
889 get_string_range_char (string, from, to, &ccfr, &ccto,
890 GB_HISTORICAL_STRING_BEHAVIOR);
891 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
892 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
893 val = make_string (XSTRING_DATA (string) + bfr, blen);
894 /* Copy any applicable extent information into the new string: */
895 copy_string_extents (val, string, 0, bfr, blen);
899 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
900 Return a subsequence of SEQ, starting at index FROM and ending before TO.
901 TO may be nil or omitted; then the subsequence runs to the end of SEQ.
902 If FROM or TO is negative, it counts from the end.
903 The resulting subsequence is always the same type as the original
905 If SEQ is a string, relevant parts of the string-extent-data are copied
913 return Fsubstring (seq, from, to);
915 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
917 check_losing_bytecode ("subseq", seq);
918 seq = wrong_type_argument (Qsequencep, seq);
921 len = XINT (Flength (seq));
938 if (!(0 <= f && f <= t && t <= len))
939 args_out_of_range_3 (seq, make_int (f), make_int (t));
943 Lisp_Object result = make_vector (t - f, Qnil);
945 Lisp_Object *in_elts = XVECTOR_DATA (seq);
946 Lisp_Object *out_elts = XVECTOR_DATA (result);
948 for (i = f; i < t; i++)
949 out_elts[i - f] = in_elts[i];
955 Lisp_Object result = Qnil;
958 seq = Fnthcdr (make_int (f), seq);
960 for (i = f; i < t; i++)
962 result = Fcons (Fcar (seq), result);
966 return Fnreverse (result);
971 Lisp_Object result = make_bit_vector (t - f, Qzero);
974 for (i = f; i < t; i++)
975 set_bit_vector_bit (XBIT_VECTOR (result), i - f,
976 bit_vector_bit (XBIT_VECTOR (seq), i));
982 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
983 Take cdr N times on LIST, and return the result.
988 REGISTER Lisp_Object tail = list;
990 for (i = XINT (n); i; i--)
994 else if (NILP (tail))
998 tail = wrong_type_argument (Qlistp, tail);
1005 DEFUN ("nth", Fnth, 2, 2, 0, /*
1006 Return the Nth element of LIST.
1007 N counts from zero. If LIST is not that long, nil is returned.
1011 return Fcar (Fnthcdr (n, list));
1014 DEFUN ("elt", Felt, 2, 2, 0, /*
1015 Return element of SEQUENCE at index N.
1020 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1021 if (LISTP (sequence))
1023 Lisp_Object tem = Fnthcdr (n, sequence);
1024 /* #### Utterly, completely, fucking disgusting.
1025 * #### The whole point of "elt" is that it operates on
1026 * #### sequences, and does error- (bounds-) checking.
1032 /* This is The Way It Has Always Been. */
1035 /* This is The Way Mly and Cltl2 say It Should Be. */
1036 args_out_of_range (sequence, n);
1039 else if (STRINGP (sequence) ||
1040 VECTORP (sequence) ||
1041 BIT_VECTORP (sequence))
1042 return Faref (sequence, n);
1043 #ifdef LOSING_BYTECODE
1044 else if (COMPILED_FUNCTIONP (sequence))
1050 args_out_of_range (sequence, n);
1052 /* Utter perversity */
1054 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1057 case COMPILED_ARGLIST:
1058 return compiled_function_arglist (f);
1059 case COMPILED_INSTRUCTIONS:
1060 return compiled_function_instructions (f);
1061 case COMPILED_CONSTANTS:
1062 return compiled_function_constants (f);
1063 case COMPILED_STACK_DEPTH:
1064 return compiled_function_stack_depth (f);
1065 case COMPILED_DOC_STRING:
1066 return compiled_function_documentation (f);
1067 case COMPILED_DOMAIN:
1068 return compiled_function_domain (f);
1069 case COMPILED_INTERACTIVE:
1070 if (f->flags.interactivep)
1071 return compiled_function_interactive (f);
1072 /* if we return nil, can't tell interactive with no args
1073 from noninteractive. */
1080 #endif /* LOSING_BYTECODE */
1083 check_losing_bytecode ("elt", sequence);
1084 sequence = wrong_type_argument (Qsequencep, sequence);
1089 DEFUN ("last", Flast, 1, 2, 0, /*
1090 Return the tail of list LIST, of length N (default 1).
1091 LIST may be a dotted list, but not a circular list.
1092 Optional argument N must be a non-negative integer.
1093 If N is zero, then the atom that terminates the list is returned.
1094 If N is greater than the length of LIST, then LIST itself is returned.
1099 Lisp_Object retval, tortoise, hare;
1111 for (retval = tortoise = hare = list, count = 0;
1114 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1117 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1120 tortoise = XCDR (tortoise);
1121 if (EQ (hare, tortoise))
1122 signal_circular_list_error (list);
1128 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1129 Modify LIST to remove the last N (default 1) elements.
1130 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1147 Lisp_Object last_cons = list;
1149 EXTERNAL_LIST_LOOP_1 (list)
1152 last_cons = XCDR (last_cons);
1158 XCDR (last_cons) = Qnil;
1163 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1164 Return a copy of LIST with the last N (default 1) elements removed.
1165 If LIST has N or fewer elements, nil is returned.
1182 Lisp_Object retval = Qnil;
1183 Lisp_Object tail = list;
1185 EXTERNAL_LIST_LOOP_1 (list)
1189 retval = Fcons (XCAR (tail), retval);
1194 return Fnreverse (retval);
1198 DEFUN ("member", Fmember, 2, 2, 0, /*
1199 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1200 The value is actually the tail of LIST whose car is ELT.
1204 Lisp_Object list_elt, tail;
1205 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1207 if (internal_equal (elt, list_elt, 0))
1213 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1214 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1215 The value is actually the tail of LIST whose car is ELT.
1216 This function is provided only for byte-code compatibility with v19.
1221 Lisp_Object list_elt, tail;
1222 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1224 if (internal_old_equal (elt, list_elt, 0))
1230 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1231 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1232 The value is actually the tail of LIST whose car is ELT.
1236 Lisp_Object list_elt, tail;
1237 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1239 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1245 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1246 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1247 The value is actually the tail of LIST whose car is ELT.
1248 This function is provided only for byte-code compatibility with v19.
1253 Lisp_Object list_elt, tail;
1254 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1256 if (HACKEQ_UNSAFE (elt, list_elt))
1263 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1265 Lisp_Object list_elt, tail;
1266 LIST_LOOP_3 (list_elt, list, tail)
1268 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1274 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1275 Return non-nil if KEY is `equal' to the car of an element of LIST.
1276 The value is actually the element of LIST whose car equals KEY.
1280 /* This function can GC. */
1281 Lisp_Object elt, elt_car, elt_cdr;
1282 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1284 if (internal_equal (key, elt_car, 0))
1290 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1291 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1292 The value is actually the element of LIST whose car equals KEY.
1296 /* This function can GC. */
1297 Lisp_Object elt, elt_car, elt_cdr;
1298 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1300 if (internal_old_equal (key, elt_car, 0))
1307 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1309 int speccount = specpdl_depth ();
1310 specbind (Qinhibit_quit, Qt);
1311 return unbind_to (speccount, Fassoc (key, list));
1314 DEFUN ("assq", Fassq, 2, 2, 0, /*
1315 Return non-nil if KEY is `eq' to the car of an element of LIST.
1316 The value is actually the element of LIST whose car is KEY.
1317 Elements of LIST that are not conses are ignored.
1321 Lisp_Object elt, elt_car, elt_cdr;
1322 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1324 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1330 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1331 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1332 The value is actually the element of LIST whose car is KEY.
1333 Elements of LIST that are not conses are ignored.
1334 This function is provided only for byte-code compatibility with v19.
1339 Lisp_Object elt, elt_car, elt_cdr;
1340 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1342 if (HACKEQ_UNSAFE (key, elt_car))
1348 /* Like Fassq but never report an error and do not allow quits.
1349 Use only on lists known never to be circular. */
1352 assq_no_quit (Lisp_Object key, Lisp_Object list)
1354 /* This cannot GC. */
1356 LIST_LOOP_2 (elt, list)
1358 Lisp_Object elt_car = XCAR (elt);
1359 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1365 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1366 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1367 The value is actually the element of LIST whose cdr equals KEY.
1371 Lisp_Object elt, elt_car, elt_cdr;
1372 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1374 if (internal_equal (key, elt_cdr, 0))
1380 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1381 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1382 The value is actually the element of LIST whose cdr equals KEY.
1386 Lisp_Object elt, elt_car, elt_cdr;
1387 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1389 if (internal_old_equal (key, elt_cdr, 0))
1395 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1396 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1397 The value is actually the element of LIST whose cdr is KEY.
1401 Lisp_Object elt, elt_car, elt_cdr;
1402 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1404 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1410 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1411 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1412 The value is actually the element of LIST whose cdr is KEY.
1416 Lisp_Object elt, elt_car, elt_cdr;
1417 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1419 if (HACKEQ_UNSAFE (key, elt_cdr))
1425 /* Like Frassq, but caller must ensure that LIST is properly
1426 nil-terminated and ebola-free. */
1428 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1431 LIST_LOOP_2 (elt, list)
1433 Lisp_Object elt_cdr = XCDR (elt);
1434 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1441 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1442 Delete by side effect any occurrences of ELT as a member of LIST.
1443 The modified LIST is returned. Comparison is done with `equal'.
1444 If the first member of LIST is ELT, there is no way to remove it by side
1445 effect; therefore, write `(setq foo (delete element foo))' to be sure
1446 of changing the value of `foo'.
1451 Lisp_Object list_elt;
1452 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1453 (internal_equal (elt, list_elt, 0)));
1457 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1458 Delete by side effect any occurrences of ELT as a member of LIST.
1459 The modified LIST is returned. Comparison is done with `old-equal'.
1460 If the first member of LIST is ELT, there is no way to remove it by side
1461 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1462 of changing the value of `foo'.
1466 Lisp_Object list_elt;
1467 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1468 (internal_old_equal (elt, list_elt, 0)));
1472 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1473 Delete by side effect any occurrences of ELT as a member of LIST.
1474 The modified LIST is returned. Comparison is done with `eq'.
1475 If the first member of LIST is ELT, there is no way to remove it by side
1476 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1477 changing the value of `foo'.
1481 Lisp_Object list_elt;
1482 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1483 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1487 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1488 Delete by side effect any occurrences of ELT as a member of LIST.
1489 The modified LIST is returned. Comparison is done with `old-eq'.
1490 If the first member of LIST is ELT, there is no way to remove it by side
1491 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1492 changing the value of `foo'.
1496 Lisp_Object list_elt;
1497 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1498 (HACKEQ_UNSAFE (elt, list_elt)));
1502 /* Like Fdelq, but caller must ensure that LIST is properly
1503 nil-terminated and ebola-free. */
1506 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1508 Lisp_Object list_elt;
1509 LIST_LOOP_DELETE_IF (list_elt, list,
1510 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1514 /* Be VERY careful with this. This is like delq_no_quit() but
1515 also calls free_cons() on the removed conses. You must be SURE
1516 that no pointers to the freed conses remain around (e.g.
1517 someone else is pointing to part of the list). This function
1518 is useful on internal lists that are used frequently and where
1519 the actual list doesn't escape beyond known code bounds. */
1522 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1524 REGISTER Lisp_Object tail = list;
1525 REGISTER Lisp_Object prev = Qnil;
1527 while (!NILP (tail))
1529 REGISTER Lisp_Object tem = XCAR (tail);
1532 Lisp_Object cons_to_free = tail;
1536 XCDR (prev) = XCDR (tail);
1538 free_cons (XCONS (cons_to_free));
1549 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1550 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1551 The modified LIST is returned. If the first member of LIST has a car
1552 that is `equal' to KEY, there is no way to remove it by side effect;
1553 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1559 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1561 internal_equal (key, XCAR (elt), 0)));
1566 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1568 int speccount = specpdl_depth ();
1569 specbind (Qinhibit_quit, Qt);
1570 return unbind_to (speccount, Fremassoc (key, list));
1573 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1574 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1575 The modified LIST is returned. If the first member of LIST has a car
1576 that is `eq' to KEY, there is no way to remove it by side effect;
1577 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1583 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1585 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1589 /* no quit, no errors; be careful */
1592 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1595 LIST_LOOP_DELETE_IF (elt, list,
1597 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1601 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1602 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1603 The modified LIST is returned. If the first member of LIST has a car
1604 that is `equal' to VALUE, there is no way to remove it by side effect;
1605 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1611 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1613 internal_equal (value, XCDR (elt), 0)));
1617 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1618 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1619 The modified LIST is returned. If the first member of LIST has a car
1620 that is `eq' to VALUE, there is no way to remove it by side effect;
1621 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1627 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1629 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1633 /* Like Fremrassq, fast and unsafe; be careful */
1635 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1638 LIST_LOOP_DELETE_IF (elt, list,
1640 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1644 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1645 Reverse LIST by destructively modifying cdr pointers.
1646 Return the beginning of the reversed list.
1647 Also see: `reverse'.
1651 struct gcpro gcpro1, gcpro2;
1652 REGISTER Lisp_Object prev = Qnil;
1653 REGISTER Lisp_Object tail = list;
1655 /* We gcpro our args; see `nconc' */
1656 GCPRO2 (prev, tail);
1657 while (!NILP (tail))
1659 REGISTER Lisp_Object next;
1660 CONCHECK_CONS (tail);
1670 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1671 Reverse LIST, copying. Return the beginning of the reversed list.
1672 See also the function `nreverse', which is used more often.
1676 Lisp_Object reversed_list = Qnil;
1678 EXTERNAL_LIST_LOOP_2 (elt, list)
1680 reversed_list = Fcons (elt, reversed_list);
1682 return reversed_list;
1685 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1686 Lisp_Object lisp_arg,
1687 int (*pred_fn) (Lisp_Object, Lisp_Object,
1688 Lisp_Object lisp_arg));
1691 list_sort (Lisp_Object list,
1692 Lisp_Object lisp_arg,
1693 int (*pred_fn) (Lisp_Object, Lisp_Object,
1694 Lisp_Object lisp_arg))
1696 struct gcpro gcpro1, gcpro2, gcpro3;
1697 Lisp_Object back, tem;
1698 Lisp_Object front = list;
1699 Lisp_Object len = Flength (list);
1700 int length = XINT (len);
1705 XSETINT (len, (length / 2) - 1);
1706 tem = Fnthcdr (len, list);
1708 Fsetcdr (tem, Qnil);
1710 GCPRO3 (front, back, lisp_arg);
1711 front = list_sort (front, lisp_arg, pred_fn);
1712 back = list_sort (back, lisp_arg, pred_fn);
1714 return list_merge (front, back, lisp_arg, pred_fn);
1719 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1724 /* prevents the GC from happening in call2 */
1725 int speccount = specpdl_depth ();
1726 /* Emacs' GC doesn't actually relocate pointers, so this probably
1727 isn't strictly necessary */
1728 record_unwind_protect (restore_gc_inhibit,
1729 make_int (gc_currently_forbidden));
1730 gc_currently_forbidden = 1;
1731 tmp = call2 (pred, obj1, obj2);
1732 unbind_to (speccount, Qnil);
1740 DEFUN ("sort", Fsort, 2, 2, 0, /*
1741 Sort LIST, stably, comparing elements using PREDICATE.
1742 Returns the sorted list. LIST is modified by side effects.
1743 PREDICATE is called with two elements of LIST, and should return T
1744 if the first element is "less" than the second.
1748 return list_sort (list, pred, merge_pred_function);
1752 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1755 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1760 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1761 Lisp_Object lisp_arg,
1762 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1768 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1775 /* It is sufficient to protect org_l1 and org_l2.
1776 When l1 and l2 are updated, we copy the new values
1777 back into the org_ vars. */
1779 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1800 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1815 Fsetcdr (tail, tem);
1821 /************************************************************************/
1822 /* property-list functions */
1823 /************************************************************************/
1825 /* For properties of text, we need to do order-insensitive comparison of
1826 plists. That is, we need to compare two plists such that they are the
1827 same if they have the same set of keys, and equivalent values.
1828 So (a 1 b 2) would be equal to (b 2 a 1).
1830 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1831 LAXP means use `equal' for comparisons.
1834 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1835 int laxp, int depth)
1837 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
1838 int la, lb, m, i, fill;
1839 Lisp_Object *keys, *vals;
1843 if (NILP (a) && NILP (b))
1846 Fcheck_valid_plist (a);
1847 Fcheck_valid_plist (b);
1849 la = XINT (Flength (a));
1850 lb = XINT (Flength (b));
1851 m = (la > lb ? la : lb);
1853 keys = alloca_array (Lisp_Object, m);
1854 vals = alloca_array (Lisp_Object, m);
1855 flags = alloca_array (char, m);
1857 /* First extract the pairs from A. */
1858 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1860 Lisp_Object k = XCAR (rest);
1861 Lisp_Object v = XCAR (XCDR (rest));
1862 /* Maybe be Ebolified. */
1863 if (nil_means_not_present && NILP (v)) continue;
1869 /* Now iterate over B, and stop if we find something that's not in A,
1870 or that doesn't match. As we match, mark them. */
1871 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1873 Lisp_Object k = XCAR (rest);
1874 Lisp_Object v = XCAR (XCDR (rest));
1875 /* Maybe be Ebolified. */
1876 if (nil_means_not_present && NILP (v)) continue;
1877 for (i = 0; i < fill; i++)
1879 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1882 /* We narrowly escaped being Ebolified here. */
1883 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1884 : !internal_equal (v, vals [i], depth)))
1885 /* a property in B has a different value than in A */
1892 /* there are some properties in B that are not in A */
1895 /* Now check to see that all the properties in A were also in B */
1896 for (i = 0; i < fill; i++)
1907 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1908 Return non-nil if property lists A and B are `eq'.
1909 A property list is an alternating list of keywords and values.
1910 This function does order-insensitive comparisons of the property lists:
1911 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1912 Comparison between values is done using `eq'. See also `plists-equal'.
1913 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1914 a nil value is ignored. This feature is a virus that has infected
1915 old Lisp implementations, but should not be used except for backward
1918 (a, b, nil_means_not_present))
1920 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1924 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1925 Return non-nil if property lists A and B are `equal'.
1926 A property list is an alternating list of keywords and values. This
1927 function does order-insensitive comparisons of the property lists: For
1928 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1929 Comparison between values is done using `equal'. See also `plists-eq'.
1930 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1931 a nil value is ignored. This feature is a virus that has infected
1932 old Lisp implementations, but should not be used except for backward
1935 (a, b, nil_means_not_present))
1937 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1942 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1943 Return non-nil if lax property lists A and B are `eq'.
1944 A property list is an alternating list of keywords and values.
1945 This function does order-insensitive comparisons of the property lists:
1946 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1947 Comparison between values is done using `eq'. See also `plists-equal'.
1948 A lax property list is like a regular one except that comparisons between
1949 keywords is done using `equal' instead of `eq'.
1950 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1951 a nil value is ignored. This feature is a virus that has infected
1952 old Lisp implementations, but should not be used except for backward
1955 (a, b, nil_means_not_present))
1957 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1961 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1962 Return non-nil if lax property lists A and B are `equal'.
1963 A property list is an alternating list of keywords and values. This
1964 function does order-insensitive comparisons of the property lists: For
1965 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1966 Comparison between values is done using `equal'. See also `plists-eq'.
1967 A lax property list is like a regular one except that comparisons between
1968 keywords is done using `equal' instead of `eq'.
1969 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1970 a nil value is ignored. This feature is a virus that has infected
1971 old Lisp implementations, but should not be used except for backward
1974 (a, b, nil_means_not_present))
1976 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1980 /* Return the value associated with key PROPERTY in property list PLIST.
1981 Return nil if key not found. This function is used for internal
1982 property lists that cannot be directly manipulated by the user.
1986 internal_plist_get (Lisp_Object plist, Lisp_Object property)
1990 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
1992 if (EQ (XCAR (tail), property))
1993 return XCAR (XCDR (tail));
1999 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2000 internal_plist_get(). */
2003 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2008 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2010 if (EQ (XCAR (tail), property))
2012 XCAR (XCDR (tail)) = value;
2017 *plist = Fcons (property, Fcons (value, *plist));
2021 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2023 Lisp_Object tail, prev;
2025 for (tail = *plist, prev = Qnil;
2027 tail = XCDR (XCDR (tail)))
2029 if (EQ (XCAR (tail), property))
2032 *plist = XCDR (XCDR (tail));
2034 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2044 /* Called on a malformed property list. BADPLACE should be some
2045 place where truncating will form a good list -- i.e. we shouldn't
2046 result in a list with an odd length. */
2049 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2051 if (ERRB_EQ (errb, ERROR_ME))
2052 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2055 if (ERRB_EQ (errb, ERROR_ME_WARN))
2057 warn_when_safe_lispobj
2060 ("Malformed property list -- list has been truncated"),
2068 /* Called on a circular property list. BADPLACE should be some place
2069 where truncating will result in an even-length list, as above.
2070 If doesn't particularly matter where we truncate -- anywhere we
2071 truncate along the entire list will break the circularity, because
2072 it will create a terminus and the list currently doesn't have one.
2076 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2078 if (ERRB_EQ (errb, ERROR_ME))
2079 /* #### Eek, this will probably result in another error
2080 when PLIST is printed out */
2081 return Fsignal (Qcircular_property_list, list1 (*plist));
2084 if (ERRB_EQ (errb, ERROR_ME_WARN))
2086 warn_when_safe_lispobj
2089 ("Circular property list -- list has been truncated"),
2097 /* Advance the tortoise pointer by two (one iteration of a property-list
2098 loop) and the hare pointer by four and verify that no malformations
2099 or circularities exist. If so, return zero and store a value into
2100 RETVAL that should be returned by the calling function. Otherwise,
2101 return 1. See external_plist_get().
2105 advance_plist_pointers (Lisp_Object *plist,
2106 Lisp_Object **tortoise, Lisp_Object **hare,
2107 Error_behavior errb, Lisp_Object *retval)
2110 Lisp_Object *tortsave = *tortoise;
2112 /* Note that our "fixing" may be more brutal than necessary,
2113 but it's the user's own problem, not ours, if they went in and
2114 manually fucked up a plist. */
2116 for (i = 0; i < 2; i++)
2118 /* This is a standard iteration of a defensive-loop-checking
2119 loop. We just do it twice because we want to advance past
2120 both the property and its value.
2122 If the pointer indirection is confusing you, remember that
2123 one level of indirection on the hare and tortoise pointers
2124 is only due to pass-by-reference for this function. The other
2125 level is so that the plist can be fixed in place. */
2127 /* When we reach the end of a well-formed plist, **HARE is
2128 nil. In that case, we don't do anything at all except
2129 advance TORTOISE by one. Otherwise, we advance HARE
2130 by two (making sure it's OK to do so), then advance
2131 TORTOISE by one (it will always be OK to do so because
2132 the HARE is always ahead of the TORTOISE and will have
2133 already verified the path), then make sure TORTOISE and
2134 HARE don't contain the same non-nil object -- if the
2135 TORTOISE and the HARE ever meet, then obviously we're
2136 in a circularity, and if we're in a circularity, then
2137 the TORTOISE and the HARE can't cross paths without
2138 meeting, since the HARE only gains one step over the
2139 TORTOISE per iteration. */
2143 Lisp_Object *haresave = *hare;
2144 if (!CONSP (**hare))
2146 *retval = bad_bad_bunny (plist, haresave, errb);
2149 *hare = &XCDR (**hare);
2150 /* In a non-plist, we'd check here for a nil value for
2151 **HARE, which is OK (it just means the list has an
2152 odd number of elements). In a plist, it's not OK
2153 for the list to have an odd number of elements. */
2154 if (!CONSP (**hare))
2156 *retval = bad_bad_bunny (plist, haresave, errb);
2159 *hare = &XCDR (**hare);
2162 *tortoise = &XCDR (**tortoise);
2163 if (!NILP (**hare) && EQ (**tortoise, **hare))
2165 *retval = bad_bad_turtle (plist, tortsave, errb);
2173 /* Return the value of PROPERTY from PLIST, or Qunbound if
2174 property is not on the list.
2176 PLIST is a Lisp-accessible property list, meaning that it
2177 has to be checked for malformations and circularities.
2179 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2180 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2181 on finding a malformation or a circularity, it issues a warning and
2182 attempts to silently fix the problem.
2184 A pointer to PLIST is passed in so that PLIST can be successfully
2185 "fixed" even if the error is at the beginning of the plist. */
2188 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2189 int laxp, Error_behavior errb)
2191 Lisp_Object *tortoise = plist;
2192 Lisp_Object *hare = plist;
2194 while (!NILP (*tortoise))
2196 Lisp_Object *tortsave = tortoise;
2199 /* We do the standard tortoise/hare march. We isolate the
2200 grungy stuff to do this in advance_plist_pointers(), though.
2201 To us, all this function does is advance the tortoise
2202 pointer by two and the hare pointer by four and make sure
2203 everything's OK. We first advance the pointers and then
2204 check if a property matched; this ensures that our
2205 check for a matching property is safe. */
2207 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2210 if (!laxp ? EQ (XCAR (*tortsave), property)
2211 : internal_equal (XCAR (*tortsave), property, 0))
2212 return XCAR (XCDR (*tortsave));
2218 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2219 malformed or circular plist. Analogous to external_plist_get(). */
2222 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2223 Lisp_Object value, int laxp, Error_behavior errb)
2225 Lisp_Object *tortoise = plist;
2226 Lisp_Object *hare = plist;
2228 while (!NILP (*tortoise))
2230 Lisp_Object *tortsave = tortoise;
2234 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2237 if (!laxp ? EQ (XCAR (*tortsave), property)
2238 : internal_equal (XCAR (*tortsave), property, 0))
2240 XCAR (XCDR (*tortsave)) = value;
2245 *plist = Fcons (property, Fcons (value, *plist));
2249 external_remprop (Lisp_Object *plist, Lisp_Object property,
2250 int laxp, Error_behavior errb)
2252 Lisp_Object *tortoise = plist;
2253 Lisp_Object *hare = plist;
2255 while (!NILP (*tortoise))
2257 Lisp_Object *tortsave = tortoise;
2261 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2264 if (!laxp ? EQ (XCAR (*tortsave), property)
2265 : internal_equal (XCAR (*tortsave), property, 0))
2267 /* Now you see why it's so convenient to have that level
2269 *tortsave = XCDR (XCDR (*tortsave));
2277 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2278 Extract a value from a property list.
2279 PLIST is a property list, which is a list of the form
2280 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2281 corresponding to the given PROP, or DEFAULT if PROP is not
2282 one of the properties on the list.
2284 (plist, prop, default_))
2286 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2287 return UNBOUNDP (val) ? default_ : val;
2290 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2291 Change value in PLIST of PROP to VAL.
2292 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2293 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2294 If PROP is already a property on the list, its value is set to VAL,
2295 otherwise the new PROP VAL pair is added. The new plist is returned;
2296 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2297 The PLIST is modified by side effects.
2301 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2305 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2306 Remove from PLIST the property PROP and its value.
2307 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2308 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2309 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2310 the new value. The PLIST is modified by side effects.
2314 external_remprop (&plist, prop, 0, ERROR_ME);
2318 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2319 Return t if PROP has a value specified in PLIST.
2323 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2324 return UNBOUNDP (val) ? Qnil : Qt;
2327 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2328 Given a plist, signal an error if there is anything wrong with it.
2329 This means that it's a malformed or circular plist.
2333 Lisp_Object *tortoise;
2339 while (!NILP (*tortoise))
2344 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2352 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2353 Given a plist, return non-nil if its format is correct.
2354 If it returns nil, `check-valid-plist' will signal an error when given
2355 the plist; that means it's a malformed or circular plist or has non-symbols
2360 Lisp_Object *tortoise;
2365 while (!NILP (*tortoise))
2370 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2378 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2379 Destructively remove any duplicate entries from a plist.
2380 In such cases, the first entry applies.
2382 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2383 a nil value is removed. This feature is a virus that has infected
2384 old Lisp implementations, but should not be used except for backward
2387 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2388 return value may not be EQ to the passed-in value, so make sure to
2389 `setq' the value back into where it came from.
2391 (plist, nil_means_not_present))
2393 Lisp_Object head = plist;
2395 Fcheck_valid_plist (plist);
2397 while (!NILP (plist))
2399 Lisp_Object prop = Fcar (plist);
2400 Lisp_Object next = Fcdr (plist);
2402 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2403 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2405 if (EQ (head, plist))
2407 plist = Fcdr (next);
2410 /* external_remprop returns 1 if it removed any property.
2411 We have to loop till it didn't remove anything, in case
2412 the property occurs many times. */
2413 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2415 plist = Fcdr (next);
2421 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2422 Extract a value from a lax property list.
2424 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2425 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2426 using `equal' instead of `eq'. This function returns the value
2427 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2428 properties on the list.
2430 (lax_plist, prop, default_))
2432 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2438 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2439 Change value in LAX-PLIST of PROP to VAL.
2440 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2441 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2442 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2443 any object. If PROP is already a property on the list, its value is
2444 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2445 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2446 use the new value. The LAX-PLIST is modified by side effects.
2448 (lax_plist, prop, val))
2450 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2454 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2455 Remove from LAX-PLIST the property PROP and its value.
2456 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2457 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2458 using `equal' instead of `eq'. PROP is usually a symbol. The new
2459 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2460 sure to use the new value. The LAX-PLIST is modified by side effects.
2464 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2468 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2469 Return t if PROP has a value specified in LAX-PLIST.
2470 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2471 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2472 using `equal' instead of `eq'.
2476 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2479 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2480 Destructively remove any duplicate entries from a lax plist.
2481 In such cases, the first entry applies.
2483 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2484 a nil value is removed. This feature is a virus that has infected
2485 old Lisp implementations, but should not be used except for backward
2488 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2489 return value may not be EQ to the passed-in value, so make sure to
2490 `setq' the value back into where it came from.
2492 (lax_plist, nil_means_not_present))
2494 Lisp_Object head = lax_plist;
2496 Fcheck_valid_plist (lax_plist);
2498 while (!NILP (lax_plist))
2500 Lisp_Object prop = Fcar (lax_plist);
2501 Lisp_Object next = Fcdr (lax_plist);
2503 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2504 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2506 if (EQ (head, lax_plist))
2508 lax_plist = Fcdr (next);
2511 /* external_remprop returns 1 if it removed any property.
2512 We have to loop till it didn't remove anything, in case
2513 the property occurs many times. */
2514 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2516 lax_plist = Fcdr (next);
2522 /* In C because the frame props stuff uses it */
2524 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2525 Convert association list ALIST into the equivalent property-list form.
2526 The plist is returned. This converts from
2528 \((a . 1) (b . 2) (c . 3))
2534 The original alist is destroyed in the process of constructing the plist.
2535 See also `alist-to-plist'.
2539 Lisp_Object head = alist;
2540 while (!NILP (alist))
2542 /* remember the alist element. */
2543 Lisp_Object el = Fcar (alist);
2545 Fsetcar (alist, Fcar (el));
2546 Fsetcar (el, Fcdr (el));
2547 Fsetcdr (el, Fcdr (alist));
2548 Fsetcdr (alist, el);
2549 alist = Fcdr (Fcdr (alist));
2555 /* Symbol plists are directly accessible, so we need to protect against
2556 invalid property list structure */
2559 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2561 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2563 return UNBOUNDP (val) ? default_ : val;
2567 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2569 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2573 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2575 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2578 /* We store the string's extent info as the first element of the string's
2579 property list; and the string's MODIFF as the first or second element
2580 of the string's property list (depending on whether the extent info
2581 is present), but only if the string has been modified. This is ugly
2582 but it reduces the memory allocated for the string in the vast
2583 majority of cases, where the string is never modified and has no
2587 static Lisp_Object *
2588 string_plist_ptr (struct Lisp_String *s)
2590 Lisp_Object *ptr = &s->plist;
2592 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2594 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2600 string_getprop (struct Lisp_String *s, Lisp_Object property,
2601 Lisp_Object default_)
2603 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2605 return UNBOUNDP (val) ? default_ : val;
2609 string_putprop (struct Lisp_String *s, Lisp_Object property,
2612 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2616 string_remprop (struct Lisp_String *s, Lisp_Object property)
2618 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2622 string_plist (struct Lisp_String *s)
2624 return *string_plist_ptr (s);
2627 DEFUN ("get", Fget, 2, 3, 0, /*
2628 Return the value of OBJECT's PROPNAME property.
2629 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
2630 If there is no such property, return optional third arg DEFAULT
2631 \(which defaults to `nil'). OBJECT can be a symbol, face, extent,
2632 or string. See also `put', `remprop', and `object-plist'.
2634 (object, propname, default_))
2636 /* Various places in emacs call Fget() and expect it not to quit,
2639 /* It's easiest to treat symbols specially because they may not
2641 if (SYMBOLP (object))
2642 return symbol_getprop (object, propname, default_);
2643 else if (STRINGP (object))
2644 return string_getprop (XSTRING (object), propname, default_);
2645 else if (LRECORDP (object))
2647 CONST struct lrecord_implementation *imp
2648 = XRECORD_LHEADER_IMPLEMENTATION (object);
2653 Lisp_Object val = (imp->getprop) (object, propname);
2662 signal_simple_error ("Object type has no properties", object);
2663 return Qnil; /* Not reached */
2667 DEFUN ("put", Fput, 3, 3, 0, /*
2668 Store OBJECT's PROPNAME property with value VALUE.
2669 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
2670 symbol, face, extent, or string.
2672 For a string, no properties currently have predefined meanings.
2673 For the predefined properties for extents, see `set-extent-property'.
2674 For the predefined properties for faces, see `set-face-property'.
2676 See also `get', `remprop', and `object-plist'.
2678 (object, propname, value))
2680 CHECK_SYMBOL (propname);
2681 CHECK_LISP_WRITEABLE (object);
2683 if (SYMBOLP (object))
2684 symbol_putprop (object, propname, value);
2685 else if (STRINGP (object))
2686 string_putprop (XSTRING (object), propname, value);
2687 else if (LRECORDP (object))
2689 CONST struct lrecord_implementation
2690 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2693 if (! (imp->putprop) (object, propname, value))
2694 signal_simple_error ("Can't set property on object", propname);
2702 signal_simple_error ("Object type has no settable properties", object);
2709 pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
2711 Fput (sym, prop, Fpurecopy (val));
2714 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2715 Remove from OBJECT's property list the property PROPNAME and its
2716 value. OBJECT can be a symbol, face, extent, or string. Returns
2717 non-nil if the property list was actually changed (i.e. if PROPNAME
2718 was present in the property list). See also `get', `put', and
2725 CHECK_SYMBOL (propname);
2726 CHECK_LISP_WRITEABLE (object);
2728 if (SYMBOLP (object))
2729 retval = symbol_remprop (object, propname);
2730 else if (STRINGP (object))
2731 retval = string_remprop (XSTRING (object), propname);
2732 else if (LRECORDP (object))
2734 CONST struct lrecord_implementation
2735 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2738 retval = (imp->remprop) (object, propname);
2740 signal_simple_error ("Can't remove property from object",
2749 signal_simple_error ("Object type has no removable properties", object);
2752 return retval ? Qt : Qnil;
2755 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2756 Return a property list of OBJECT's props.
2757 For a symbol this is equivalent to `symbol-plist'.
2758 Do not modify the property list directly; this may or may not have
2759 the desired effects. (In particular, for a property with a special
2760 interpretation, this will probably have no effect at all.)
2764 if (SYMBOLP (object))
2765 return Fsymbol_plist (object);
2766 else if (STRINGP (object))
2767 return string_plist (XSTRING (object));
2768 else if (LRECORDP (object))
2770 CONST struct lrecord_implementation
2771 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2773 return (imp->plist) (object);
2775 signal_simple_error ("Object type has no properties", object);
2778 signal_simple_error ("Object type has no properties", object);
2785 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2788 error ("Stack overflow in equal");
2790 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2792 /* Note that (equal 20 20.0) should be nil */
2793 if (XTYPE (obj1) != XTYPE (obj2))
2795 if (LRECORDP (obj1))
2797 CONST struct lrecord_implementation
2798 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2799 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2801 return (imp1 == imp2) &&
2802 /* EQ-ness of the objects was noticed above */
2803 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2809 /* Note that we may be calling sub-objects that will use
2810 internal_equal() (instead of internal_old_equal()). Oh well.
2811 We will get an Ebola note if there's any possibility of confusion,
2812 but that seems unlikely. */
2815 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2818 error ("Stack overflow in equal");
2820 if (HACKEQ_UNSAFE (obj1, obj2))
2822 /* Note that (equal 20 20.0) should be nil */
2823 if (XTYPE (obj1) != XTYPE (obj2))
2826 return internal_equal (obj1, obj2, depth);
2829 DEFUN ("equal", Fequal, 2, 2, 0, /*
2830 Return t if two Lisp objects have similar structure and contents.
2831 They must have the same data type.
2832 Conses are compared by comparing the cars and the cdrs.
2833 Vectors and strings are compared element by element.
2834 Numbers are compared by value. Symbols must match exactly.
2838 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2841 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2842 Return t if two Lisp objects have similar structure and contents.
2843 They must have the same data type.
2844 \(Note, however, that an exception is made for characters and integers;
2845 this is known as the "char-int confoundance disease." See `eq' and
2847 This function is provided only for byte-code compatibility with v19.
2852 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2856 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2857 Store each element of ARRAY with ITEM.
2858 ARRAY is a vector, bit vector, or string.
2863 if (STRINGP (array))
2866 struct Lisp_String *s = XSTRING (array);
2867 Charcount len = string_char_length (s);
2869 CHECK_CHAR_COERCE_INT (item);
2870 CHECK_LISP_WRITEABLE (array);
2871 charval = XCHAR (item);
2872 for (i = 0; i < len; i++)
2873 set_string_char (s, i, charval);
2874 bump_string_modiff (array);
2876 else if (VECTORP (array))
2878 Lisp_Object *p = XVECTOR_DATA (array);
2879 int len = XVECTOR_LENGTH (array);
2880 CHECK_LISP_WRITEABLE (array);
2884 else if (BIT_VECTORP (array))
2886 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2887 int len = bit_vector_length (v);
2890 CHECK_LISP_WRITEABLE (array);
2893 set_bit_vector_bit (v, len, bit);
2897 array = wrong_type_argument (Qarrayp, array);
2904 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2906 Lisp_Object args[2];
2907 struct gcpro gcpro1;
2914 RETURN_UNGCPRO (bytecode_nconc2 (args));
2918 bytecode_nconc2 (Lisp_Object *args)
2922 if (CONSP (args[0]))
2924 /* (setcdr (last args[0]) args[1]) */
2925 Lisp_Object tortoise, hare;
2928 for (hare = tortoise = args[0], count = 0;
2929 CONSP (XCDR (hare));
2930 hare = XCDR (hare), count++)
2932 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2935 tortoise = XCDR (tortoise);
2936 if (EQ (hare, tortoise))
2937 signal_circular_list_error (args[0]);
2939 XCDR (hare) = args[1];
2942 else if (NILP (args[0]))
2948 args[0] = wrong_type_argument (args[0], Qlistp);
2953 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2954 Concatenate any number of lists by altering them.
2955 Only the last argument is not altered, and need not be a list.
2957 If the first argument is nil, there is no way to modify it by side
2958 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2959 changing the value of `foo'.
2961 (int nargs, Lisp_Object *args))
2964 struct gcpro gcpro1;
2966 /* The modus operandi in Emacs is "caller gc-protects args".
2967 However, nconc (particularly nconc2 ()) is called many times
2968 in Emacs on freshly created stuff (e.g. you see the idiom
2969 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2970 callers out by protecting the args ourselves to save them
2971 a lot of temporary-variable grief. */
2974 gcpro1.nvars = nargs;
2976 while (argnum < nargs)
2983 /* `val' is the first cons, which will be our return value. */
2984 /* `last_cons' will be the cons cell to mutate. */
2985 Lisp_Object last_cons = val;
2986 Lisp_Object tortoise = val;
2988 for (argnum++; argnum < nargs; argnum++)
2990 Lisp_Object next = args[argnum];
2992 if (CONSP (next) || argnum == nargs -1)
2994 /* (setcdr (last val) next) */
2998 CONSP (XCDR (last_cons));
2999 last_cons = XCDR (last_cons), count++)
3001 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3004 tortoise = XCDR (tortoise);
3005 if (EQ (last_cons, tortoise))
3006 signal_circular_list_error (args[argnum-1]);
3008 XCDR (last_cons) = next;
3010 else if (NILP (next))
3016 next = wrong_type_argument (Qlistp, next);
3020 RETURN_UNGCPRO (val);
3022 else if (NILP (val))
3024 else if (argnum == nargs - 1) /* last arg? */
3025 RETURN_UNGCPRO (val);
3028 args[argnum] = wrong_type_argument (Qlistp, val);
3032 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3036 /* This is the guts of all mapping functions.
3037 Apply fn to each element of seq, one by one,
3038 storing the results into elements of vals, a C vector of Lisp_Objects.
3039 leni is the length of vals, which should also be the length of seq.
3041 If VALS is a null pointer, do not accumulate the results. */
3044 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3047 Lisp_Object args[2];
3049 struct gcpro gcpro1;
3061 for (i = 0; i < leni; i++)
3063 args[1] = XCAR (seq);
3065 result = Ffuncall (2, args);
3066 if (vals) vals[gcpro1.nvars++] = result;
3069 else if (VECTORP (seq))
3071 Lisp_Object *objs = XVECTOR_DATA (seq);
3072 for (i = 0; i < leni; i++)
3075 result = Ffuncall (2, args);
3076 if (vals) vals[gcpro1.nvars++] = result;
3079 else if (STRINGP (seq))
3081 Bufbyte *p = XSTRING_DATA (seq);
3082 for (i = 0; i < leni; i++)
3084 args[1] = make_char (charptr_emchar (p));
3086 result = Ffuncall (2, args);
3087 if (vals) vals[gcpro1.nvars++] = result;
3090 else if (BIT_VECTORP (seq))
3092 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3093 for (i = 0; i < leni; i++)
3095 args[1] = make_int (bit_vector_bit (v, i));
3096 result = Ffuncall (2, args);
3097 if (vals) vals[gcpro1.nvars++] = result;
3101 abort(); /* cannot get here since Flength(seq) did not get an error */
3107 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3108 Apply FN to each element of SEQ, and concat the results as strings.
3109 In between each pair of results, stick in SEP.
3110 Thus, " " as SEP results in spaces between the values returned by FN.
3114 size_t len = XINT (Flength (seq));
3117 struct gcpro gcpro1;
3118 int nargs = len + len - 1;
3120 if (nargs < 0) return build_string ("");
3122 args = alloca_array (Lisp_Object, nargs);
3125 mapcar1 (len, args, fn, seq);
3128 for (i = len - 1; i >= 0; i--)
3129 args[i + i] = args[i];
3131 for (i = 1; i < nargs; i += 2)
3134 return Fconcat (nargs, args);
3137 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3138 Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3139 The result is a list just as long as SEQUENCE.
3140 SEQUENCE may be a list, a vector, a bit vector, or a string.
3144 size_t len = XINT (Flength (seq));
3145 Lisp_Object *args = alloca_array (Lisp_Object, len);
3147 mapcar1 (len, args, fn, seq);
3149 return Flist (len, args);
3152 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3153 Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
3154 The result is a vector of the same length as SEQUENCE.
3155 SEQUENCE may be a list, a vector or a string.
3159 size_t len = XINT (Flength (seq));
3160 Lisp_Object result = make_vector (len, Qnil);
3161 struct gcpro gcpro1;
3164 mapcar1 (len, XVECTOR_DATA (result), fn, seq);
3170 DEFUN ("mapc", Fmapc, 2, 2, 0, /*
3171 Apply FUNCTION to each element of SEQUENCE.
3172 SEQUENCE may be a list, a vector, a bit vector, or a string.
3173 This function is like `mapcar' but does not accumulate the results,
3174 which is more efficient if you do not use the results.
3178 mapcar1 (XINT (Flength (seq)), 0, fn, seq);
3184 /* #### this function doesn't belong in this file! */
3186 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3187 Return list of 1 minute, 5 minute and 15 minute load averages.
3188 Each of the three load averages is multiplied by 100,
3189 then converted to integer.
3191 When USE-FLOATS is non-nil, floats will be used instead of integers.
3192 These floats are not multiplied by 100.
3194 If the 5-minute or 15-minute load averages are not available, return a
3195 shortened list, containing only those averages which are available.
3197 On some systems, this won't work due to permissions on /dev/kmem,
3198 in which case you can't use this.
3203 int loads = getloadavg (load_ave, countof (load_ave));
3204 Lisp_Object ret = Qnil;
3207 error ("load-average not implemented for this operating system");
3209 signal_simple_error ("Could not get load-average",
3210 lisp_strerror (errno));
3214 Lisp_Object load = (NILP (use_floats) ?
3215 make_int ((int) (100.0 * load_ave[loads]))
3216 : make_float (load_ave[loads]));
3217 ret = Fcons (load, ret);
3223 Lisp_Object Vfeatures;
3225 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3226 Return non-nil if feature FEXP is present in this Emacs.
3227 Use this to conditionalize execution of lisp code based on the
3228 presence or absence of emacs or environment extensions.
3229 FEXP can be a symbol, a number, or a list.
3230 If it is a symbol, that symbol is looked up in the `features' variable,
3231 and non-nil will be returned if found.
3232 If it is a number, the function will return non-nil if this Emacs
3233 has an equal or greater version number than FEXP.
3234 If it is a list whose car is the symbol `and', it will return
3235 non-nil if all the features in its cdr are non-nil.
3236 If it is a list whose car is the symbol `or', it will return non-nil
3237 if any of the features in its cdr are non-nil.
3238 If it is a list whose car is the symbol `not', it will return
3239 non-nil if the feature is not present.
3244 => ; Non-nil on XEmacs.
3246 (featurep '(and xemacs gnus))
3247 => ; Non-nil on XEmacs with Gnus loaded.
3249 (featurep '(or tty-frames (and emacs 19.30)))
3250 => ; Non-nil if this Emacs supports TTY frames.
3252 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3253 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3255 NOTE: The advanced arguments of this function (anything other than a
3256 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3257 for supporting multiple Emacs variants, lobby Richard Stallman at
3258 <bug-gnu-emacs@prep.ai.mit.edu>.
3262 #ifndef FEATUREP_SYNTAX
3263 CHECK_SYMBOL (fexp);
3264 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3265 #else /* FEATUREP_SYNTAX */
3266 static double featurep_emacs_version;
3268 /* Brute force translation from Erik Naggum's lisp function. */
3271 /* Original definition */
3272 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3274 else if (INTP (fexp) || FLOATP (fexp))
3276 double d = extract_float (fexp);
3278 if (featurep_emacs_version == 0.0)
3280 featurep_emacs_version = XINT (Vemacs_major_version) +
3281 (XINT (Vemacs_minor_version) / 100.0);
3283 return featurep_emacs_version >= d ? Qt : Qnil;
3285 else if (CONSP (fexp))
3287 Lisp_Object tem = XCAR (fexp);
3293 negate = Fcar (tem);
3295 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3297 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3299 else if (EQ (tem, Qand))
3302 /* Use Fcar/Fcdr for error-checking. */
3303 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3307 return NILP (tem) ? Qt : Qnil;
3309 else if (EQ (tem, Qor))
3312 /* Use Fcar/Fcdr for error-checking. */
3313 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3317 return NILP (tem) ? Qnil : Qt;
3321 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3326 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3329 #endif /* FEATUREP_SYNTAX */
3331 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3332 Announce that FEATURE is a feature of the current Emacs.
3333 This function updates the value of the variable `features'.
3338 CHECK_SYMBOL (feature);
3339 if (!NILP (Vautoload_queue))
3340 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3341 tem = Fmemq (feature, Vfeatures);
3343 Vfeatures = Fcons (feature, Vfeatures);
3344 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3348 DEFUN ("require", Frequire, 1, 2, 0, /*
3349 If feature FEATURE is not loaded, load it from FILENAME.
3350 If FEATURE is not a member of the list `features', then the feature
3351 is not loaded; so load the file FILENAME.
3352 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3354 (feature, file_name))
3357 CHECK_SYMBOL (feature);
3358 tem = Fmemq (feature, Vfeatures);
3359 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3364 int speccount = specpdl_depth ();
3366 /* Value saved here is to be restored into Vautoload_queue */
3367 record_unwind_protect (un_autoload, Vautoload_queue);
3368 Vautoload_queue = Qt;
3370 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3373 tem = Fmemq (feature, Vfeatures);
3375 error ("Required feature %s was not provided",
3376 string_data (XSYMBOL (feature)->name));
3378 /* Once loading finishes, don't undo it. */
3379 Vautoload_queue = Qt;
3380 return unbind_to (speccount, feature);
3384 /* base64 encode/decode functions.
3385 Based on code from GNU recode. */
3387 #define MIME_LINE_LENGTH 76
3389 #define IS_ASCII(Character) \
3391 #define IS_BASE64(Character) \
3392 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3394 /* Table of characters coding the 64 values. */
3395 static char base64_value_to_char[64] =
3397 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3398 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3399 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3400 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3401 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3402 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3403 '8', '9', '+', '/' /* 60-63 */
3406 /* Table of base64 values for first 128 characters. */
3407 static short base64_char_to_value[128] =
3409 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3410 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3411 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3412 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3413 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3414 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3415 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3416 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3417 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3418 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3419 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3420 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3421 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3424 /* The following diagram shows the logical steps by which three octets
3425 get transformed into four base64 characters.
3427 .--------. .--------. .--------.
3428 |aaaaaabb| |bbbbcccc| |ccdddddd|
3429 `--------' `--------' `--------'
3431 .--------+--------+--------+--------.
3432 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3433 `--------+--------+--------+--------'
3435 .--------+--------+--------+--------.
3436 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3437 `--------+--------+--------+--------'
3439 The octets are divided into 6 bit chunks, which are then encoded into
3440 base64 characters. */
3442 #define ADVANCE_INPUT(c, stream) \
3443 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3445 (signal_simple_error ("Non-ascii character in base64 input", \
3446 make_char (ec)), 0) \
3447 : (c = (Bufbyte)ec), 1))
3450 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3452 EMACS_INT counter = 0;
3460 if (!ADVANCE_INPUT (c, istream))
3463 /* Wrap line every 76 characters. */
3466 if (counter < MIME_LINE_LENGTH / 4)
3475 /* Process first byte of a triplet. */
3476 *e++ = base64_value_to_char[0x3f & c >> 2];
3477 value = (0x03 & c) << 4;
3479 /* Process second byte of a triplet. */
3480 if (!ADVANCE_INPUT (c, istream))
3482 *e++ = base64_value_to_char[value];
3488 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3489 value = (0x0f & c) << 2;
3491 /* Process third byte of a triplet. */
3492 if (!ADVANCE_INPUT (c, istream))
3494 *e++ = base64_value_to_char[value];
3499 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3500 *e++ = base64_value_to_char[0x3f & c];
3505 #undef ADVANCE_INPUT
3507 /* Semantically identical to ADVANCE_INPUT above, only no >255
3508 checking is needed for decoding -- checking is covered by IS_BASE64
3510 #define ADVANCE_INPUT(c, stream) \
3511 (ec = Lstream_get_emchar (stream), \
3512 ec == -1 ? 0 : (c = (Bufbyte)ec, 1))
3514 /* Get next character from the stream, but ignore it if it's
3515 whitespace. ENDP is set to 1 if EOF is hit. */
3516 #define ADVANCE_INPUT_IGNORE_WHITESPACE(c, endp, stream) do { \
3519 if (!ADVANCE_INPUT (c, stream)) \
3521 } while (!endp && (c == ' ' || c == '\t' || c == '\r' || c == '\n' \
3522 || c == '\f' || c == '\v')); \
3525 #define STORE_BYTE(pos, val) do { \
3526 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3531 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3534 unsigned long value;
3543 ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3547 /* Process first byte of a quadruplet. */
3550 value = base64_char_to_value[c] << 18;
3552 /* Process second byte of a quadruplet. */
3553 ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3559 value |= base64_char_to_value[c] << 12;
3561 STORE_BYTE (e, value >> 16);
3563 /* Process third byte of a quadruplet. */
3564 ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3570 ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3580 value |= base64_char_to_value[c] << 6;
3582 STORE_BYTE (e, 0xff & value >> 8);
3584 /* Process fourth byte of a quadruplet. */
3585 ADVANCE_INPUT_IGNORE_WHITESPACE (c, endp, istream);
3594 value |= base64_char_to_value[c];
3596 STORE_BYTE (e, 0xff & value);
3601 #undef ADVANCE_INPUT
3602 #undef ADVANCE_INPUT_IGNORE_WHITESPACE
3606 free_malloced_ptr (Lisp_Object unwind_obj)
3608 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3610 free_opaque_ptr (unwind_obj);
3614 /* Don't use alloca for regions larger than this, lest we overflow
3616 #define MAX_ALLOCA 65536
3618 /* We need to setup proper unwinding, because there is a number of
3619 ways these functions can blow up, and we don't want to have memory
3620 leaks in those cases. */
3621 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3622 size_t XOA_len = (len); \
3623 if (XOA_len > MAX_ALLOCA) \
3625 ptr = xnew_array (type, XOA_len); \
3626 record_unwind_protect (free_malloced_ptr, \
3627 make_opaque_ptr ((void *)ptr)); \
3630 ptr = alloca_array (type, XOA_len); \
3633 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3634 if ((len) > MAX_ALLOCA) \
3635 unbind_to (speccount, Qnil); \
3638 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3639 Base64-encode the region between BEG and END.
3640 Return the length of the encoded text.
3641 Optional third argument NO-LINE-BREAK means do not break long lines
3644 (beg, end, no_line_break))
3647 Bytind encoded_length;
3648 Charcount allength, length;
3649 struct buffer *buf = current_buffer;
3650 Bufpos begv, zv, old_pt = BUF_PT (buf);
3652 int speccount = specpdl_depth();
3654 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3655 barf_if_buffer_read_only (buf, begv, zv);
3657 /* We need to allocate enough room for encoding the text.
3658 We need 33 1/3% more space, plus a newline every 76
3659 characters, and then we round up. */
3661 allength = length + length/3 + 1;
3662 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3664 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3665 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3666 base64 characters will be single-byte. */
3667 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3668 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3669 NILP (no_line_break));
3670 if (encoded_length > allength)
3672 Lstream_delete (XLSTREAM (input));
3674 /* Now we have encoded the region, so we insert the new contents
3675 and delete the old. (Insert first in order to preserve markers.) */
3676 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3677 XMALLOC_UNBIND (encoded, allength, speccount);
3678 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3680 /* Simulate FSF Emacs: if point was in the region, place it at the
3682 if (old_pt >= begv && old_pt < zv)
3683 BUF_SET_PT (buf, begv);
3685 /* We return the length of the encoded text. */
3686 return make_int (encoded_length);
3689 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3690 Base64 encode STRING and return the result.
3692 (string, no_line_break))
3694 Charcount allength, length;
3695 Bytind encoded_length;
3697 Lisp_Object input, result;
3698 int speccount = specpdl_depth();
3700 CHECK_STRING (string);
3702 length = XSTRING_CHAR_LENGTH (string);
3703 allength = length + length/3 + 1;
3704 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3706 input = make_lisp_string_input_stream (string, 0, -1);
3707 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3708 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3709 NILP (no_line_break));
3710 if (encoded_length > allength)
3712 Lstream_delete (XLSTREAM (input));
3713 result = make_string (encoded, encoded_length);
3714 XMALLOC_UNBIND (encoded, allength, speccount);
3718 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3719 Base64-decode the region between BEG and END.
3720 Return the length of the decoded text.
3721 If the region can't be decoded, return nil and don't modify the buffer.
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 if (decoded_length < 0)
3748 /* The decoding wasn't possible. */
3749 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3753 /* Now we have decoded the region, so we insert the new contents
3754 and delete the old. (Insert first in order to preserve markers.) */
3755 BUF_SET_PT (buf, begv);
3756 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3757 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3758 buffer_delete_range (buf, begv + cc_decoded_length,
3759 zv + cc_decoded_length, 0);
3761 /* Simulate FSF Emacs: if point was in the region, place it at the
3763 if (old_pt >= begv && old_pt < zv)
3764 BUF_SET_PT (buf, begv);
3766 return make_int (cc_decoded_length);
3769 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3770 Base64-decode STRING and return the result.
3775 Bytind decoded_length;
3776 Charcount length, cc_decoded_length;
3777 Lisp_Object input, result;
3778 int speccount = specpdl_depth();
3780 CHECK_STRING (string);
3782 length = XSTRING_CHAR_LENGTH (string);
3783 /* We need to allocate enough room for decoding the text. */
3784 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3786 input = make_lisp_string_input_stream (string, 0, -1);
3787 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3788 &cc_decoded_length);
3789 if (decoded_length > length * MAX_EMCHAR_LEN)
3791 Lstream_delete (XLSTREAM (input));
3793 if (decoded_length < 0)
3795 /* The decoding wasn't possible. */
3796 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3800 result = make_string (decoded, decoded_length);
3801 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3805 Lisp_Object Qyes_or_no_p;
3810 defsymbol (&Qstring_lessp, "string-lessp");
3811 defsymbol (&Qidentity, "identity");
3812 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3814 DEFSUBR (Fidentity);
3817 DEFSUBR (Fsafe_length);
3818 DEFSUBR (Fstring_equal);
3819 DEFSUBR (Fstring_lessp);
3820 DEFSUBR (Fstring_modified_tick);
3824 DEFSUBR (Fbvconcat);
3825 DEFSUBR (Fcopy_list);
3826 DEFSUBR (Fcopy_sequence);
3827 DEFSUBR (Fcopy_alist);
3828 DEFSUBR (Fcopy_tree);
3829 DEFSUBR (Fsubstring);
3836 DEFSUBR (Fnbutlast);
3838 DEFSUBR (Fold_member);
3840 DEFSUBR (Fold_memq);
3842 DEFSUBR (Fold_assoc);
3844 DEFSUBR (Fold_assq);
3846 DEFSUBR (Fold_rassoc);
3848 DEFSUBR (Fold_rassq);
3850 DEFSUBR (Fold_delete);
3852 DEFSUBR (Fold_delq);
3853 DEFSUBR (Fremassoc);
3855 DEFSUBR (Fremrassoc);
3856 DEFSUBR (Fremrassq);
3857 DEFSUBR (Fnreverse);
3860 DEFSUBR (Fplists_eq);
3861 DEFSUBR (Fplists_equal);
3862 DEFSUBR (Flax_plists_eq);
3863 DEFSUBR (Flax_plists_equal);
3864 DEFSUBR (Fplist_get);
3865 DEFSUBR (Fplist_put);
3866 DEFSUBR (Fplist_remprop);
3867 DEFSUBR (Fplist_member);
3868 DEFSUBR (Fcheck_valid_plist);
3869 DEFSUBR (Fvalid_plist_p);
3870 DEFSUBR (Fcanonicalize_plist);
3871 DEFSUBR (Flax_plist_get);
3872 DEFSUBR (Flax_plist_put);
3873 DEFSUBR (Flax_plist_remprop);
3874 DEFSUBR (Flax_plist_member);
3875 DEFSUBR (Fcanonicalize_lax_plist);
3876 DEFSUBR (Fdestructive_alist_to_plist);
3880 DEFSUBR (Fobject_plist);
3882 DEFSUBR (Fold_equal);
3883 DEFSUBR (Ffillarray);
3886 DEFSUBR (Fmapvector);
3888 DEFSUBR (Fmapconcat);
3889 DEFSUBR (Fload_average);
3890 DEFSUBR (Ffeaturep);
3893 DEFSUBR (Fbase64_encode_region);
3894 DEFSUBR (Fbase64_encode_string);
3895 DEFSUBR (Fbase64_decode_region);
3896 DEFSUBR (Fbase64_decode_string);
3900 init_provide_once (void)
3902 DEFVAR_LISP ("features", &Vfeatures /*
3903 A list of symbols which are the features of the executing emacs.
3904 Used by `featurep' and `require', and altered by `provide'.
3908 Fprovide (intern ("base64"));