1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
52 /* NOTE: This symbol is also used in lread.c */
53 #define FEATUREP_SYNTAX
55 Lisp_Object Qstring_lessp;
56 Lisp_Object Qidentity;
58 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
61 mark_bit_vector (Lisp_Object obj)
67 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
70 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
71 size_t len = bit_vector_length (v);
74 if (INTP (Vprint_length))
75 last = min (len, XINT (Vprint_length));
76 write_c_string ("#*", printcharfun);
77 for (i = 0; i < last; i++)
79 if (bit_vector_bit (v, i))
80 write_c_string ("1", printcharfun);
82 write_c_string ("0", printcharfun);
86 write_c_string ("...", printcharfun);
90 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
92 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
93 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
95 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
96 !memcmp (v1->bits, v2->bits,
97 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
102 bit_vector_hash (Lisp_Object obj, int depth)
104 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
105 return HASH2 (bit_vector_length (v),
106 memory_hash (v->bits,
107 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
112 size_bit_vector (const void *lheader)
114 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
115 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
116 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
119 static const struct lrecord_description bit_vector_description[] = {
120 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
125 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
126 mark_bit_vector, print_bit_vector, 0,
127 bit_vector_equal, bit_vector_hash,
128 bit_vector_description, size_bit_vector,
131 DEFUN ("identity", Fidentity, 1, 1, 0, /*
132 Return the argument unchanged.
139 extern long get_random (void);
140 extern void seed_random (long arg);
142 DEFUN ("random", Frandom, 0, 1, 0, /*
143 Return a pseudo-random number.
144 All integers representable in Lisp are equally likely.
145 On most systems, this is 28 bits' worth.
146 With positive integer argument N, return random number in interval [0,N).
147 With argument t, set the random number seed from the current time and pid.
152 unsigned long denominator;
155 seed_random (getpid () + time (NULL));
156 if (NATNUMP (limit) && !ZEROP (limit))
158 /* Try to take our random number from the higher bits of VAL,
159 not the lower, since (says Gentzel) the low bits of `random'
160 are less random than the higher ones. We do this by using the
161 quotient rather than the remainder. At the high end of the RNG
162 it's possible to get a quotient larger than limit; discarding
163 these values eliminates the bias that would otherwise appear
164 when using a large limit. */
165 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
167 val = get_random () / denominator;
168 while (val >= XINT (limit));
173 return make_int (val);
176 /* Random data-structure functions */
178 #ifdef LOSING_BYTECODE
180 /* #### Delete this shit */
182 /* Charcount is a misnomer here as we might be dealing with the
183 length of a vector or list, but emphasizes that we're not dealing
184 with Bytecounts in strings */
186 length_with_bytecode_hack (Lisp_Object seq)
188 if (!COMPILED_FUNCTIONP (seq))
189 return XINT (Flength (seq));
192 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
194 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
195 f->flags.domainp ? COMPILED_DOMAIN :
201 #endif /* LOSING_BYTECODE */
204 check_losing_bytecode (const char *function, Lisp_Object seq)
206 if (COMPILED_FUNCTIONP (seq))
209 "As of 20.3, `%s' no longer works with compiled-function objects",
213 DEFUN ("length", Flength, 1, 1, 0, /*
214 Return the length of vector, bit vector, list or string SEQUENCE.
219 if (STRINGP (sequence))
220 return make_int (XSTRING_CHAR_LENGTH (sequence));
221 else if (CONSP (sequence))
224 GET_EXTERNAL_LIST_LENGTH (sequence, len);
225 return make_int (len);
227 else if (VECTORP (sequence))
228 return make_int (XVECTOR_LENGTH (sequence));
229 else if (NILP (sequence))
231 else if (BIT_VECTORP (sequence))
232 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
235 check_losing_bytecode ("length", sequence);
236 sequence = wrong_type_argument (Qsequencep, sequence);
241 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
242 Return the length of a list, but avoid error or infinite loop.
243 This function never gets an error. If LIST is not really a list,
244 it returns 0. If LIST is circular, it returns a finite value
245 which is at least the number of distinct elements.
249 Lisp_Object hare, tortoise;
252 for (hare = tortoise = list, len = 0;
253 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
254 hare = XCDR (hare), len++)
257 tortoise = XCDR (tortoise);
260 return make_int (len);
263 /*** string functions. ***/
265 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
266 Return t if two strings have identical contents.
267 Case is significant. Text properties are ignored.
268 \(Under XEmacs, `equal' also ignores text properties and extents in
269 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
270 `equal' is the same as in XEmacs, in that respect.)
271 Symbols are also allowed; their print names are used instead.
276 Lisp_String *p1, *p2;
279 p1 = XSYMBOL (s1)->name;
287 p2 = XSYMBOL (s2)->name;
294 return (((len = string_length (p1)) == string_length (p2)) &&
295 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
299 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
300 Return t if first arg string is less than second in lexicographic order.
301 If I18N2 support (but not Mule support) was compiled in, ordering is
302 determined by the locale. (Case is significant for the default C locale.)
303 In all other cases, comparison is simply done on a character-by-
304 character basis using the numeric value of a character. (Note that
305 this may not produce particularly meaningful results under Mule if
306 characters from different charsets are being compared.)
308 Symbols are also allowed; their print names are used instead.
310 The reason that the I18N2 locale-specific collation is not used under
311 Mule is that the locale model of internationalization does not handle
312 multiple charsets and thus has no hope of working properly under Mule.
313 What we really should do is create a collation table over all built-in
314 charsets. This is extremely difficult to do from scratch, however.
316 Unicode is a good first step towards solving this problem. In fact,
317 it is quite likely that a collation table exists (or will exist) for
318 Unicode. When Unicode support is added to XEmacs/Mule, this problem
323 Lisp_String *p1, *p2;
328 p1 = XSYMBOL (s1)->name;
336 p2 = XSYMBOL (s2)->name;
343 end = string_char_length (p1);
344 len2 = string_char_length (p2);
348 #if defined (I18N2) && !defined (MULE)
349 /* There is no hope of this working under Mule. Even if we converted
350 the data into an external format so that strcoll() processed it
351 properly, it would still not work because strcoll() does not
352 handle multiple locales. This is the fundamental flaw in the
355 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
356 /* Compare strings using collation order of locale. */
357 /* Need to be tricky to handle embedded nulls. */
359 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
361 int val = strcoll ((char *) string_data (p1) + i,
362 (char *) string_data (p2) + i);
369 #else /* not I18N2, or MULE */
371 Bufbyte *ptr1 = string_data (p1);
372 Bufbyte *ptr2 = string_data (p2);
374 /* #### It is not really necessary to do this: We could compare
375 byte-by-byte and still get a reasonable comparison, since this
376 would compare characters with a charset in the same way. With
377 a little rearrangement of the leading bytes, we could make most
378 inter-charset comparisons work out the same, too; even if some
379 don't, this is not a big deal because inter-charset comparisons
380 aren't really well-defined anyway. */
381 for (i = 0; i < end; i++)
383 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
384 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
389 #endif /* not I18N2, or MULE */
390 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
391 won't work right in I18N2 case */
392 return end < len2 ? Qt : Qnil;
395 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
396 Return STRING's tick counter, incremented for each change to the string.
397 Each string has a tick counter which is incremented each time the contents
398 of the string are changed (e.g. with `aset'). It wraps around occasionally.
404 CHECK_STRING (string);
405 s = XSTRING (string);
406 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
407 return XCAR (s->plist);
413 bump_string_modiff (Lisp_Object str)
415 Lisp_String *s = XSTRING (str);
416 Lisp_Object *ptr = &s->plist;
419 /* #### remove the `string-translatable' property from the string,
422 /* skip over extent info if it's there */
423 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
425 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
426 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
428 *ptr = Fcons (make_int (1), *ptr);
432 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
433 static Lisp_Object concat (int nargs, Lisp_Object *args,
434 enum concat_target_type target_type,
438 concat2 (Lisp_Object s1, Lisp_Object s2)
443 return concat (2, args, c_string, 0);
447 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
453 return concat (3, args, c_string, 0);
457 vconcat2 (Lisp_Object s1, Lisp_Object s2)
462 return concat (2, args, c_vector, 0);
466 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
472 return concat (3, args, c_vector, 0);
475 DEFUN ("append", Fappend, 0, MANY, 0, /*
476 Concatenate all the arguments and make the result a list.
477 The result is a list whose elements are the elements of all the arguments.
478 Each argument may be a list, vector, bit vector, or string.
479 The last argument is not copied, just used as the tail of the new list.
482 (int nargs, Lisp_Object *args))
484 return concat (nargs, args, c_cons, 1);
487 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
488 Concatenate all the arguments and make the result a string.
489 The result is a string whose elements are the elements of all the arguments.
490 Each argument may be a string or a list or vector of characters.
492 As of XEmacs 21.0, this function does NOT accept individual integers
493 as arguments. Old code that relies on, for example, (concat "foo" 50)
494 returning "foo50" will fail. To fix such code, either apply
495 `int-to-string' to the integer argument, or use `format'.
497 (int nargs, Lisp_Object *args))
499 return concat (nargs, args, c_string, 0);
502 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
503 Concatenate all the arguments and make the result a vector.
504 The result is a vector whose elements are the elements of all the arguments.
505 Each argument may be a list, vector, bit vector, or string.
507 (int nargs, Lisp_Object *args))
509 return concat (nargs, args, c_vector, 0);
512 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
513 Concatenate all the arguments and make the result a bit vector.
514 The result is a bit vector whose elements are the elements of all the
515 arguments. Each argument may be a list, vector, bit vector, or string.
517 (int nargs, Lisp_Object *args))
519 return concat (nargs, args, c_bit_vector, 0);
522 /* Copy a (possibly dotted) list. LIST must be a cons.
523 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
525 copy_list (Lisp_Object list)
527 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
528 Lisp_Object last = list_copy;
529 Lisp_Object hare, tortoise;
532 for (tortoise = hare = XCDR (list), len = 1;
534 hare = XCDR (hare), len++)
536 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
539 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
542 tortoise = XCDR (tortoise);
543 if (EQ (tortoise, hare))
544 signal_circular_list_error (list);
550 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
551 Return a copy of list LIST, which may be a dotted list.
552 The elements of LIST are not copied; they are shared
558 if (NILP (list)) return list;
559 if (CONSP (list)) return copy_list (list);
561 list = wrong_type_argument (Qlistp, list);
565 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
566 Return a copy of list, vector, bit vector or string SEQUENCE.
567 The elements of a list or vector are not copied; they are shared
568 with the original. SEQUENCE may be a dotted list.
573 if (NILP (sequence)) return sequence;
574 if (CONSP (sequence)) return copy_list (sequence);
575 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
576 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
577 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
579 check_losing_bytecode ("copy-sequence", sequence);
580 sequence = wrong_type_argument (Qsequencep, sequence);
584 struct merge_string_extents_struct
587 Bytecount entry_offset;
588 Bytecount entry_length;
592 concat (int nargs, Lisp_Object *args,
593 enum concat_target_type target_type,
597 Lisp_Object tail = Qnil;
600 Lisp_Object last_tail;
602 struct merge_string_extents_struct *args_mse = 0;
603 Bufbyte *string_result = 0;
604 Bufbyte *string_result_ptr = 0;
607 /* The modus operandi in Emacs is "caller gc-protects args".
608 However, concat is called many times in Emacs on freshly
609 created stuff. So we help those callers out by protecting
610 the args ourselves to save them a lot of temporary-variable
614 gcpro1.nvars = nargs;
617 /* #### if the result is a string and any of the strings have a string
618 for the `string-translatable' property, then concat should also
619 concat the args but use the `string-translatable' strings, and store
620 the result in the returned string's `string-translatable' property. */
622 if (target_type == c_string)
623 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
625 /* In append, the last arg isn't treated like the others */
626 if (last_special && nargs > 0)
629 last_tail = args[nargs];
634 /* Check and coerce the arguments. */
635 for (argnum = 0; argnum < nargs; argnum++)
637 Lisp_Object seq = args[argnum];
640 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
642 #ifdef LOSING_BYTECODE
643 else if (COMPILED_FUNCTIONP (seq))
644 /* Urk! We allow this, for "compatibility"... */
647 #if 0 /* removed for XEmacs 21 */
649 /* This is too revolting to think about but maintains
650 compatibility with FSF (and lots and lots of old code). */
651 args[argnum] = Fnumber_to_string (seq);
655 check_losing_bytecode ("concat", seq);
656 args[argnum] = wrong_type_argument (Qsequencep, seq);
662 args_mse[argnum].string = seq;
664 args_mse[argnum].string = Qnil;
669 /* Charcount is a misnomer here as we might be dealing with the
670 length of a vector or list, but emphasizes that we're not dealing
671 with Bytecounts in strings */
672 Charcount total_length;
674 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
676 #ifdef LOSING_BYTECODE
677 Charcount thislen = length_with_bytecode_hack (args[argnum]);
679 Charcount thislen = XINT (Flength (args[argnum]));
681 total_length += thislen;
687 if (total_length == 0)
688 /* In append, if all but last arg are nil, return last arg */
689 RETURN_UNGCPRO (last_tail);
690 val = Fmake_list (make_int (total_length), Qnil);
693 val = make_vector (total_length, Qnil);
696 val = make_bit_vector (total_length, Qzero);
699 /* We don't make the string yet because we don't know the
700 actual number of bytes. This loop was formerly written
701 to call Fmake_string() here and then call set_string_char()
702 for each char. This seems logical enough but is waaaaaaaay
703 slow -- set_string_char() has to scan the whole string up
704 to the place where the substitution is called for in order
705 to find the place to change, and may have to do some
706 realloc()ing in order to make the char fit properly.
709 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
710 string_result_ptr = string_result;
719 tail = val, toindex = -1; /* -1 in toindex is flag we are
726 for (argnum = 0; argnum < nargs; argnum++)
728 Charcount thisleni = 0;
729 Charcount thisindex = 0;
730 Lisp_Object seq = args[argnum];
731 Bufbyte *string_source_ptr = 0;
732 Bufbyte *string_prev_result_ptr = string_result_ptr;
736 #ifdef LOSING_BYTECODE
737 thisleni = length_with_bytecode_hack (seq);
739 thisleni = XINT (Flength (seq));
743 string_source_ptr = XSTRING_DATA (seq);
749 /* We've come to the end of this arg, so exit. */
753 /* Fetch next element of `seq' arg into `elt' */
761 if (thisindex >= thisleni)
766 elt = make_char (charptr_emchar (string_source_ptr));
767 INC_CHARPTR (string_source_ptr);
769 else if (VECTORP (seq))
770 elt = XVECTOR_DATA (seq)[thisindex];
771 else if (BIT_VECTORP (seq))
772 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
775 elt = Felt (seq, make_int (thisindex));
779 /* Store into result */
782 /* toindex negative means we are making a list */
787 else if (VECTORP (val))
788 XVECTOR_DATA (val)[toindex++] = elt;
789 else if (BIT_VECTORP (val))
792 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
796 CHECK_CHAR_COERCE_INT (elt);
797 string_result_ptr += set_charptr_emchar (string_result_ptr,
803 args_mse[argnum].entry_offset =
804 string_prev_result_ptr - string_result;
805 args_mse[argnum].entry_length =
806 string_result_ptr - string_prev_result_ptr;
810 /* Now we finally make the string. */
811 if (target_type == c_string)
813 val = make_string (string_result, string_result_ptr - string_result);
814 for (argnum = 0; argnum < nargs; argnum++)
816 if (STRINGP (args_mse[argnum].string))
817 copy_string_extents (val, args_mse[argnum].string,
818 args_mse[argnum].entry_offset, 0,
819 args_mse[argnum].entry_length);
824 XCDR (prev) = last_tail;
826 RETURN_UNGCPRO (val);
829 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
830 Return a copy of ALIST.
831 This is an alist which represents the same mapping from objects to objects,
832 but does not share the alist structure with ALIST.
833 The objects mapped (cars and cdrs of elements of the alist)
835 Elements of ALIST that are not conses are also shared.
845 alist = concat (1, &alist, c_cons, 0);
846 for (tail = alist; CONSP (tail); tail = XCDR (tail))
848 Lisp_Object car = XCAR (tail);
851 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
856 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
857 Return a copy of a list and substructures.
858 The argument is copied, and any lists contained within it are copied
859 recursively. Circularities and shared substructures are not preserved.
860 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
868 rest = arg = Fcopy_sequence (arg);
871 Lisp_Object elt = XCAR (rest);
873 if (CONSP (elt) || VECTORP (elt))
874 XCAR (rest) = Fcopy_tree (elt, vecp);
875 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
876 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
880 else if (VECTORP (arg) && ! NILP (vecp))
882 int i = XVECTOR_LENGTH (arg);
884 arg = Fcopy_sequence (arg);
885 for (j = 0; j < i; j++)
887 Lisp_Object elt = XVECTOR_DATA (arg) [j];
889 if (CONSP (elt) || VECTORP (elt))
890 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
896 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
897 Return a substring of STRING, starting at index FROM and ending before TO.
898 TO may be nil or omitted; then the substring runs to the end of STRING.
899 If FROM or TO is negative, it counts from the end.
900 Relevant parts of the string-extent-data are copied in the new string.
904 Charcount ccfr, ccto;
908 CHECK_STRING (string);
910 get_string_range_char (string, from, to, &ccfr, &ccto,
911 GB_HISTORICAL_STRING_BEHAVIOR);
912 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
913 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
914 val = make_string (XSTRING_DATA (string) + bfr, blen);
915 /* Copy any applicable extent information into the new string: */
916 copy_string_extents (val, string, 0, bfr, blen);
920 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
921 Return the subsequence of SEQUENCE starting at START and ending before END.
922 END may be omitted; then the subsequence runs to the end of SEQUENCE.
923 If START or END is negative, it counts from the end.
924 The returned subsequence is always of the same type as SEQUENCE.
925 If SEQUENCE is a string, relevant parts of the string-extent-data
926 are copied to the new string.
928 (sequence, start, end))
932 if (STRINGP (sequence))
933 return Fsubstring (sequence, start, end);
935 len = XINT (Flength (sequence));
952 if (!(0 <= s && s <= e && e <= len))
953 args_out_of_range_3 (sequence, make_int (s), make_int (e));
955 if (VECTORP (sequence))
957 Lisp_Object result = make_vector (e - s, Qnil);
959 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
960 Lisp_Object *out_elts = XVECTOR_DATA (result);
962 for (i = s; i < e; i++)
963 out_elts[i - s] = in_elts[i];
966 else if (LISTP (sequence))
968 Lisp_Object result = Qnil;
971 sequence = Fnthcdr (make_int (s), sequence);
973 for (i = s; i < e; i++)
975 result = Fcons (Fcar (sequence), result);
976 sequence = Fcdr (sequence);
979 return Fnreverse (result);
981 else if (BIT_VECTORP (sequence))
983 Lisp_Object result = make_bit_vector (e - s, Qzero);
986 for (i = s; i < e; i++)
987 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
988 bit_vector_bit (XBIT_VECTOR (sequence), i));
993 abort (); /* unreachable, since Flength (sequence) did not get
1000 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1001 Take cdr N times on LIST, and return the result.
1006 REGISTER Lisp_Object tail = list;
1008 for (i = XINT (n); i; i--)
1012 else if (NILP (tail))
1016 tail = wrong_type_argument (Qlistp, tail);
1023 DEFUN ("nth", Fnth, 2, 2, 0, /*
1024 Return the Nth element of LIST.
1025 N counts from zero. If LIST is not that long, nil is returned.
1029 return Fcar (Fnthcdr (n, list));
1032 DEFUN ("elt", Felt, 2, 2, 0, /*
1033 Return element of SEQUENCE at index N.
1038 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1039 if (LISTP (sequence))
1041 Lisp_Object tem = Fnthcdr (n, sequence);
1042 /* #### Utterly, completely, fucking disgusting.
1043 * #### The whole point of "elt" is that it operates on
1044 * #### sequences, and does error- (bounds-) checking.
1050 /* This is The Way It Has Always Been. */
1053 /* This is The Way Mly and Cltl2 say It Should Be. */
1054 args_out_of_range (sequence, n);
1057 else if (STRINGP (sequence) ||
1058 VECTORP (sequence) ||
1059 BIT_VECTORP (sequence))
1060 return Faref (sequence, n);
1061 #ifdef LOSING_BYTECODE
1062 else if (COMPILED_FUNCTIONP (sequence))
1064 EMACS_INT idx = XINT (n);
1068 args_out_of_range (sequence, n);
1070 /* Utter perversity */
1072 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1075 case COMPILED_ARGLIST:
1076 return compiled_function_arglist (f);
1077 case COMPILED_INSTRUCTIONS:
1078 return compiled_function_instructions (f);
1079 case COMPILED_CONSTANTS:
1080 return compiled_function_constants (f);
1081 case COMPILED_STACK_DEPTH:
1082 return compiled_function_stack_depth (f);
1083 case COMPILED_DOC_STRING:
1084 return compiled_function_documentation (f);
1085 case COMPILED_DOMAIN:
1086 return compiled_function_domain (f);
1087 case COMPILED_INTERACTIVE:
1088 if (f->flags.interactivep)
1089 return compiled_function_interactive (f);
1090 /* if we return nil, can't tell interactive with no args
1091 from noninteractive. */
1098 #endif /* LOSING_BYTECODE */
1101 check_losing_bytecode ("elt", sequence);
1102 sequence = wrong_type_argument (Qsequencep, sequence);
1107 DEFUN ("last", Flast, 1, 2, 0, /*
1108 Return the tail of list LIST, of length N (default 1).
1109 LIST may be a dotted list, but not a circular list.
1110 Optional argument N must be a non-negative integer.
1111 If N is zero, then the atom that terminates the list is returned.
1112 If N is greater than the length of LIST, then LIST itself is returned.
1116 EMACS_INT int_n, count;
1117 Lisp_Object retval, tortoise, hare;
1129 for (retval = tortoise = hare = list, count = 0;
1132 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1135 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1138 tortoise = XCDR (tortoise);
1139 if (EQ (hare, tortoise))
1140 signal_circular_list_error (list);
1146 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1147 Modify LIST to remove the last N (default 1) elements.
1148 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1165 Lisp_Object last_cons = list;
1167 EXTERNAL_LIST_LOOP_1 (list)
1170 last_cons = XCDR (last_cons);
1176 XCDR (last_cons) = Qnil;
1181 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1182 Return a copy of LIST with the last N (default 1) elements removed.
1183 If LIST has N or fewer elements, nil is returned.
1200 Lisp_Object retval = Qnil;
1201 Lisp_Object tail = list;
1203 EXTERNAL_LIST_LOOP_1 (list)
1207 retval = Fcons (XCAR (tail), retval);
1212 return Fnreverse (retval);
1216 DEFUN ("member", Fmember, 2, 2, 0, /*
1217 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1218 The value is actually the tail of LIST whose car is ELT.
1222 Lisp_Object list_elt, tail;
1223 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1225 if (internal_equal (elt, list_elt, 0))
1231 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1232 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1233 The value is actually the tail of LIST whose car is ELT.
1234 This function is provided only for byte-code compatibility with v19.
1239 Lisp_Object list_elt, tail;
1240 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1242 if (internal_old_equal (elt, list_elt, 0))
1248 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1249 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1250 The value is actually the tail of LIST whose car is ELT.
1254 Lisp_Object list_elt, tail;
1255 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1257 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1263 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1264 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1265 The value is actually the tail of LIST whose car is ELT.
1266 This function is provided only for byte-code compatibility with v19.
1271 Lisp_Object list_elt, tail;
1272 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1274 if (HACKEQ_UNSAFE (elt, list_elt))
1281 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1283 Lisp_Object list_elt, tail;
1284 LIST_LOOP_3 (list_elt, list, tail)
1286 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1292 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1293 Return non-nil if KEY is `equal' to the car of an element of LIST.
1294 The value is actually the element of LIST whose car equals KEY.
1298 /* This function can GC. */
1299 Lisp_Object elt, elt_car, elt_cdr;
1300 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1302 if (internal_equal (key, elt_car, 0))
1308 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1309 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1310 The value is actually the element of LIST whose car equals KEY.
1314 /* This function can GC. */
1315 Lisp_Object elt, elt_car, elt_cdr;
1316 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1318 if (internal_old_equal (key, elt_car, 0))
1325 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1327 int speccount = specpdl_depth ();
1328 specbind (Qinhibit_quit, Qt);
1329 return unbind_to (speccount, Fassoc (key, list));
1332 DEFUN ("assq", Fassq, 2, 2, 0, /*
1333 Return non-nil if KEY is `eq' to the car of an element of LIST.
1334 The value is actually the element of LIST whose car is KEY.
1335 Elements of LIST that are not conses are ignored.
1339 Lisp_Object elt, elt_car, elt_cdr;
1340 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1342 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1348 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1349 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1350 The value is actually the element of LIST whose car is KEY.
1351 Elements of LIST that are not conses are ignored.
1352 This function is provided only for byte-code compatibility with v19.
1357 Lisp_Object elt, elt_car, elt_cdr;
1358 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1360 if (HACKEQ_UNSAFE (key, elt_car))
1366 /* Like Fassq but never report an error and do not allow quits.
1367 Use only on lists known never to be circular. */
1370 assq_no_quit (Lisp_Object key, Lisp_Object list)
1372 /* This cannot GC. */
1374 LIST_LOOP_2 (elt, list)
1376 Lisp_Object elt_car = XCAR (elt);
1377 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1383 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1384 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1385 The value is actually the element of LIST whose cdr equals KEY.
1389 Lisp_Object elt, elt_car, elt_cdr;
1390 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1392 if (internal_equal (key, elt_cdr, 0))
1398 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1399 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1400 The value is actually the element of LIST whose cdr equals KEY.
1404 Lisp_Object elt, elt_car, elt_cdr;
1405 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1407 if (internal_old_equal (key, elt_cdr, 0))
1413 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1414 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1415 The value is actually the element of LIST whose cdr is KEY.
1419 Lisp_Object elt, elt_car, elt_cdr;
1420 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1422 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1428 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1429 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1430 The value is actually the element of LIST whose cdr is KEY.
1434 Lisp_Object elt, elt_car, elt_cdr;
1435 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1437 if (HACKEQ_UNSAFE (key, elt_cdr))
1443 /* Like Frassq, but caller must ensure that LIST is properly
1444 nil-terminated and ebola-free. */
1446 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1449 LIST_LOOP_2 (elt, list)
1451 Lisp_Object elt_cdr = XCDR (elt);
1452 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1459 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1460 Delete by side effect any occurrences of ELT as a member of LIST.
1461 The modified LIST is returned. Comparison is done with `equal'.
1462 If the first member of LIST is ELT, there is no way to remove it by side
1463 effect; therefore, write `(setq foo (delete element foo))' to be sure
1464 of changing the value of `foo'.
1469 Lisp_Object list_elt;
1470 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1471 (internal_equal (elt, list_elt, 0)));
1475 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1476 Delete by side effect any occurrences of ELT as a member of LIST.
1477 The modified LIST is returned. Comparison is done with `old-equal'.
1478 If the first member of LIST is ELT, there is no way to remove it by side
1479 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1480 of changing the value of `foo'.
1484 Lisp_Object list_elt;
1485 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1486 (internal_old_equal (elt, list_elt, 0)));
1490 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1491 Delete by side effect any occurrences of ELT as a member of LIST.
1492 The modified LIST is returned. Comparison is done with `eq'.
1493 If the first member of LIST is ELT, there is no way to remove it by side
1494 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1495 changing the value of `foo'.
1499 Lisp_Object list_elt;
1500 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1501 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1505 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1506 Delete by side effect any occurrences of ELT as a member of LIST.
1507 The modified LIST is returned. Comparison is done with `old-eq'.
1508 If the first member of LIST is ELT, there is no way to remove it by side
1509 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1510 changing the value of `foo'.
1514 Lisp_Object list_elt;
1515 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1516 (HACKEQ_UNSAFE (elt, list_elt)));
1520 /* Like Fdelq, but caller must ensure that LIST is properly
1521 nil-terminated and ebola-free. */
1524 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1526 Lisp_Object list_elt;
1527 LIST_LOOP_DELETE_IF (list_elt, list,
1528 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1532 /* Be VERY careful with this. This is like delq_no_quit() but
1533 also calls free_cons() on the removed conses. You must be SURE
1534 that no pointers to the freed conses remain around (e.g.
1535 someone else is pointing to part of the list). This function
1536 is useful on internal lists that are used frequently and where
1537 the actual list doesn't escape beyond known code bounds. */
1540 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1542 REGISTER Lisp_Object tail = list;
1543 REGISTER Lisp_Object prev = Qnil;
1545 while (!NILP (tail))
1547 REGISTER Lisp_Object tem = XCAR (tail);
1550 Lisp_Object cons_to_free = tail;
1554 XCDR (prev) = XCDR (tail);
1556 free_cons (XCONS (cons_to_free));
1567 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1568 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1569 The modified LIST is returned. If the first member of LIST has a car
1570 that is `equal' to KEY, there is no way to remove it by side effect;
1571 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1577 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1579 internal_equal (key, XCAR (elt), 0)));
1584 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1586 int speccount = specpdl_depth ();
1587 specbind (Qinhibit_quit, Qt);
1588 return unbind_to (speccount, Fremassoc (key, list));
1591 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1592 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1593 The modified LIST is returned. If the first member of LIST has a car
1594 that is `eq' to KEY, there is no way to remove it by side effect;
1595 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1601 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1603 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1607 /* no quit, no errors; be careful */
1610 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1613 LIST_LOOP_DELETE_IF (elt, list,
1615 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1619 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1620 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1621 The modified LIST is returned. If the first member of LIST has a car
1622 that is `equal' to VALUE, there is no way to remove it by side effect;
1623 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1629 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1631 internal_equal (value, XCDR (elt), 0)));
1635 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1636 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1637 The modified LIST is returned. If the first member of LIST has a car
1638 that is `eq' to VALUE, there is no way to remove it by side effect;
1639 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1645 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1647 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1651 /* Like Fremrassq, fast and unsafe; be careful */
1653 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1656 LIST_LOOP_DELETE_IF (elt, list,
1658 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1662 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1663 Reverse LIST by destructively modifying cdr pointers.
1664 Return the beginning of the reversed list.
1665 Also see: `reverse'.
1669 struct gcpro gcpro1, gcpro2;
1670 REGISTER Lisp_Object prev = Qnil;
1671 REGISTER Lisp_Object tail = list;
1673 /* We gcpro our args; see `nconc' */
1674 GCPRO2 (prev, tail);
1675 while (!NILP (tail))
1677 REGISTER Lisp_Object next;
1678 CONCHECK_CONS (tail);
1688 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1689 Reverse LIST, copying. Return the beginning of the reversed list.
1690 See also the function `nreverse', which is used more often.
1694 Lisp_Object reversed_list = Qnil;
1696 EXTERNAL_LIST_LOOP_2 (elt, list)
1698 reversed_list = Fcons (elt, reversed_list);
1700 return reversed_list;
1703 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1704 Lisp_Object lisp_arg,
1705 int (*pred_fn) (Lisp_Object, Lisp_Object,
1706 Lisp_Object lisp_arg));
1709 list_sort (Lisp_Object list,
1710 Lisp_Object lisp_arg,
1711 int (*pred_fn) (Lisp_Object, Lisp_Object,
1712 Lisp_Object lisp_arg))
1714 struct gcpro gcpro1, gcpro2, gcpro3;
1715 Lisp_Object back, tem;
1716 Lisp_Object front = list;
1717 Lisp_Object len = Flength (list);
1718 int length = XINT (len);
1723 XSETINT (len, (length / 2) - 1);
1724 tem = Fnthcdr (len, list);
1726 Fsetcdr (tem, Qnil);
1728 GCPRO3 (front, back, lisp_arg);
1729 front = list_sort (front, lisp_arg, pred_fn);
1730 back = list_sort (back, lisp_arg, pred_fn);
1732 return list_merge (front, back, lisp_arg, pred_fn);
1737 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1742 /* prevents the GC from happening in call2 */
1743 int speccount = specpdl_depth ();
1744 /* Emacs' GC doesn't actually relocate pointers, so this probably
1745 isn't strictly necessary */
1746 record_unwind_protect (restore_gc_inhibit,
1747 make_int (gc_currently_forbidden));
1748 gc_currently_forbidden = 1;
1749 tmp = call2 (pred, obj1, obj2);
1750 unbind_to (speccount, Qnil);
1758 DEFUN ("sort", Fsort, 2, 2, 0, /*
1759 Sort LIST, stably, comparing elements using PREDICATE.
1760 Returns the sorted list. LIST is modified by side effects.
1761 PREDICATE is called with two elements of LIST, and should return T
1762 if the first element is "less" than the second.
1766 return list_sort (list, pred, merge_pred_function);
1770 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1773 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1778 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1779 Lisp_Object lisp_arg,
1780 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1786 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1793 /* It is sufficient to protect org_l1 and org_l2.
1794 When l1 and l2 are updated, we copy the new values
1795 back into the org_ vars. */
1797 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1818 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1833 Fsetcdr (tail, tem);
1839 /************************************************************************/
1840 /* property-list functions */
1841 /************************************************************************/
1843 /* For properties of text, we need to do order-insensitive comparison of
1844 plists. That is, we need to compare two plists such that they are the
1845 same if they have the same set of keys, and equivalent values.
1846 So (a 1 b 2) would be equal to (b 2 a 1).
1848 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1849 LAXP means use `equal' for comparisons.
1852 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1853 int laxp, int depth)
1855 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1856 int la, lb, m, i, fill;
1857 Lisp_Object *keys, *vals;
1861 if (NILP (a) && NILP (b))
1864 Fcheck_valid_plist (a);
1865 Fcheck_valid_plist (b);
1867 la = XINT (Flength (a));
1868 lb = XINT (Flength (b));
1869 m = (la > lb ? la : lb);
1871 keys = alloca_array (Lisp_Object, m);
1872 vals = alloca_array (Lisp_Object, m);
1873 flags = alloca_array (char, m);
1875 /* First extract the pairs from A. */
1876 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1878 Lisp_Object k = XCAR (rest);
1879 Lisp_Object v = XCAR (XCDR (rest));
1880 /* Maybe be Ebolified. */
1881 if (nil_means_not_present && NILP (v)) continue;
1887 /* Now iterate over B, and stop if we find something that's not in A,
1888 or that doesn't match. As we match, mark them. */
1889 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1891 Lisp_Object k = XCAR (rest);
1892 Lisp_Object v = XCAR (XCDR (rest));
1893 /* Maybe be Ebolified. */
1894 if (nil_means_not_present && NILP (v)) continue;
1895 for (i = 0; i < fill; i++)
1897 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1900 /* We narrowly escaped being Ebolified here. */
1901 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1902 : !internal_equal (v, vals [i], depth))
1903 /* a property in B has a different value than in A */
1910 /* there are some properties in B that are not in A */
1913 /* Now check to see that all the properties in A were also in B */
1914 for (i = 0; i < fill; i++)
1925 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1926 Return non-nil if property lists A and B are `eq'.
1927 A property list is an alternating list of keywords and values.
1928 This function does order-insensitive comparisons of the property lists:
1929 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1930 Comparison between values is done using `eq'. See also `plists-equal'.
1931 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1932 a nil value is ignored. This feature is a virus that has infected
1933 old Lisp implementations, but should not be used except for backward
1936 (a, b, nil_means_not_present))
1938 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1942 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1943 Return non-nil if property lists A and B are `equal'.
1944 A property list is an alternating list of keywords and values. This
1945 function does order-insensitive comparisons of the property lists: For
1946 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1947 Comparison between values is done using `equal'. See also `plists-eq'.
1948 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1949 a nil value is ignored. This feature is a virus that has infected
1950 old Lisp implementations, but should not be used except for backward
1953 (a, b, nil_means_not_present))
1955 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1960 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1961 Return non-nil if lax property lists A and B are `eq'.
1962 A property list is an alternating list of keywords and values.
1963 This function does order-insensitive comparisons of the property lists:
1964 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1965 Comparison between values is done using `eq'. See also `plists-equal'.
1966 A lax property list is like a regular one except that comparisons between
1967 keywords is done using `equal' instead of `eq'.
1968 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1969 a nil value is ignored. This feature is a virus that has infected
1970 old Lisp implementations, but should not be used except for backward
1973 (a, b, nil_means_not_present))
1975 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1979 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1980 Return non-nil if lax property lists A and B are `equal'.
1981 A property list is an alternating list of keywords and values. This
1982 function does order-insensitive comparisons of the property lists: For
1983 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1984 Comparison between values is done using `equal'. See also `plists-eq'.
1985 A lax property list is like a regular one except that comparisons between
1986 keywords is done using `equal' instead of `eq'.
1987 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1988 a nil value is ignored. This feature is a virus that has infected
1989 old Lisp implementations, but should not be used except for backward
1992 (a, b, nil_means_not_present))
1994 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1998 /* Return the value associated with key PROPERTY in property list PLIST.
1999 Return nil if key not found. This function is used for internal
2000 property lists that cannot be directly manipulated by the user.
2004 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2008 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2010 if (EQ (XCAR (tail), property))
2011 return XCAR (XCDR (tail));
2017 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2018 internal_plist_get(). */
2021 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2026 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2028 if (EQ (XCAR (tail), property))
2030 XCAR (XCDR (tail)) = value;
2035 *plist = Fcons (property, Fcons (value, *plist));
2039 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2041 Lisp_Object tail, prev;
2043 for (tail = *plist, prev = Qnil;
2045 tail = XCDR (XCDR (tail)))
2047 if (EQ (XCAR (tail), property))
2050 *plist = XCDR (XCDR (tail));
2052 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2062 /* Called on a malformed property list. BADPLACE should be some
2063 place where truncating will form a good list -- i.e. we shouldn't
2064 result in a list with an odd length. */
2067 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2069 if (ERRB_EQ (errb, ERROR_ME))
2070 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2073 if (ERRB_EQ (errb, ERROR_ME_WARN))
2075 warn_when_safe_lispobj
2078 ("Malformed property list -- list has been truncated"),
2086 /* Called on a circular property list. BADPLACE should be some place
2087 where truncating will result in an even-length list, as above.
2088 If doesn't particularly matter where we truncate -- anywhere we
2089 truncate along the entire list will break the circularity, because
2090 it will create a terminus and the list currently doesn't have one.
2094 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2096 if (ERRB_EQ (errb, ERROR_ME))
2097 /* #### Eek, this will probably result in another error
2098 when PLIST is printed out */
2099 return Fsignal (Qcircular_property_list, list1 (*plist));
2102 if (ERRB_EQ (errb, ERROR_ME_WARN))
2104 warn_when_safe_lispobj
2107 ("Circular property list -- list has been truncated"),
2115 /* Advance the tortoise pointer by two (one iteration of a property-list
2116 loop) and the hare pointer by four and verify that no malformations
2117 or circularities exist. If so, return zero and store a value into
2118 RETVAL that should be returned by the calling function. Otherwise,
2119 return 1. See external_plist_get().
2123 advance_plist_pointers (Lisp_Object *plist,
2124 Lisp_Object **tortoise, Lisp_Object **hare,
2125 Error_behavior errb, Lisp_Object *retval)
2128 Lisp_Object *tortsave = *tortoise;
2130 /* Note that our "fixing" may be more brutal than necessary,
2131 but it's the user's own problem, not ours, if they went in and
2132 manually fucked up a plist. */
2134 for (i = 0; i < 2; i++)
2136 /* This is a standard iteration of a defensive-loop-checking
2137 loop. We just do it twice because we want to advance past
2138 both the property and its value.
2140 If the pointer indirection is confusing you, remember that
2141 one level of indirection on the hare and tortoise pointers
2142 is only due to pass-by-reference for this function. The other
2143 level is so that the plist can be fixed in place. */
2145 /* When we reach the end of a well-formed plist, **HARE is
2146 nil. In that case, we don't do anything at all except
2147 advance TORTOISE by one. Otherwise, we advance HARE
2148 by two (making sure it's OK to do so), then advance
2149 TORTOISE by one (it will always be OK to do so because
2150 the HARE is always ahead of the TORTOISE and will have
2151 already verified the path), then make sure TORTOISE and
2152 HARE don't contain the same non-nil object -- if the
2153 TORTOISE and the HARE ever meet, then obviously we're
2154 in a circularity, and if we're in a circularity, then
2155 the TORTOISE and the HARE can't cross paths without
2156 meeting, since the HARE only gains one step over the
2157 TORTOISE per iteration. */
2161 Lisp_Object *haresave = *hare;
2162 if (!CONSP (**hare))
2164 *retval = bad_bad_bunny (plist, haresave, errb);
2167 *hare = &XCDR (**hare);
2168 /* In a non-plist, we'd check here for a nil value for
2169 **HARE, which is OK (it just means the list has an
2170 odd number of elements). In a plist, it's not OK
2171 for the list to have an odd number of elements. */
2172 if (!CONSP (**hare))
2174 *retval = bad_bad_bunny (plist, haresave, errb);
2177 *hare = &XCDR (**hare);
2180 *tortoise = &XCDR (**tortoise);
2181 if (!NILP (**hare) && EQ (**tortoise, **hare))
2183 *retval = bad_bad_turtle (plist, tortsave, errb);
2191 /* Return the value of PROPERTY from PLIST, or Qunbound if
2192 property is not on the list.
2194 PLIST is a Lisp-accessible property list, meaning that it
2195 has to be checked for malformations and circularities.
2197 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2198 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2199 on finding a malformation or a circularity, it issues a warning and
2200 attempts to silently fix the problem.
2202 A pointer to PLIST is passed in so that PLIST can be successfully
2203 "fixed" even if the error is at the beginning of the plist. */
2206 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2207 int laxp, Error_behavior errb)
2209 Lisp_Object *tortoise = plist;
2210 Lisp_Object *hare = plist;
2212 while (!NILP (*tortoise))
2214 Lisp_Object *tortsave = tortoise;
2217 /* We do the standard tortoise/hare march. We isolate the
2218 grungy stuff to do this in advance_plist_pointers(), though.
2219 To us, all this function does is advance the tortoise
2220 pointer by two and the hare pointer by four and make sure
2221 everything's OK. We first advance the pointers and then
2222 check if a property matched; this ensures that our
2223 check for a matching property is safe. */
2225 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2228 if (!laxp ? EQ (XCAR (*tortsave), property)
2229 : internal_equal (XCAR (*tortsave), property, 0))
2230 return XCAR (XCDR (*tortsave));
2236 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2237 malformed or circular plist. Analogous to external_plist_get(). */
2240 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2241 Lisp_Object value, int laxp, Error_behavior errb)
2243 Lisp_Object *tortoise = plist;
2244 Lisp_Object *hare = plist;
2246 while (!NILP (*tortoise))
2248 Lisp_Object *tortsave = tortoise;
2252 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2255 if (!laxp ? EQ (XCAR (*tortsave), property)
2256 : internal_equal (XCAR (*tortsave), property, 0))
2258 XCAR (XCDR (*tortsave)) = value;
2263 *plist = Fcons (property, Fcons (value, *plist));
2267 external_remprop (Lisp_Object *plist, Lisp_Object property,
2268 int laxp, Error_behavior errb)
2270 Lisp_Object *tortoise = plist;
2271 Lisp_Object *hare = plist;
2273 while (!NILP (*tortoise))
2275 Lisp_Object *tortsave = tortoise;
2279 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2282 if (!laxp ? EQ (XCAR (*tortsave), property)
2283 : internal_equal (XCAR (*tortsave), property, 0))
2285 /* Now you see why it's so convenient to have that level
2287 *tortsave = XCDR (XCDR (*tortsave));
2295 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2296 Extract a value from a property list.
2297 PLIST is a property list, which is a list of the form
2298 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2299 corresponding to the given PROP, or DEFAULT if PROP is not
2300 one of the properties on the list.
2302 (plist, prop, default_))
2304 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2305 return UNBOUNDP (val) ? default_ : val;
2308 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2309 Change value in PLIST of PROP to VAL.
2310 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2311 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2312 If PROP is already a property on the list, its value is set to VAL,
2313 otherwise the new PROP VAL pair is added. The new plist is returned;
2314 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2315 The PLIST is modified by side effects.
2319 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2323 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2324 Remove from PLIST the property PROP and its value.
2325 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2326 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2327 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2328 the new value. The PLIST is modified by side effects.
2332 external_remprop (&plist, prop, 0, ERROR_ME);
2336 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2337 Return t if PROP has a value specified in PLIST.
2341 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2342 return UNBOUNDP (val) ? Qnil : Qt;
2345 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2346 Given a plist, signal an error if there is anything wrong with it.
2347 This means that it's a malformed or circular plist.
2351 Lisp_Object *tortoise;
2357 while (!NILP (*tortoise))
2362 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2370 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2371 Given a plist, return non-nil if its format is correct.
2372 If it returns nil, `check-valid-plist' will signal an error when given
2373 the plist; that means it's a malformed or circular plist.
2377 Lisp_Object *tortoise;
2382 while (!NILP (*tortoise))
2387 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2395 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2396 Destructively remove any duplicate entries from a plist.
2397 In such cases, the first entry applies.
2399 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2400 a nil value is removed. This feature is a virus that has infected
2401 old Lisp implementations, but should not be used except for backward
2404 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2405 return value may not be EQ to the passed-in value, so make sure to
2406 `setq' the value back into where it came from.
2408 (plist, nil_means_not_present))
2410 Lisp_Object head = plist;
2412 Fcheck_valid_plist (plist);
2414 while (!NILP (plist))
2416 Lisp_Object prop = Fcar (plist);
2417 Lisp_Object next = Fcdr (plist);
2419 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2420 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2422 if (EQ (head, plist))
2424 plist = Fcdr (next);
2427 /* external_remprop returns 1 if it removed any property.
2428 We have to loop till it didn't remove anything, in case
2429 the property occurs many times. */
2430 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2432 plist = Fcdr (next);
2438 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2439 Extract a value from a lax property list.
2441 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2442 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2443 using `equal' instead of `eq'. This function returns the value
2444 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2445 properties on the list.
2447 (lax_plist, prop, default_))
2449 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2450 return UNBOUNDP (val) ? default_ : val;
2453 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2454 Change value in LAX-PLIST of PROP to VAL.
2455 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2456 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2457 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2458 any object. If PROP is already a property on the list, its value is
2459 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2460 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2461 use the new value. The LAX-PLIST is modified by side effects.
2463 (lax_plist, prop, val))
2465 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2469 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2470 Remove from LAX-PLIST the property PROP and its value.
2471 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2472 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2473 using `equal' instead of `eq'. PROP is usually a symbol. The new
2474 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2475 sure to use the new value. The LAX-PLIST is modified by side effects.
2479 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2483 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2484 Return t if PROP has a value specified in LAX-PLIST.
2485 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2486 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2487 using `equal' instead of `eq'.
2491 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2494 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2495 Destructively remove any duplicate entries from a lax plist.
2496 In such cases, the first entry applies.
2498 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2499 a nil value is removed. This feature is a virus that has infected
2500 old Lisp implementations, but should not be used except for backward
2503 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2504 return value may not be EQ to the passed-in value, so make sure to
2505 `setq' the value back into where it came from.
2507 (lax_plist, nil_means_not_present))
2509 Lisp_Object head = lax_plist;
2511 Fcheck_valid_plist (lax_plist);
2513 while (!NILP (lax_plist))
2515 Lisp_Object prop = Fcar (lax_plist);
2516 Lisp_Object next = Fcdr (lax_plist);
2518 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2519 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2521 if (EQ (head, lax_plist))
2523 lax_plist = Fcdr (next);
2526 /* external_remprop returns 1 if it removed any property.
2527 We have to loop till it didn't remove anything, in case
2528 the property occurs many times. */
2529 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2531 lax_plist = Fcdr (next);
2537 /* In C because the frame props stuff uses it */
2539 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2540 Convert association list ALIST into the equivalent property-list form.
2541 The plist is returned. This converts from
2543 \((a . 1) (b . 2) (c . 3))
2549 The original alist is destroyed in the process of constructing the plist.
2550 See also `alist-to-plist'.
2554 Lisp_Object head = alist;
2555 while (!NILP (alist))
2557 /* remember the alist element. */
2558 Lisp_Object el = Fcar (alist);
2560 Fsetcar (alist, Fcar (el));
2561 Fsetcar (el, Fcdr (el));
2562 Fsetcdr (el, Fcdr (alist));
2563 Fsetcdr (alist, el);
2564 alist = Fcdr (Fcdr (alist));
2570 DEFUN ("get", Fget, 2, 3, 0, /*
2571 Return the value of OBJECT's PROPERTY property.
2572 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2573 If there is no such property, return optional third arg DEFAULT
2574 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2575 face, or glyph. See also `put', `remprop', and `object-plist'.
2577 (object, property, default_))
2579 /* Various places in emacs call Fget() and expect it not to quit,
2583 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2584 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2586 signal_simple_error ("Object type has no properties", object);
2588 return UNBOUNDP (val) ? default_ : val;
2591 DEFUN ("put", Fput, 3, 3, 0, /*
2592 Set OBJECT's PROPERTY to VALUE.
2593 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2594 OBJECT can be a symbol, face, extent, or string.
2595 For a string, no properties currently have predefined meanings.
2596 For the predefined properties for extents, see `set-extent-property'.
2597 For the predefined properties for faces, see `set-face-property'.
2598 See also `get', `remprop', and `object-plist'.
2600 (object, property, value))
2602 CHECK_LISP_WRITEABLE (object);
2604 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2606 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2607 (object, property, value))
2608 signal_simple_error ("Can't set property on object", property);
2611 signal_simple_error ("Object type has no settable properties", object);
2616 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2617 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2618 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2619 if the property list was actually modified (i.e. if PROPERTY was present
2620 in the property list). See also `get', `put', and `object-plist'.
2626 CHECK_LISP_WRITEABLE (object);
2628 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2630 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2632 signal_simple_error ("Can't remove property from object", property);
2635 signal_simple_error ("Object type has no removable properties", object);
2637 return ret ? Qt : Qnil;
2640 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2641 Return a property list of OBJECT's properties.
2642 For a symbol, this is equivalent to `symbol-plist'.
2643 OBJECT can be a symbol, string, extent, face, or glyph.
2644 Do not modify the returned property list directly;
2645 this may or may not have the desired effects. Use `put' instead.
2649 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2650 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2652 signal_simple_error ("Object type has no properties", object);
2659 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2662 error ("Stack overflow in equal");
2664 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2666 /* Note that (equal 20 20.0) should be nil */
2667 if (XTYPE (obj1) != XTYPE (obj2))
2669 if (LRECORDP (obj1))
2671 const struct lrecord_implementation
2672 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2673 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2675 return (imp1 == imp2) &&
2676 /* EQ-ness of the objects was noticed above */
2677 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2683 /* Note that we may be calling sub-objects that will use
2684 internal_equal() (instead of internal_old_equal()). Oh well.
2685 We will get an Ebola note if there's any possibility of confusion,
2686 but that seems unlikely. */
2689 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2692 error ("Stack overflow in equal");
2694 if (HACKEQ_UNSAFE (obj1, obj2))
2696 /* Note that (equal 20 20.0) should be nil */
2697 if (XTYPE (obj1) != XTYPE (obj2))
2700 return internal_equal (obj1, obj2, depth);
2703 DEFUN ("equal", Fequal, 2, 2, 0, /*
2704 Return t if two Lisp objects have similar structure and contents.
2705 They must have the same data type.
2706 Conses are compared by comparing the cars and the cdrs.
2707 Vectors and strings are compared element by element.
2708 Numbers are compared by value. Symbols must match exactly.
2712 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2715 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2716 Return t if two Lisp objects have similar structure and contents.
2717 They must have the same data type.
2718 \(Note, however, that an exception is made for characters and integers;
2719 this is known as the "char-int confoundance disease." See `eq' and
2721 This function is provided only for byte-code compatibility with v19.
2726 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2730 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2731 Destructively modify ARRAY by replacing each element with ITEM.
2732 ARRAY is a vector, bit vector, or string.
2737 if (STRINGP (array))
2739 Lisp_String *s = XSTRING (array);
2740 Bytecount old_bytecount = string_length (s);
2741 Bytecount new_bytecount;
2742 Bytecount item_bytecount;
2743 Bufbyte item_buf[MAX_EMCHAR_LEN];
2747 CHECK_CHAR_COERCE_INT (item);
2748 CHECK_LISP_WRITEABLE (array);
2750 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2751 new_bytecount = item_bytecount * string_char_length (s);
2753 resize_string (s, -1, new_bytecount - old_bytecount);
2755 for (p = string_data (s), end = p + new_bytecount;
2757 p += item_bytecount)
2758 memcpy (p, item_buf, item_bytecount);
2761 bump_string_modiff (array);
2763 else if (VECTORP (array))
2765 Lisp_Object *p = XVECTOR_DATA (array);
2766 int len = XVECTOR_LENGTH (array);
2767 CHECK_LISP_WRITEABLE (array);
2771 else if (BIT_VECTORP (array))
2773 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2774 int len = bit_vector_length (v);
2777 CHECK_LISP_WRITEABLE (array);
2780 set_bit_vector_bit (v, len, bit);
2784 array = wrong_type_argument (Qarrayp, array);
2791 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2793 Lisp_Object args[2];
2794 struct gcpro gcpro1;
2801 RETURN_UNGCPRO (bytecode_nconc2 (args));
2805 bytecode_nconc2 (Lisp_Object *args)
2809 if (CONSP (args[0]))
2811 /* (setcdr (last args[0]) args[1]) */
2812 Lisp_Object tortoise, hare;
2815 for (hare = tortoise = args[0], count = 0;
2816 CONSP (XCDR (hare));
2817 hare = XCDR (hare), count++)
2819 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2822 tortoise = XCDR (tortoise);
2823 if (EQ (hare, tortoise))
2824 signal_circular_list_error (args[0]);
2826 XCDR (hare) = args[1];
2829 else if (NILP (args[0]))
2835 args[0] = wrong_type_argument (args[0], Qlistp);
2840 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2841 Concatenate any number of lists by altering them.
2842 Only the last argument is not altered, and need not be a list.
2844 If the first argument is nil, there is no way to modify it by side
2845 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2846 changing the value of `foo'.
2848 (int nargs, Lisp_Object *args))
2851 struct gcpro gcpro1;
2853 /* The modus operandi in Emacs is "caller gc-protects args".
2854 However, nconc (particularly nconc2 ()) is called many times
2855 in Emacs on freshly created stuff (e.g. you see the idiom
2856 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2857 callers out by protecting the args ourselves to save them
2858 a lot of temporary-variable grief. */
2861 gcpro1.nvars = nargs;
2863 while (argnum < nargs)
2870 /* `val' is the first cons, which will be our return value. */
2871 /* `last_cons' will be the cons cell to mutate. */
2872 Lisp_Object last_cons = val;
2873 Lisp_Object tortoise = val;
2875 for (argnum++; argnum < nargs; argnum++)
2877 Lisp_Object next = args[argnum];
2879 if (CONSP (next) || argnum == nargs -1)
2881 /* (setcdr (last val) next) */
2885 CONSP (XCDR (last_cons));
2886 last_cons = XCDR (last_cons), count++)
2888 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2891 tortoise = XCDR (tortoise);
2892 if (EQ (last_cons, tortoise))
2893 signal_circular_list_error (args[argnum-1]);
2895 XCDR (last_cons) = next;
2897 else if (NILP (next))
2903 next = wrong_type_argument (Qlistp, next);
2907 RETURN_UNGCPRO (val);
2909 else if (NILP (val))
2911 else if (argnum == nargs - 1) /* last arg? */
2912 RETURN_UNGCPRO (val);
2915 args[argnum] = wrong_type_argument (Qlistp, val);
2919 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2923 /* This is the guts of several mapping functions.
2924 Apply FUNCTION to each element of SEQUENCE, one by one,
2925 storing the results into elements of VALS, a C vector of Lisp_Objects.
2926 LENI is the length of VALS, which should also be the length of SEQUENCE.
2928 If VALS is a null pointer, do not accumulate the results. */
2931 mapcar1 (size_t leni, Lisp_Object *vals,
2932 Lisp_Object function, Lisp_Object sequence)
2935 Lisp_Object args[2];
2937 struct gcpro gcpro1;
2947 if (LISTP (sequence))
2949 /* A devious `function' could either:
2950 - insert garbage into the list in front of us, causing XCDR to crash
2951 - amputate the list behind us using (setcdr), causing the remaining
2952 elts to lose their GCPRO status.
2954 if (vals != 0) we avoid this by copying the elts into the
2955 `vals' array. By a stroke of luck, `vals' is exactly large
2956 enough to hold the elts left to be traversed as well as the
2957 results computed so far.
2959 if (vals == 0) we don't have any free space available and
2960 don't want to eat up any more stack with alloca().
2961 So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
2965 Lisp_Object *val = vals;
2968 LIST_LOOP_2 (elt, sequence)
2971 gcpro1.nvars = leni;
2973 for (i = 0; i < leni; i++)
2976 vals[i] = Ffuncall (2, args);
2981 Lisp_Object elt, tail;
2982 struct gcpro ngcpro1;
2987 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2997 else if (VECTORP (sequence))
2999 Lisp_Object *objs = XVECTOR_DATA (sequence);
3000 for (i = 0; i < leni; i++)
3003 result = Ffuncall (2, args);
3004 if (vals) vals[gcpro1.nvars++] = result;
3007 else if (STRINGP (sequence))
3009 /* The string data of `sequence' might be relocated during GC. */
3010 Bytecount slen = XSTRING_LENGTH (sequence);
3011 Bufbyte *p = alloca_array (Bufbyte, slen);
3012 Bufbyte *end = p + slen;
3014 memcpy (p, XSTRING_DATA (sequence), slen);
3018 args[1] = make_char (charptr_emchar (p));
3020 result = Ffuncall (2, args);
3021 if (vals) vals[gcpro1.nvars++] = result;
3024 else if (BIT_VECTORP (sequence))
3026 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3027 for (i = 0; i < leni; i++)
3029 args[1] = make_int (bit_vector_bit (v, i));
3030 result = Ffuncall (2, args);
3031 if (vals) vals[gcpro1.nvars++] = result;
3035 abort (); /* unreachable, since Flength (sequence) did not get an error */
3041 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3042 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3043 In between each pair of results, insert SEPARATOR. Thus, using " " as
3044 SEPARATOR results in spaces between the values returned by FUNCTION.
3045 SEQUENCE may be a list, a vector, a bit vector, or a string.
3047 (function, sequence, separator))
3049 size_t len = XINT (Flength (sequence));
3052 int nargs = len + len - 1;
3054 if (len == 0) return build_string ("");
3056 args = alloca_array (Lisp_Object, nargs);
3058 mapcar1 (len, args, function, sequence);
3060 for (i = len - 1; i >= 0; i--)
3061 args[i + i] = args[i];
3063 for (i = 1; i < nargs; i += 2)
3064 args[i] = separator;
3066 return Fconcat (nargs, args);
3069 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3070 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3071 The result is a list of the same length as SEQUENCE.
3072 SEQUENCE may be a list, a vector, a bit vector, or a string.
3074 (function, sequence))
3076 size_t len = XINT (Flength (sequence));
3077 Lisp_Object *args = alloca_array (Lisp_Object, len);
3079 mapcar1 (len, args, function, sequence);
3081 return Flist (len, args);
3084 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3085 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3086 The result is a vector of the same length as SEQUENCE.
3087 SEQUENCE may be a list, a vector, a bit vector, or a string.
3089 (function, sequence))
3091 size_t len = XINT (Flength (sequence));
3092 Lisp_Object result = make_vector (len, Qnil);
3093 struct gcpro gcpro1;
3096 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3102 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3103 Apply FUNCTION to each element of SEQUENCE.
3104 SEQUENCE may be a list, a vector, a bit vector, or a string.
3105 This function is like `mapcar' but does not accumulate the results,
3106 which is more efficient if you do not use the results.
3108 The difference between this and `mapc' is that `mapc' supports all
3109 the spiffy Common Lisp arguments. You should normally use `mapc'.
3111 (function, sequence))
3113 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3121 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3122 Destructively replace the list OLD with NEW.
3123 This is like (copy-sequence NEW) except that it reuses the
3124 conses in OLD as much as possible. If OLD and NEW are the same
3125 length, no consing will take place.
3129 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
3131 EXTERNAL_LIST_LOOP (tail, new)
3133 if (!NILP (oldtail))
3135 CHECK_CONS (oldtail);
3136 XCAR (oldtail) = XCAR (tail);
3138 else if (!NILP (prevoldtail))
3140 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
3141 prevoldtail = XCDR (prevoldtail);
3144 old = oldtail = Fcons (XCAR (tail), Qnil);
3146 if (!NILP (oldtail))
3148 prevoldtail = oldtail;
3149 oldtail = XCDR (oldtail);
3153 if (!NILP (prevoldtail))
3154 XCDR (prevoldtail) = Qnil;
3162 /* #### this function doesn't belong in this file! */
3164 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3165 Return list of 1 minute, 5 minute and 15 minute load averages.
3166 Each of the three load averages is multiplied by 100,
3167 then converted to integer.
3169 When USE-FLOATS is non-nil, floats will be used instead of integers.
3170 These floats are not multiplied by 100.
3172 If the 5-minute or 15-minute load averages are not available, return a
3173 shortened list, containing only those averages which are available.
3175 On some systems, this won't work due to permissions on /dev/kmem,
3176 in which case you can't use this.
3181 int loads = getloadavg (load_ave, countof (load_ave));
3182 Lisp_Object ret = Qnil;
3185 error ("load-average not implemented for this operating system");
3187 signal_simple_error ("Could not get load-average",
3188 lisp_strerror (errno));
3192 Lisp_Object load = (NILP (use_floats) ?
3193 make_int ((int) (100.0 * load_ave[loads]))
3194 : make_float (load_ave[loads]));
3195 ret = Fcons (load, ret);
3201 Lisp_Object Vfeatures;
3203 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3204 Return non-nil if feature FEXP is present in this Emacs.
3205 Use this to conditionalize execution of lisp code based on the
3206 presence or absence of emacs or environment extensions.
3207 FEXP can be a symbol, a number, or a list.
3208 If it is a symbol, that symbol is looked up in the `features' variable,
3209 and non-nil will be returned if found.
3210 If it is a number, the function will return non-nil if this Emacs
3211 has an equal or greater version number than FEXP.
3212 If it is a list whose car is the symbol `and', it will return
3213 non-nil if all the features in its cdr are non-nil.
3214 If it is a list whose car is the symbol `or', it will return non-nil
3215 if any of the features in its cdr are non-nil.
3216 If it is a list whose car is the symbol `not', it will return
3217 non-nil if the feature is not present.
3222 => ; Non-nil on XEmacs.
3224 (featurep '(and xemacs gnus))
3225 => ; Non-nil on XEmacs with Gnus loaded.
3227 (featurep '(or tty-frames (and emacs 19.30)))
3228 => ; Non-nil if this Emacs supports TTY frames.
3230 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3231 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3233 (featurep '(and xemacs 21.02))
3234 => ; Non-nil on XEmacs 21.2 and later.
3236 NOTE: The advanced arguments of this function (anything other than a
3237 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3238 for supporting multiple Emacs variants, lobby Richard Stallman at
3239 <bug-gnu-emacs@gnu.org>.
3243 #ifndef FEATUREP_SYNTAX
3244 CHECK_SYMBOL (fexp);
3245 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3246 #else /* FEATUREP_SYNTAX */
3247 static double featurep_emacs_version;
3249 /* Brute force translation from Erik Naggum's lisp function. */
3252 /* Original definition */
3253 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3255 else if (INTP (fexp) || FLOATP (fexp))
3257 double d = extract_float (fexp);
3259 if (featurep_emacs_version == 0.0)
3261 featurep_emacs_version = XINT (Vemacs_major_version) +
3262 (XINT (Vemacs_minor_version) / 100.0);
3264 return featurep_emacs_version >= d ? Qt : Qnil;
3266 else if (CONSP (fexp))
3268 Lisp_Object tem = XCAR (fexp);
3274 negate = Fcar (tem);
3276 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3278 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3280 else if (EQ (tem, Qand))
3283 /* Use Fcar/Fcdr for error-checking. */
3284 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3288 return NILP (tem) ? Qt : Qnil;
3290 else if (EQ (tem, Qor))
3293 /* Use Fcar/Fcdr for error-checking. */
3294 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3298 return NILP (tem) ? Qnil : Qt;
3302 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3307 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3310 #endif /* FEATUREP_SYNTAX */
3312 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3313 Announce that FEATURE is a feature of the current Emacs.
3314 This function updates the value of the variable `features'.
3319 CHECK_SYMBOL (feature);
3320 if (!NILP (Vautoload_queue))
3321 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3322 tem = Fmemq (feature, Vfeatures);
3324 Vfeatures = Fcons (feature, Vfeatures);
3325 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3329 DEFUN ("require", Frequire, 1, 2, 0, /*
3330 If feature FEATURE is not loaded, load it from FILENAME.
3331 If FEATURE is not a member of the list `features', then the feature
3332 is not loaded; so load the file FILENAME.
3333 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3335 (feature, file_name))
3338 CHECK_SYMBOL (feature);
3339 tem = Fmemq (feature, Vfeatures);
3340 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3345 int speccount = specpdl_depth ();
3347 /* Value saved here is to be restored into Vautoload_queue */
3348 record_unwind_protect (un_autoload, Vautoload_queue);
3349 Vautoload_queue = Qt;
3351 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3354 tem = Fmemq (feature, Vfeatures);
3356 error ("Required feature %s was not provided",
3357 string_data (XSYMBOL (feature)->name));
3359 /* Once loading finishes, don't undo it. */
3360 Vautoload_queue = Qt;
3361 return unbind_to (speccount, feature);
3365 /* base64 encode/decode functions.
3367 Originally based on code from GNU recode. Ported to FSF Emacs by
3368 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3369 subsequently heavily hacked by Hrvoje Niksic. */
3371 #define MIME_LINE_LENGTH 72
3373 #define IS_ASCII(Character) \
3375 #define IS_BASE64(Character) \
3376 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3378 /* Table of characters coding the 64 values. */
3379 static char base64_value_to_char[64] =
3381 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3382 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3383 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3384 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3385 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3386 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3387 '8', '9', '+', '/' /* 60-63 */
3390 /* Table of base64 values for first 128 characters. */
3391 static short base64_char_to_value[128] =
3393 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3394 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3395 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3396 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3397 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3398 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3399 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3400 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3401 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3402 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3403 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3404 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3405 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3408 /* The following diagram shows the logical steps by which three octets
3409 get transformed into four base64 characters.
3411 .--------. .--------. .--------.
3412 |aaaaaabb| |bbbbcccc| |ccdddddd|
3413 `--------' `--------' `--------'
3415 .--------+--------+--------+--------.
3416 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3417 `--------+--------+--------+--------'
3419 .--------+--------+--------+--------.
3420 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3421 `--------+--------+--------+--------'
3423 The octets are divided into 6 bit chunks, which are then encoded into
3424 base64 characters. */
3426 #define ADVANCE_INPUT(c, stream) \
3427 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3429 (signal_simple_error ("Non-ascii character in base64 input", \
3430 make_char (ec)), 0) \
3431 : (c = (Bufbyte)ec), 1))
3434 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3436 EMACS_INT counter = 0;
3444 if (!ADVANCE_INPUT (c, istream))
3447 /* Wrap line every 76 characters. */
3450 if (counter < MIME_LINE_LENGTH / 4)
3459 /* Process first byte of a triplet. */
3460 *e++ = base64_value_to_char[0x3f & c >> 2];
3461 value = (0x03 & c) << 4;
3463 /* Process second byte of a triplet. */
3464 if (!ADVANCE_INPUT (c, istream))
3466 *e++ = base64_value_to_char[value];
3472 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3473 value = (0x0f & c) << 2;
3475 /* Process third byte of a triplet. */
3476 if (!ADVANCE_INPUT (c, istream))
3478 *e++ = base64_value_to_char[value];
3483 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3484 *e++ = base64_value_to_char[0x3f & c];
3489 #undef ADVANCE_INPUT
3491 /* Get next character from the stream, except that non-base64
3492 characters are ignored. This is in accordance with rfc2045. EC
3493 should be an Emchar, so that it can hold -1 as the value for EOF. */
3494 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3495 ec = Lstream_get_emchar (stream); \
3497 /* IS_BASE64 may not be called with negative arguments so check for \
3499 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3503 #define STORE_BYTE(pos, val, ccnt) do { \
3504 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3509 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3513 EMACS_INT streampos = 0;
3518 unsigned long value;
3520 /* Process first byte of a quadruplet. */
3521 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3525 signal_simple_error ("Illegal `=' character while decoding base64",
3526 make_int (streampos));
3527 value = base64_char_to_value[ec] << 18;
3529 /* Process second byte of a quadruplet. */
3530 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3532 error ("Premature EOF while decoding base64");
3534 signal_simple_error ("Illegal `=' character while decoding base64",
3535 make_int (streampos));
3536 value |= base64_char_to_value[ec] << 12;
3537 STORE_BYTE (e, value >> 16, ccnt);
3539 /* Process third byte of a quadruplet. */
3540 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3542 error ("Premature EOF while decoding base64");
3546 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3548 error ("Premature EOF while decoding base64");
3550 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3551 make_int (streampos));
3555 value |= base64_char_to_value[ec] << 6;
3556 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3558 /* Process fourth byte of a quadruplet. */
3559 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3561 error ("Premature EOF while decoding base64");
3565 value |= base64_char_to_value[ec];
3566 STORE_BYTE (e, 0xff & value, ccnt);
3572 #undef ADVANCE_INPUT
3573 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3577 free_malloced_ptr (Lisp_Object unwind_obj)
3579 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3581 free_opaque_ptr (unwind_obj);
3585 /* Don't use alloca for regions larger than this, lest we overflow
3587 #define MAX_ALLOCA 65536
3589 /* We need to setup proper unwinding, because there is a number of
3590 ways these functions can blow up, and we don't want to have memory
3591 leaks in those cases. */
3592 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3593 size_t XOA_len = (len); \
3594 if (XOA_len > MAX_ALLOCA) \
3596 ptr = xnew_array (type, XOA_len); \
3597 record_unwind_protect (free_malloced_ptr, \
3598 make_opaque_ptr ((void *)ptr)); \
3601 ptr = alloca_array (type, XOA_len); \
3604 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3605 if ((len) > MAX_ALLOCA) \
3606 unbind_to (speccount, Qnil); \
3609 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3610 Base64-encode the region between BEG and END.
3611 Return the length of the encoded text.
3612 Optional third argument NO-LINE-BREAK means do not break long lines
3615 (beg, end, no_line_break))
3618 Bytind encoded_length;
3619 Charcount allength, length;
3620 struct buffer *buf = current_buffer;
3621 Bufpos begv, zv, old_pt = BUF_PT (buf);
3623 int speccount = specpdl_depth();
3625 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3626 barf_if_buffer_read_only (buf, begv, zv);
3628 /* We need to allocate enough room for encoding the text.
3629 We need 33 1/3% more space, plus a newline every 76
3630 characters, and then we round up. */
3632 allength = length + length/3 + 1;
3633 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3635 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3636 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3637 base64 characters will be single-byte. */
3638 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3639 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3640 NILP (no_line_break));
3641 if (encoded_length > allength)
3643 Lstream_delete (XLSTREAM (input));
3645 /* Now we have encoded the region, so we insert the new contents
3646 and delete the old. (Insert first in order to preserve markers.) */
3647 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3648 XMALLOC_UNBIND (encoded, allength, speccount);
3649 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3651 /* Simulate FSF Emacs implementation of this function: if point was
3652 in the region, place it at the beginning. */
3653 if (old_pt >= begv && old_pt < zv)
3654 BUF_SET_PT (buf, begv);
3656 /* We return the length of the encoded text. */
3657 return make_int (encoded_length);
3660 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3661 Base64 encode STRING and return the result.
3663 (string, no_line_break))
3665 Charcount allength, length;
3666 Bytind encoded_length;
3668 Lisp_Object input, result;
3669 int speccount = specpdl_depth();
3671 CHECK_STRING (string);
3673 length = XSTRING_CHAR_LENGTH (string);
3674 allength = length + length/3 + 1;
3675 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3677 input = make_lisp_string_input_stream (string, 0, -1);
3678 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3679 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3680 NILP (no_line_break));
3681 if (encoded_length > allength)
3683 Lstream_delete (XLSTREAM (input));
3684 result = make_string (encoded, encoded_length);
3685 XMALLOC_UNBIND (encoded, allength, speccount);
3689 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3690 Base64-decode the region between BEG and END.
3691 Return the length of the decoded text.
3692 If the region can't be decoded, return nil and don't modify the buffer.
3693 Characters out of the base64 alphabet are ignored.
3697 struct buffer *buf = current_buffer;
3698 Bufpos begv, zv, old_pt = BUF_PT (buf);
3700 Bytind decoded_length;
3701 Charcount length, cc_decoded_length;
3703 int speccount = specpdl_depth();
3705 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3706 barf_if_buffer_read_only (buf, begv, zv);
3710 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3711 /* We need to allocate enough room for decoding the text. */
3712 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3713 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3714 if (decoded_length > length * MAX_EMCHAR_LEN)
3716 Lstream_delete (XLSTREAM (input));
3718 /* Now we have decoded the region, so we insert the new contents
3719 and delete the old. (Insert first in order to preserve markers.) */
3720 BUF_SET_PT (buf, begv);
3721 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3722 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3723 buffer_delete_range (buf, begv + cc_decoded_length,
3724 zv + cc_decoded_length, 0);
3726 /* Simulate FSF Emacs implementation of this function: if point was
3727 in the region, place it at the beginning. */
3728 if (old_pt >= begv && old_pt < zv)
3729 BUF_SET_PT (buf, begv);
3731 return make_int (cc_decoded_length);
3734 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3735 Base64-decode STRING and return the result.
3736 Characters out of the base64 alphabet are ignored.
3741 Bytind decoded_length;
3742 Charcount length, cc_decoded_length;
3743 Lisp_Object input, result;
3744 int speccount = specpdl_depth();
3746 CHECK_STRING (string);
3748 length = XSTRING_CHAR_LENGTH (string);
3749 /* We need to allocate enough room for decoding the text. */
3750 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3752 input = make_lisp_string_input_stream (string, 0, -1);
3753 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3754 &cc_decoded_length);
3755 if (decoded_length > length * MAX_EMCHAR_LEN)
3757 Lstream_delete (XLSTREAM (input));
3759 result = make_string (decoded, decoded_length);
3760 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3764 Lisp_Object Qyes_or_no_p;
3769 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3771 defsymbol (&Qstring_lessp, "string-lessp");
3772 defsymbol (&Qidentity, "identity");
3773 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3775 DEFSUBR (Fidentity);
3778 DEFSUBR (Fsafe_length);
3779 DEFSUBR (Fstring_equal);
3780 DEFSUBR (Fstring_lessp);
3781 DEFSUBR (Fstring_modified_tick);
3785 DEFSUBR (Fbvconcat);
3786 DEFSUBR (Fcopy_list);
3787 DEFSUBR (Fcopy_sequence);
3788 DEFSUBR (Fcopy_alist);
3789 DEFSUBR (Fcopy_tree);
3790 DEFSUBR (Fsubstring);
3797 DEFSUBR (Fnbutlast);
3799 DEFSUBR (Fold_member);
3801 DEFSUBR (Fold_memq);
3803 DEFSUBR (Fold_assoc);
3805 DEFSUBR (Fold_assq);
3807 DEFSUBR (Fold_rassoc);
3809 DEFSUBR (Fold_rassq);
3811 DEFSUBR (Fold_delete);
3813 DEFSUBR (Fold_delq);
3814 DEFSUBR (Fremassoc);
3816 DEFSUBR (Fremrassoc);
3817 DEFSUBR (Fremrassq);
3818 DEFSUBR (Fnreverse);
3821 DEFSUBR (Fplists_eq);
3822 DEFSUBR (Fplists_equal);
3823 DEFSUBR (Flax_plists_eq);
3824 DEFSUBR (Flax_plists_equal);
3825 DEFSUBR (Fplist_get);
3826 DEFSUBR (Fplist_put);
3827 DEFSUBR (Fplist_remprop);
3828 DEFSUBR (Fplist_member);
3829 DEFSUBR (Fcheck_valid_plist);
3830 DEFSUBR (Fvalid_plist_p);
3831 DEFSUBR (Fcanonicalize_plist);
3832 DEFSUBR (Flax_plist_get);
3833 DEFSUBR (Flax_plist_put);
3834 DEFSUBR (Flax_plist_remprop);
3835 DEFSUBR (Flax_plist_member);
3836 DEFSUBR (Fcanonicalize_lax_plist);
3837 DEFSUBR (Fdestructive_alist_to_plist);
3841 DEFSUBR (Fobject_plist);
3843 DEFSUBR (Fold_equal);
3844 DEFSUBR (Ffillarray);
3847 DEFSUBR (Fmapvector);
3848 DEFSUBR (Fmapc_internal);
3849 DEFSUBR (Fmapconcat);
3850 DEFSUBR (Freplace_list);
3851 DEFSUBR (Fload_average);
3852 DEFSUBR (Ffeaturep);
3855 DEFSUBR (Fbase64_encode_region);
3856 DEFSUBR (Fbase64_encode_string);
3857 DEFSUBR (Fbase64_decode_region);
3858 DEFSUBR (Fbase64_decode_string);
3862 init_provide_once (void)
3864 DEFVAR_LISP ("features", &Vfeatures /*
3865 A list of symbols which are the features of the executing emacs.
3866 Used by `featurep' and `require', and altered by `provide'.
3870 Fprovide (intern ("base64"));