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;
720 tail = val, toindex = -1; /* -1 in toindex is flag we are
727 for (argnum = 0; argnum < nargs; argnum++)
729 Charcount thisleni = 0;
730 Charcount thisindex = 0;
731 Lisp_Object seq = args[argnum];
732 Bufbyte *string_source_ptr = 0;
733 Bufbyte *string_prev_result_ptr = string_result_ptr;
737 #ifdef LOSING_BYTECODE
738 thisleni = length_with_bytecode_hack (seq);
740 thisleni = XINT (Flength (seq));
744 string_source_ptr = XSTRING_DATA (seq);
750 /* We've come to the end of this arg, so exit. */
754 /* Fetch next element of `seq' arg into `elt' */
762 if (thisindex >= thisleni)
767 elt = make_char (charptr_emchar (string_source_ptr));
768 INC_CHARPTR (string_source_ptr);
770 else if (VECTORP (seq))
771 elt = XVECTOR_DATA (seq)[thisindex];
772 else if (BIT_VECTORP (seq))
773 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
776 elt = Felt (seq, make_int (thisindex));
780 /* Store into result */
783 /* toindex negative means we are making a list */
788 else if (VECTORP (val))
789 XVECTOR_DATA (val)[toindex++] = elt;
790 else if (BIT_VECTORP (val))
793 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
797 CHECK_CHAR_COERCE_INT (elt);
798 string_result_ptr += set_charptr_emchar (string_result_ptr,
804 args_mse[argnum].entry_offset =
805 string_prev_result_ptr - string_result;
806 args_mse[argnum].entry_length =
807 string_result_ptr - string_prev_result_ptr;
811 /* Now we finally make the string. */
812 if (target_type == c_string)
814 val = make_string (string_result, string_result_ptr - string_result);
815 for (argnum = 0; argnum < nargs; argnum++)
817 if (STRINGP (args_mse[argnum].string))
818 copy_string_extents (val, args_mse[argnum].string,
819 args_mse[argnum].entry_offset, 0,
820 args_mse[argnum].entry_length);
825 XCDR (prev) = last_tail;
827 RETURN_UNGCPRO (val);
830 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
831 Return a copy of ALIST.
832 This is an alist which represents the same mapping from objects to objects,
833 but does not share the alist structure with ALIST.
834 The objects mapped (cars and cdrs of elements of the alist)
836 Elements of ALIST that are not conses are also shared.
846 alist = concat (1, &alist, c_cons, 0);
847 for (tail = alist; CONSP (tail); tail = XCDR (tail))
849 Lisp_Object car = XCAR (tail);
852 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
857 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
858 Return a copy of a list and substructures.
859 The argument is copied, and any lists contained within it are copied
860 recursively. Circularities and shared substructures are not preserved.
861 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
869 rest = arg = Fcopy_sequence (arg);
872 Lisp_Object elt = XCAR (rest);
874 if (CONSP (elt) || VECTORP (elt))
875 XCAR (rest) = Fcopy_tree (elt, vecp);
876 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
877 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
881 else if (VECTORP (arg) && ! NILP (vecp))
883 int i = XVECTOR_LENGTH (arg);
885 arg = Fcopy_sequence (arg);
886 for (j = 0; j < i; j++)
888 Lisp_Object elt = XVECTOR_DATA (arg) [j];
890 if (CONSP (elt) || VECTORP (elt))
891 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
897 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
898 Return a substring of STRING, starting at index FROM and ending before TO.
899 TO may be nil or omitted; then the substring runs to the end of STRING.
900 If FROM or TO is negative, it counts from the end.
901 Relevant parts of the string-extent-data are copied in the new string.
905 Charcount ccfr, ccto;
909 CHECK_STRING (string);
911 get_string_range_char (string, from, to, &ccfr, &ccto,
912 GB_HISTORICAL_STRING_BEHAVIOR);
913 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
914 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
915 val = make_string (XSTRING_DATA (string) + bfr, blen);
916 /* Copy any applicable extent information into the new string: */
917 copy_string_extents (val, string, 0, bfr, blen);
921 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
922 Return the subsequence of SEQUENCE starting at START and ending before END.
923 END may be omitted; then the subsequence runs to the end of SEQUENCE.
924 If START or END is negative, it counts from the end.
925 The returned subsequence is always of the same type as SEQUENCE.
926 If SEQUENCE is a string, relevant parts of the string-extent-data
927 are copied to the new string.
929 (sequence, start, end))
933 if (STRINGP (sequence))
934 return Fsubstring (sequence, start, end);
936 len = XINT (Flength (sequence));
953 if (!(0 <= s && s <= e && e <= len))
954 args_out_of_range_3 (sequence, make_int (s), make_int (e));
956 if (VECTORP (sequence))
958 Lisp_Object result = make_vector (e - s, Qnil);
960 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
961 Lisp_Object *out_elts = XVECTOR_DATA (result);
963 for (i = s; i < e; i++)
964 out_elts[i - s] = in_elts[i];
967 else if (LISTP (sequence))
969 Lisp_Object result = Qnil;
972 sequence = Fnthcdr (make_int (s), sequence);
974 for (i = s; i < e; i++)
976 result = Fcons (Fcar (sequence), result);
977 sequence = Fcdr (sequence);
980 return Fnreverse (result);
982 else if (BIT_VECTORP (sequence))
984 Lisp_Object result = make_bit_vector (e - s, Qzero);
987 for (i = s; i < e; i++)
988 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
989 bit_vector_bit (XBIT_VECTOR (sequence), i));
994 abort (); /* unreachable, since Flength (sequence) did not get
1001 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1002 Take cdr N times on LIST, and return the result.
1007 REGISTER Lisp_Object tail = list;
1009 for (i = XINT (n); i; i--)
1013 else if (NILP (tail))
1017 tail = wrong_type_argument (Qlistp, tail);
1024 DEFUN ("nth", Fnth, 2, 2, 0, /*
1025 Return the Nth element of LIST.
1026 N counts from zero. If LIST is not that long, nil is returned.
1030 return Fcar (Fnthcdr (n, list));
1033 DEFUN ("elt", Felt, 2, 2, 0, /*
1034 Return element of SEQUENCE at index N.
1039 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1040 if (LISTP (sequence))
1042 Lisp_Object tem = Fnthcdr (n, sequence);
1043 /* #### Utterly, completely, fucking disgusting.
1044 * #### The whole point of "elt" is that it operates on
1045 * #### sequences, and does error- (bounds-) checking.
1051 /* This is The Way It Has Always Been. */
1054 /* This is The Way Mly and Cltl2 say It Should Be. */
1055 args_out_of_range (sequence, n);
1058 else if (STRINGP (sequence) ||
1059 VECTORP (sequence) ||
1060 BIT_VECTORP (sequence))
1061 return Faref (sequence, n);
1062 #ifdef LOSING_BYTECODE
1063 else if (COMPILED_FUNCTIONP (sequence))
1065 EMACS_INT idx = XINT (n);
1069 args_out_of_range (sequence, n);
1071 /* Utter perversity */
1073 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1076 case COMPILED_ARGLIST:
1077 return compiled_function_arglist (f);
1078 case COMPILED_INSTRUCTIONS:
1079 return compiled_function_instructions (f);
1080 case COMPILED_CONSTANTS:
1081 return compiled_function_constants (f);
1082 case COMPILED_STACK_DEPTH:
1083 return compiled_function_stack_depth (f);
1084 case COMPILED_DOC_STRING:
1085 return compiled_function_documentation (f);
1086 case COMPILED_DOMAIN:
1087 return compiled_function_domain (f);
1088 case COMPILED_INTERACTIVE:
1089 if (f->flags.interactivep)
1090 return compiled_function_interactive (f);
1091 /* if we return nil, can't tell interactive with no args
1092 from noninteractive. */
1099 #endif /* LOSING_BYTECODE */
1102 check_losing_bytecode ("elt", sequence);
1103 sequence = wrong_type_argument (Qsequencep, sequence);
1108 DEFUN ("last", Flast, 1, 2, 0, /*
1109 Return the tail of list LIST, of length N (default 1).
1110 LIST may be a dotted list, but not a circular list.
1111 Optional argument N must be a non-negative integer.
1112 If N is zero, then the atom that terminates the list is returned.
1113 If N is greater than the length of LIST, then LIST itself is returned.
1117 EMACS_INT int_n, count;
1118 Lisp_Object retval, tortoise, hare;
1130 for (retval = tortoise = hare = list, count = 0;
1133 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1136 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1139 tortoise = XCDR (tortoise);
1140 if (EQ (hare, tortoise))
1141 signal_circular_list_error (list);
1147 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1148 Modify LIST to remove the last N (default 1) elements.
1149 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1166 Lisp_Object last_cons = list;
1168 EXTERNAL_LIST_LOOP_1 (list)
1171 last_cons = XCDR (last_cons);
1177 XCDR (last_cons) = Qnil;
1182 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1183 Return a copy of LIST with the last N (default 1) elements removed.
1184 If LIST has N or fewer elements, nil is returned.
1201 Lisp_Object retval = Qnil;
1202 Lisp_Object tail = list;
1204 EXTERNAL_LIST_LOOP_1 (list)
1208 retval = Fcons (XCAR (tail), retval);
1213 return Fnreverse (retval);
1217 DEFUN ("member", Fmember, 2, 2, 0, /*
1218 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1219 The value is actually the tail of LIST whose car is ELT.
1223 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1225 if (internal_equal (elt, list_elt, 0))
1231 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1232 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1233 The value is actually the tail of LIST whose car is ELT.
1234 This function is provided only for byte-code compatibility with v19.
1239 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1241 if (internal_old_equal (elt, list_elt, 0))
1247 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1248 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1249 The value is actually the tail of LIST whose car is ELT.
1253 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1255 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1261 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1262 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1263 The value is actually the tail of LIST whose car is ELT.
1264 This function is provided only for byte-code compatibility with v19.
1269 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1271 if (HACKEQ_UNSAFE (elt, list_elt))
1278 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1280 LIST_LOOP_3 (list_elt, list, tail)
1282 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1288 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1289 Return non-nil if KEY is `equal' to the car of an element of LIST.
1290 The value is actually the element of LIST whose car equals KEY.
1294 /* This function can GC. */
1295 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1297 if (internal_equal (key, elt_car, 0))
1303 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1304 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1305 The value is actually the element of LIST whose car equals KEY.
1309 /* This function can GC. */
1310 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1312 if (internal_old_equal (key, elt_car, 0))
1319 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1321 int speccount = specpdl_depth ();
1322 specbind (Qinhibit_quit, Qt);
1323 return unbind_to (speccount, Fassoc (key, list));
1326 DEFUN ("assq", Fassq, 2, 2, 0, /*
1327 Return non-nil if KEY is `eq' to the car of an element of LIST.
1328 The value is actually the element of LIST whose car is KEY.
1329 Elements of LIST that are not conses are ignored.
1333 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1335 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1341 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1342 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1343 The value is actually the element of LIST whose car is KEY.
1344 Elements of LIST that are not conses are ignored.
1345 This function is provided only for byte-code compatibility with v19.
1350 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1352 if (HACKEQ_UNSAFE (key, elt_car))
1358 /* Like Fassq but never report an error and do not allow quits.
1359 Use only on lists known never to be circular. */
1362 assq_no_quit (Lisp_Object key, Lisp_Object list)
1364 /* This cannot GC. */
1365 LIST_LOOP_2 (elt, list)
1367 Lisp_Object elt_car = XCAR (elt);
1368 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1374 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1375 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1376 The value is actually the element of LIST whose cdr equals KEY.
1380 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1382 if (internal_equal (key, elt_cdr, 0))
1388 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1389 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1390 The value is actually the element of LIST whose cdr equals KEY.
1394 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1396 if (internal_old_equal (key, elt_cdr, 0))
1402 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1403 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1404 The value is actually the element of LIST whose cdr is KEY.
1408 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1410 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1416 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1417 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1418 The value is actually the element of LIST whose cdr is KEY.
1422 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1424 if (HACKEQ_UNSAFE (key, elt_cdr))
1430 /* Like Frassq, but caller must ensure that LIST is properly
1431 nil-terminated and ebola-free. */
1433 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1435 LIST_LOOP_2 (elt, list)
1437 Lisp_Object elt_cdr = XCDR (elt);
1438 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1445 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1446 Delete by side effect any occurrences of ELT as a member of LIST.
1447 The modified LIST is returned. Comparison is done with `equal'.
1448 If the first member of LIST is ELT, there is no way to remove it by side
1449 effect; therefore, write `(setq foo (delete element foo))' to be sure
1450 of changing the value of `foo'.
1455 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1456 (internal_equal (elt, list_elt, 0)));
1460 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1461 Delete by side effect any occurrences of ELT as a member of LIST.
1462 The modified LIST is returned. Comparison is done with `old-equal'.
1463 If the first member of LIST is ELT, there is no way to remove it by side
1464 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1465 of changing the value of `foo'.
1469 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1470 (internal_old_equal (elt, list_elt, 0)));
1474 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1475 Delete by side effect any occurrences of ELT as a member of LIST.
1476 The modified LIST is returned. Comparison is done with `eq'.
1477 If the first member of LIST is ELT, there is no way to remove it by side
1478 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1479 changing the value of `foo'.
1483 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1484 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1488 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1489 Delete by side effect any occurrences of ELT as a member of LIST.
1490 The modified LIST is returned. Comparison is done with `old-eq'.
1491 If the first member of LIST is ELT, there is no way to remove it by side
1492 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1493 changing the value of `foo'.
1497 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1498 (HACKEQ_UNSAFE (elt, list_elt)));
1502 /* Like Fdelq, but caller must ensure that LIST is properly
1503 nil-terminated and ebola-free. */
1506 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1508 LIST_LOOP_DELETE_IF (list_elt, list,
1509 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1513 /* Be VERY careful with this. This is like delq_no_quit() but
1514 also calls free_cons() on the removed conses. You must be SURE
1515 that no pointers to the freed conses remain around (e.g.
1516 someone else is pointing to part of the list). This function
1517 is useful on internal lists that are used frequently and where
1518 the actual list doesn't escape beyond known code bounds. */
1521 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1523 REGISTER Lisp_Object tail = list;
1524 REGISTER Lisp_Object prev = Qnil;
1526 while (!NILP (tail))
1528 REGISTER Lisp_Object tem = XCAR (tail);
1531 Lisp_Object cons_to_free = tail;
1535 XCDR (prev) = XCDR (tail);
1537 free_cons (XCONS (cons_to_free));
1548 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1549 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1550 The modified LIST is returned. If the first member of LIST has a car
1551 that is `equal' to KEY, there is no way to remove it by side effect;
1552 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1557 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1559 internal_equal (key, XCAR (elt), 0)));
1564 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1566 int speccount = specpdl_depth ();
1567 specbind (Qinhibit_quit, Qt);
1568 return unbind_to (speccount, Fremassoc (key, list));
1571 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1572 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1573 The modified LIST is returned. If the first member of LIST has a car
1574 that is `eq' to KEY, there is no way to remove it by side effect;
1575 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1580 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1582 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1586 /* no quit, no errors; be careful */
1589 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1591 LIST_LOOP_DELETE_IF (elt, list,
1593 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1597 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1598 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1599 The modified LIST is returned. If the first member of LIST has a car
1600 that is `equal' to VALUE, there is no way to remove it by side effect;
1601 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1606 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1608 internal_equal (value, XCDR (elt), 0)));
1612 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1613 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1614 The modified LIST is returned. If the first member of LIST has a car
1615 that is `eq' to VALUE, there is no way to remove it by side effect;
1616 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1621 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1623 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1627 /* Like Fremrassq, fast and unsafe; be careful */
1629 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1631 LIST_LOOP_DELETE_IF (elt, list,
1633 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1637 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1638 Reverse LIST by destructively modifying cdr pointers.
1639 Return the beginning of the reversed list.
1640 Also see: `reverse'.
1644 struct gcpro gcpro1, gcpro2;
1645 REGISTER Lisp_Object prev = Qnil;
1646 REGISTER Lisp_Object tail = list;
1648 /* We gcpro our args; see `nconc' */
1649 GCPRO2 (prev, tail);
1650 while (!NILP (tail))
1652 REGISTER Lisp_Object next;
1653 CONCHECK_CONS (tail);
1663 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1664 Reverse LIST, copying. Return the beginning of the reversed list.
1665 See also the function `nreverse', which is used more often.
1669 Lisp_Object reversed_list = Qnil;
1670 EXTERNAL_LIST_LOOP_2 (elt, list)
1672 reversed_list = Fcons (elt, reversed_list);
1674 return reversed_list;
1677 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1678 Lisp_Object lisp_arg,
1679 int (*pred_fn) (Lisp_Object, Lisp_Object,
1680 Lisp_Object lisp_arg));
1683 list_sort (Lisp_Object list,
1684 Lisp_Object lisp_arg,
1685 int (*pred_fn) (Lisp_Object, Lisp_Object,
1686 Lisp_Object lisp_arg))
1688 struct gcpro gcpro1, gcpro2, gcpro3;
1689 Lisp_Object back, tem;
1690 Lisp_Object front = list;
1691 Lisp_Object len = Flength (list);
1692 int length = XINT (len);
1697 XSETINT (len, (length / 2) - 1);
1698 tem = Fnthcdr (len, list);
1700 Fsetcdr (tem, Qnil);
1702 GCPRO3 (front, back, lisp_arg);
1703 front = list_sort (front, lisp_arg, pred_fn);
1704 back = list_sort (back, lisp_arg, pred_fn);
1706 return list_merge (front, back, lisp_arg, pred_fn);
1711 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1716 /* prevents the GC from happening in call2 */
1717 int speccount = specpdl_depth ();
1718 /* Emacs' GC doesn't actually relocate pointers, so this probably
1719 isn't strictly necessary */
1720 record_unwind_protect (restore_gc_inhibit,
1721 make_int (gc_currently_forbidden));
1722 gc_currently_forbidden = 1;
1723 tmp = call2 (pred, obj1, obj2);
1724 unbind_to (speccount, Qnil);
1732 DEFUN ("sort", Fsort, 2, 2, 0, /*
1733 Sort LIST, stably, comparing elements using PREDICATE.
1734 Returns the sorted list. LIST is modified by side effects.
1735 PREDICATE is called with two elements of LIST, and should return T
1736 if the first element is "less" than the second.
1740 return list_sort (list, pred, merge_pred_function);
1744 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1747 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1752 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1753 Lisp_Object lisp_arg,
1754 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1760 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1767 /* It is sufficient to protect org_l1 and org_l2.
1768 When l1 and l2 are updated, we copy the new values
1769 back into the org_ vars. */
1771 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1792 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1807 Fsetcdr (tail, tem);
1813 /************************************************************************/
1814 /* property-list functions */
1815 /************************************************************************/
1817 /* For properties of text, we need to do order-insensitive comparison of
1818 plists. That is, we need to compare two plists such that they are the
1819 same if they have the same set of keys, and equivalent values.
1820 So (a 1 b 2) would be equal to (b 2 a 1).
1822 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1823 LAXP means use `equal' for comparisons.
1826 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1827 int laxp, int depth)
1829 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1830 int la, lb, m, i, fill;
1831 Lisp_Object *keys, *vals;
1835 if (NILP (a) && NILP (b))
1838 Fcheck_valid_plist (a);
1839 Fcheck_valid_plist (b);
1841 la = XINT (Flength (a));
1842 lb = XINT (Flength (b));
1843 m = (la > lb ? la : lb);
1845 keys = alloca_array (Lisp_Object, m);
1846 vals = alloca_array (Lisp_Object, m);
1847 flags = alloca_array (char, m);
1849 /* First extract the pairs from A. */
1850 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1852 Lisp_Object k = XCAR (rest);
1853 Lisp_Object v = XCAR (XCDR (rest));
1854 /* Maybe be Ebolified. */
1855 if (nil_means_not_present && NILP (v)) continue;
1861 /* Now iterate over B, and stop if we find something that's not in A,
1862 or that doesn't match. As we match, mark them. */
1863 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1865 Lisp_Object k = XCAR (rest);
1866 Lisp_Object v = XCAR (XCDR (rest));
1867 /* Maybe be Ebolified. */
1868 if (nil_means_not_present && NILP (v)) continue;
1869 for (i = 0; i < fill; i++)
1871 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1874 /* We narrowly escaped being Ebolified here. */
1875 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1876 : !internal_equal (v, vals [i], depth))
1877 /* a property in B has a different value than in A */
1884 /* there are some properties in B that are not in A */
1887 /* Now check to see that all the properties in A were also in B */
1888 for (i = 0; i < fill; i++)
1899 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1900 Return non-nil if property lists A and B are `eq'.
1901 A property list is an alternating list of keywords and values.
1902 This function does order-insensitive comparisons of the property lists:
1903 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1904 Comparison between values is done using `eq'. See also `plists-equal'.
1905 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1906 a nil value is ignored. This feature is a virus that has infected
1907 old Lisp implementations, but should not be used except for backward
1910 (a, b, nil_means_not_present))
1912 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1916 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1917 Return non-nil if property lists A and B are `equal'.
1918 A property list is an alternating list of keywords and values. This
1919 function does order-insensitive comparisons of the property lists: For
1920 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1921 Comparison between values is done using `equal'. See also `plists-eq'.
1922 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1923 a nil value is ignored. This feature is a virus that has infected
1924 old Lisp implementations, but should not be used except for backward
1927 (a, b, nil_means_not_present))
1929 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1934 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1935 Return non-nil if lax property lists A and B are `eq'.
1936 A property list is an alternating list of keywords and values.
1937 This function does order-insensitive comparisons of the property lists:
1938 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1939 Comparison between values is done using `eq'. See also `plists-equal'.
1940 A lax property list is like a regular one except that comparisons between
1941 keywords is done using `equal' instead of `eq'.
1942 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1943 a nil value is ignored. This feature is a virus that has infected
1944 old Lisp implementations, but should not be used except for backward
1947 (a, b, nil_means_not_present))
1949 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1953 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1954 Return non-nil if lax property lists A and B are `equal'.
1955 A property list is an alternating list of keywords and values. This
1956 function does order-insensitive comparisons of the property lists: For
1957 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1958 Comparison between values is done using `equal'. See also `plists-eq'.
1959 A lax property list is like a regular one except that comparisons between
1960 keywords is done using `equal' instead of `eq'.
1961 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1962 a nil value is ignored. This feature is a virus that has infected
1963 old Lisp implementations, but should not be used except for backward
1966 (a, b, nil_means_not_present))
1968 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1972 /* Return the value associated with key PROPERTY in property list PLIST.
1973 Return nil if key not found. This function is used for internal
1974 property lists that cannot be directly manipulated by the user.
1978 internal_plist_get (Lisp_Object plist, Lisp_Object property)
1982 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
1984 if (EQ (XCAR (tail), property))
1985 return XCAR (XCDR (tail));
1991 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
1992 internal_plist_get(). */
1995 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2000 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2002 if (EQ (XCAR (tail), property))
2004 XCAR (XCDR (tail)) = value;
2009 *plist = Fcons (property, Fcons (value, *plist));
2013 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2015 Lisp_Object tail, prev;
2017 for (tail = *plist, prev = Qnil;
2019 tail = XCDR (XCDR (tail)))
2021 if (EQ (XCAR (tail), property))
2024 *plist = XCDR (XCDR (tail));
2026 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2036 /* Called on a malformed property list. BADPLACE should be some
2037 place where truncating will form a good list -- i.e. we shouldn't
2038 result in a list with an odd length. */
2041 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2043 if (ERRB_EQ (errb, ERROR_ME))
2044 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2047 if (ERRB_EQ (errb, ERROR_ME_WARN))
2049 warn_when_safe_lispobj
2052 ("Malformed property list -- list has been truncated"),
2060 /* Called on a circular property list. BADPLACE should be some place
2061 where truncating will result in an even-length list, as above.
2062 If doesn't particularly matter where we truncate -- anywhere we
2063 truncate along the entire list will break the circularity, because
2064 it will create a terminus and the list currently doesn't have one.
2068 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2070 if (ERRB_EQ (errb, ERROR_ME))
2071 return Fsignal (Qcircular_property_list, list1 (*plist));
2074 if (ERRB_EQ (errb, ERROR_ME_WARN))
2076 warn_when_safe_lispobj
2079 ("Circular property list -- list has been truncated"),
2087 /* Advance the tortoise pointer by two (one iteration of a property-list
2088 loop) and the hare pointer by four and verify that no malformations
2089 or circularities exist. If so, return zero and store a value into
2090 RETVAL that should be returned by the calling function. Otherwise,
2091 return 1. See external_plist_get().
2095 advance_plist_pointers (Lisp_Object *plist,
2096 Lisp_Object **tortoise, Lisp_Object **hare,
2097 Error_behavior errb, Lisp_Object *retval)
2100 Lisp_Object *tortsave = *tortoise;
2102 /* Note that our "fixing" may be more brutal than necessary,
2103 but it's the user's own problem, not ours, if they went in and
2104 manually fucked up a plist. */
2106 for (i = 0; i < 2; i++)
2108 /* This is a standard iteration of a defensive-loop-checking
2109 loop. We just do it twice because we want to advance past
2110 both the property and its value.
2112 If the pointer indirection is confusing you, remember that
2113 one level of indirection on the hare and tortoise pointers
2114 is only due to pass-by-reference for this function. The other
2115 level is so that the plist can be fixed in place. */
2117 /* When we reach the end of a well-formed plist, **HARE is
2118 nil. In that case, we don't do anything at all except
2119 advance TORTOISE by one. Otherwise, we advance HARE
2120 by two (making sure it's OK to do so), then advance
2121 TORTOISE by one (it will always be OK to do so because
2122 the HARE is always ahead of the TORTOISE and will have
2123 already verified the path), then make sure TORTOISE and
2124 HARE don't contain the same non-nil object -- if the
2125 TORTOISE and the HARE ever meet, then obviously we're
2126 in a circularity, and if we're in a circularity, then
2127 the TORTOISE and the HARE can't cross paths without
2128 meeting, since the HARE only gains one step over the
2129 TORTOISE per iteration. */
2133 Lisp_Object *haresave = *hare;
2134 if (!CONSP (**hare))
2136 *retval = bad_bad_bunny (plist, haresave, errb);
2139 *hare = &XCDR (**hare);
2140 /* In a non-plist, we'd check here for a nil value for
2141 **HARE, which is OK (it just means the list has an
2142 odd number of elements). In a plist, it's not OK
2143 for the list to have an odd number of elements. */
2144 if (!CONSP (**hare))
2146 *retval = bad_bad_bunny (plist, haresave, errb);
2149 *hare = &XCDR (**hare);
2152 *tortoise = &XCDR (**tortoise);
2153 if (!NILP (**hare) && EQ (**tortoise, **hare))
2155 *retval = bad_bad_turtle (plist, tortsave, errb);
2163 /* Return the value of PROPERTY from PLIST, or Qunbound if
2164 property is not on the list.
2166 PLIST is a Lisp-accessible property list, meaning that it
2167 has to be checked for malformations and circularities.
2169 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2170 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2171 on finding a malformation or a circularity, it issues a warning and
2172 attempts to silently fix the problem.
2174 A pointer to PLIST is passed in so that PLIST can be successfully
2175 "fixed" even if the error is at the beginning of the plist. */
2178 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2179 int laxp, Error_behavior errb)
2181 Lisp_Object *tortoise = plist;
2182 Lisp_Object *hare = plist;
2184 while (!NILP (*tortoise))
2186 Lisp_Object *tortsave = tortoise;
2189 /* We do the standard tortoise/hare march. We isolate the
2190 grungy stuff to do this in advance_plist_pointers(), though.
2191 To us, all this function does is advance the tortoise
2192 pointer by two and the hare pointer by four and make sure
2193 everything's OK. We first advance the pointers and then
2194 check if a property matched; this ensures that our
2195 check for a matching property is safe. */
2197 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2200 if (!laxp ? EQ (XCAR (*tortsave), property)
2201 : internal_equal (XCAR (*tortsave), property, 0))
2202 return XCAR (XCDR (*tortsave));
2208 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2209 malformed or circular plist. Analogous to external_plist_get(). */
2212 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2213 Lisp_Object value, int laxp, Error_behavior errb)
2215 Lisp_Object *tortoise = plist;
2216 Lisp_Object *hare = plist;
2218 while (!NILP (*tortoise))
2220 Lisp_Object *tortsave = tortoise;
2224 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2227 if (!laxp ? EQ (XCAR (*tortsave), property)
2228 : internal_equal (XCAR (*tortsave), property, 0))
2230 XCAR (XCDR (*tortsave)) = value;
2235 *plist = Fcons (property, Fcons (value, *plist));
2239 external_remprop (Lisp_Object *plist, Lisp_Object property,
2240 int laxp, Error_behavior errb)
2242 Lisp_Object *tortoise = plist;
2243 Lisp_Object *hare = plist;
2245 while (!NILP (*tortoise))
2247 Lisp_Object *tortsave = tortoise;
2251 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2254 if (!laxp ? EQ (XCAR (*tortsave), property)
2255 : internal_equal (XCAR (*tortsave), property, 0))
2257 /* Now you see why it's so convenient to have that level
2259 *tortsave = XCDR (XCDR (*tortsave));
2267 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2268 Extract a value from a property list.
2269 PLIST is a property list, which is a list of the form
2270 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2271 corresponding to the given PROP, or DEFAULT if PROP is not
2272 one of the properties on the list.
2274 (plist, prop, default_))
2276 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2277 return UNBOUNDP (val) ? default_ : val;
2280 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2281 Change value in PLIST of PROP to VAL.
2282 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2283 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2284 If PROP is already a property on the list, its value is set to VAL,
2285 otherwise the new PROP VAL pair is added. The new plist is returned;
2286 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2287 The PLIST is modified by side effects.
2291 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2295 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2296 Remove from PLIST the property PROP and its value.
2297 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2298 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2299 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2300 the new value. The PLIST is modified by side effects.
2304 external_remprop (&plist, prop, 0, ERROR_ME);
2308 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2309 Return t if PROP has a value specified in PLIST.
2313 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2314 return UNBOUNDP (val) ? Qnil : Qt;
2317 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2318 Given a plist, signal an error if there is anything wrong with it.
2319 This means that it's a malformed or circular plist.
2323 Lisp_Object *tortoise;
2329 while (!NILP (*tortoise))
2334 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2342 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2343 Given a plist, return non-nil if its format is correct.
2344 If it returns nil, `check-valid-plist' will signal an error when given
2345 the plist; that means it's a malformed or circular plist.
2349 Lisp_Object *tortoise;
2354 while (!NILP (*tortoise))
2359 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2367 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2368 Destructively remove any duplicate entries from a plist.
2369 In such cases, the first entry applies.
2371 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2372 a nil value is removed. This feature is a virus that has infected
2373 old Lisp implementations, but should not be used except for backward
2376 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2377 return value may not be EQ to the passed-in value, so make sure to
2378 `setq' the value back into where it came from.
2380 (plist, nil_means_not_present))
2382 Lisp_Object head = plist;
2384 Fcheck_valid_plist (plist);
2386 while (!NILP (plist))
2388 Lisp_Object prop = Fcar (plist);
2389 Lisp_Object next = Fcdr (plist);
2391 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2392 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2394 if (EQ (head, plist))
2396 plist = Fcdr (next);
2399 /* external_remprop returns 1 if it removed any property.
2400 We have to loop till it didn't remove anything, in case
2401 the property occurs many times. */
2402 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2404 plist = Fcdr (next);
2410 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2411 Extract a value from a lax property list.
2413 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2414 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2415 using `equal' instead of `eq'. This function returns the value
2416 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2417 properties on the list.
2419 (lax_plist, prop, default_))
2421 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2422 return UNBOUNDP (val) ? default_ : val;
2425 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2426 Change value in LAX-PLIST of PROP to VAL.
2427 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2428 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2429 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2430 any object. If PROP is already a property on the list, its value is
2431 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2432 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2433 use the new value. The LAX-PLIST is modified by side effects.
2435 (lax_plist, prop, val))
2437 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2441 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2442 Remove from LAX-PLIST the property PROP and its value.
2443 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2444 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2445 using `equal' instead of `eq'. PROP is usually a symbol. The new
2446 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2447 sure to use the new value. The LAX-PLIST is modified by side effects.
2451 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2455 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2456 Return t if PROP has a value specified in LAX-PLIST.
2457 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2458 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2459 using `equal' instead of `eq'.
2463 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2466 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2467 Destructively remove any duplicate entries from a lax plist.
2468 In such cases, the first entry applies.
2470 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2471 a nil value is removed. This feature is a virus that has infected
2472 old Lisp implementations, but should not be used except for backward
2475 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2476 return value may not be EQ to the passed-in value, so make sure to
2477 `setq' the value back into where it came from.
2479 (lax_plist, nil_means_not_present))
2481 Lisp_Object head = lax_plist;
2483 Fcheck_valid_plist (lax_plist);
2485 while (!NILP (lax_plist))
2487 Lisp_Object prop = Fcar (lax_plist);
2488 Lisp_Object next = Fcdr (lax_plist);
2490 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2491 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2493 if (EQ (head, lax_plist))
2495 lax_plist = Fcdr (next);
2498 /* external_remprop returns 1 if it removed any property.
2499 We have to loop till it didn't remove anything, in case
2500 the property occurs many times. */
2501 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2503 lax_plist = Fcdr (next);
2509 /* In C because the frame props stuff uses it */
2511 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2512 Convert association list ALIST into the equivalent property-list form.
2513 The plist is returned. This converts from
2515 \((a . 1) (b . 2) (c . 3))
2521 The original alist is destroyed in the process of constructing the plist.
2522 See also `alist-to-plist'.
2526 Lisp_Object head = alist;
2527 while (!NILP (alist))
2529 /* remember the alist element. */
2530 Lisp_Object el = Fcar (alist);
2532 Fsetcar (alist, Fcar (el));
2533 Fsetcar (el, Fcdr (el));
2534 Fsetcdr (el, Fcdr (alist));
2535 Fsetcdr (alist, el);
2536 alist = Fcdr (Fcdr (alist));
2542 DEFUN ("get", Fget, 2, 3, 0, /*
2543 Return the value of OBJECT's PROPERTY property.
2544 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2545 If there is no such property, return optional third arg DEFAULT
2546 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2547 face, or glyph. See also `put', `remprop', and `object-plist'.
2549 (object, property, default_))
2551 /* Various places in emacs call Fget() and expect it not to quit,
2555 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2556 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2558 signal_simple_error ("Object type has no properties", object);
2560 return UNBOUNDP (val) ? default_ : val;
2563 DEFUN ("put", Fput, 3, 3, 0, /*
2564 Set OBJECT's PROPERTY to VALUE.
2565 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2566 OBJECT can be a symbol, face, extent, or string.
2567 For a string, no properties currently have predefined meanings.
2568 For the predefined properties for extents, see `set-extent-property'.
2569 For the predefined properties for faces, see `set-face-property'.
2570 See also `get', `remprop', and `object-plist'.
2572 (object, property, value))
2574 CHECK_LISP_WRITEABLE (object);
2576 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2578 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2579 (object, property, value))
2580 signal_simple_error ("Can't set property on object", property);
2583 signal_simple_error ("Object type has no settable properties", object);
2588 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2589 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2590 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2591 if the property list was actually modified (i.e. if PROPERTY was present
2592 in the property list). See also `get', `put', and `object-plist'.
2598 CHECK_LISP_WRITEABLE (object);
2600 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2602 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2604 signal_simple_error ("Can't remove property from object", property);
2607 signal_simple_error ("Object type has no removable properties", object);
2609 return ret ? Qt : Qnil;
2612 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2613 Return a property list of OBJECT's properties.
2614 For a symbol, this is equivalent to `symbol-plist'.
2615 OBJECT can be a symbol, string, extent, face, or glyph.
2616 Do not modify the returned property list directly;
2617 this may or may not have the desired effects. Use `put' instead.
2621 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2622 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2624 signal_simple_error ("Object type has no properties", object);
2631 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2634 error ("Stack overflow in equal");
2636 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2638 /* Note that (equal 20 20.0) should be nil */
2639 if (XTYPE (obj1) != XTYPE (obj2))
2641 if (LRECORDP (obj1))
2643 const struct lrecord_implementation
2644 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2645 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2647 return (imp1 == imp2) &&
2648 /* EQ-ness of the objects was noticed above */
2649 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2655 /* Note that we may be calling sub-objects that will use
2656 internal_equal() (instead of internal_old_equal()). Oh well.
2657 We will get an Ebola note if there's any possibility of confusion,
2658 but that seems unlikely. */
2661 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2664 error ("Stack overflow in equal");
2666 if (HACKEQ_UNSAFE (obj1, obj2))
2668 /* Note that (equal 20 20.0) should be nil */
2669 if (XTYPE (obj1) != XTYPE (obj2))
2672 return internal_equal (obj1, obj2, depth);
2675 DEFUN ("equal", Fequal, 2, 2, 0, /*
2676 Return t if two Lisp objects have similar structure and contents.
2677 They must have the same data type.
2678 Conses are compared by comparing the cars and the cdrs.
2679 Vectors and strings are compared element by element.
2680 Numbers are compared by value. Symbols must match exactly.
2684 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2687 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2688 Return t if two Lisp objects have similar structure and contents.
2689 They must have the same data type.
2690 \(Note, however, that an exception is made for characters and integers;
2691 this is known as the "char-int confoundance disease." See `eq' and
2693 This function is provided only for byte-code compatibility with v19.
2698 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2702 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2703 Destructively modify ARRAY by replacing each element with ITEM.
2704 ARRAY is a vector, bit vector, or string.
2709 if (STRINGP (array))
2711 Lisp_String *s = XSTRING (array);
2712 Bytecount old_bytecount = string_length (s);
2713 Bytecount new_bytecount;
2714 Bytecount item_bytecount;
2715 Bufbyte item_buf[MAX_EMCHAR_LEN];
2719 CHECK_CHAR_COERCE_INT (item);
2720 CHECK_LISP_WRITEABLE (array);
2722 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2723 new_bytecount = item_bytecount * string_char_length (s);
2725 resize_string (s, -1, new_bytecount - old_bytecount);
2727 for (p = string_data (s), end = p + new_bytecount;
2729 p += item_bytecount)
2730 memcpy (p, item_buf, item_bytecount);
2733 bump_string_modiff (array);
2735 else if (VECTORP (array))
2737 Lisp_Object *p = XVECTOR_DATA (array);
2738 int len = XVECTOR_LENGTH (array);
2739 CHECK_LISP_WRITEABLE (array);
2743 else if (BIT_VECTORP (array))
2745 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2746 int len = bit_vector_length (v);
2749 CHECK_LISP_WRITEABLE (array);
2752 set_bit_vector_bit (v, len, bit);
2756 array = wrong_type_argument (Qarrayp, array);
2763 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2765 Lisp_Object args[2];
2766 struct gcpro gcpro1;
2773 RETURN_UNGCPRO (bytecode_nconc2 (args));
2777 bytecode_nconc2 (Lisp_Object *args)
2781 if (CONSP (args[0]))
2783 /* (setcdr (last args[0]) args[1]) */
2784 Lisp_Object tortoise, hare;
2787 for (hare = tortoise = args[0], count = 0;
2788 CONSP (XCDR (hare));
2789 hare = XCDR (hare), count++)
2791 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2794 tortoise = XCDR (tortoise);
2795 if (EQ (hare, tortoise))
2796 signal_circular_list_error (args[0]);
2798 XCDR (hare) = args[1];
2801 else if (NILP (args[0]))
2807 args[0] = wrong_type_argument (args[0], Qlistp);
2812 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2813 Concatenate any number of lists by altering them.
2814 Only the last argument is not altered, and need not be a list.
2816 If the first argument is nil, there is no way to modify it by side
2817 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2818 changing the value of `foo'.
2820 (int nargs, Lisp_Object *args))
2823 struct gcpro gcpro1;
2825 /* The modus operandi in Emacs is "caller gc-protects args".
2826 However, nconc (particularly nconc2 ()) is called many times
2827 in Emacs on freshly created stuff (e.g. you see the idiom
2828 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2829 callers out by protecting the args ourselves to save them
2830 a lot of temporary-variable grief. */
2833 gcpro1.nvars = nargs;
2835 while (argnum < nargs)
2842 /* `val' is the first cons, which will be our return value. */
2843 /* `last_cons' will be the cons cell to mutate. */
2844 Lisp_Object last_cons = val;
2845 Lisp_Object tortoise = val;
2847 for (argnum++; argnum < nargs; argnum++)
2849 Lisp_Object next = args[argnum];
2851 if (CONSP (next) || argnum == nargs -1)
2853 /* (setcdr (last val) next) */
2857 CONSP (XCDR (last_cons));
2858 last_cons = XCDR (last_cons), count++)
2860 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2863 tortoise = XCDR (tortoise);
2864 if (EQ (last_cons, tortoise))
2865 signal_circular_list_error (args[argnum-1]);
2867 XCDR (last_cons) = next;
2869 else if (NILP (next))
2875 next = wrong_type_argument (Qlistp, next);
2879 RETURN_UNGCPRO (val);
2881 else if (NILP (val))
2883 else if (argnum == nargs - 1) /* last arg? */
2884 RETURN_UNGCPRO (val);
2887 args[argnum] = wrong_type_argument (Qlistp, val);
2891 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
2895 /* This is the guts of several mapping functions.
2896 Apply FUNCTION to each element of SEQUENCE, one by one,
2897 storing the results into elements of VALS, a C vector of Lisp_Objects.
2898 LENI is the length of VALS, which should also be the length of SEQUENCE.
2900 If VALS is a null pointer, do not accumulate the results. */
2903 mapcar1 (size_t leni, Lisp_Object *vals,
2904 Lisp_Object function, Lisp_Object sequence)
2907 Lisp_Object args[2];
2909 struct gcpro gcpro1;
2919 if (LISTP (sequence))
2921 /* A devious `function' could either:
2922 - insert garbage into the list in front of us, causing XCDR to crash
2923 - amputate the list behind us using (setcdr), causing the remaining
2924 elts to lose their GCPRO status.
2926 if (vals != 0) we avoid this by copying the elts into the
2927 `vals' array. By a stroke of luck, `vals' is exactly large
2928 enough to hold the elts left to be traversed as well as the
2929 results computed so far.
2931 if (vals == 0) we don't have any free space available and
2932 don't want to eat up any more stack with alloca().
2933 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
2937 Lisp_Object *val = vals;
2939 LIST_LOOP_2 (elt, sequence)
2942 gcpro1.nvars = leni;
2944 for (i = 0; i < leni; i++)
2947 vals[i] = Ffuncall (2, args);
2952 Lisp_Object elt, tail;
2953 EMACS_INT len_unused;
2954 struct gcpro ngcpro1;
2959 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
2969 else if (VECTORP (sequence))
2971 Lisp_Object *objs = XVECTOR_DATA (sequence);
2972 for (i = 0; i < leni; i++)
2975 result = Ffuncall (2, args);
2976 if (vals) vals[gcpro1.nvars++] = result;
2979 else if (STRINGP (sequence))
2981 /* The string data of `sequence' might be relocated during GC. */
2982 Bytecount slen = XSTRING_LENGTH (sequence);
2983 Bufbyte *p = alloca_array (Bufbyte, slen);
2984 Bufbyte *end = p + slen;
2986 memcpy (p, XSTRING_DATA (sequence), slen);
2990 args[1] = make_char (charptr_emchar (p));
2992 result = Ffuncall (2, args);
2993 if (vals) vals[gcpro1.nvars++] = result;
2996 else if (BIT_VECTORP (sequence))
2998 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
2999 for (i = 0; i < leni; i++)
3001 args[1] = make_int (bit_vector_bit (v, i));
3002 result = Ffuncall (2, args);
3003 if (vals) vals[gcpro1.nvars++] = result;
3007 abort (); /* unreachable, since Flength (sequence) did not get an error */
3013 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3014 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3015 In between each pair of results, insert SEPARATOR. Thus, using " " as
3016 SEPARATOR results in spaces between the values returned by FUNCTION.
3017 SEQUENCE may be a list, a vector, a bit vector, or a string.
3019 (function, sequence, separator))
3021 size_t len = XINT (Flength (sequence));
3024 int nargs = len + len - 1;
3026 if (len == 0) return build_string ("");
3028 args = alloca_array (Lisp_Object, nargs);
3030 mapcar1 (len, args, function, sequence);
3032 for (i = len - 1; i >= 0; i--)
3033 args[i + i] = args[i];
3035 for (i = 1; i < nargs; i += 2)
3036 args[i] = separator;
3038 return Fconcat (nargs, args);
3041 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3042 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3043 The result is a list of the same length as SEQUENCE.
3044 SEQUENCE may be a list, a vector, a bit vector, or a string.
3046 (function, sequence))
3048 size_t len = XINT (Flength (sequence));
3049 Lisp_Object *args = alloca_array (Lisp_Object, len);
3051 mapcar1 (len, args, function, sequence);
3053 return Flist (len, args);
3056 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3057 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3058 The result is a vector of the same length as SEQUENCE.
3059 SEQUENCE may be a list, a vector, a bit vector, or a string.
3061 (function, sequence))
3063 size_t len = XINT (Flength (sequence));
3064 Lisp_Object result = make_vector (len, Qnil);
3065 struct gcpro gcpro1;
3068 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3074 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3075 Apply FUNCTION to each element of SEQUENCE.
3076 SEQUENCE may be a list, a vector, a bit vector, or a string.
3077 This function is like `mapcar' but does not accumulate the results,
3078 which is more efficient if you do not use the results.
3080 The difference between this and `mapc' is that `mapc' supports all
3081 the spiffy Common Lisp arguments. You should normally use `mapc'.
3083 (function, sequence))
3085 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3093 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3094 Destructively replace the list OLD with NEW.
3095 This is like (copy-sequence NEW) except that it reuses the
3096 conses in OLD as much as possible. If OLD and NEW are the same
3097 length, no consing will take place.
3101 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
3103 EXTERNAL_LIST_LOOP (tail, new)
3105 if (!NILP (oldtail))
3107 CHECK_CONS (oldtail);
3108 XCAR (oldtail) = XCAR (tail);
3110 else if (!NILP (prevoldtail))
3112 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
3113 prevoldtail = XCDR (prevoldtail);
3116 old = oldtail = Fcons (XCAR (tail), Qnil);
3118 if (!NILP (oldtail))
3120 prevoldtail = oldtail;
3121 oldtail = XCDR (oldtail);
3125 if (!NILP (prevoldtail))
3126 XCDR (prevoldtail) = Qnil;
3134 /* #### this function doesn't belong in this file! */
3136 #ifdef HAVE_GETLOADAVG
3137 #ifdef HAVE_SYS_LOADAVG_H
3138 #include <sys/loadavg.h>
3141 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
3144 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3145 Return list of 1 minute, 5 minute and 15 minute load averages.
3146 Each of the three load averages is multiplied by 100,
3147 then converted to integer.
3149 When USE-FLOATS is non-nil, floats will be used instead of integers.
3150 These floats are not multiplied by 100.
3152 If the 5-minute or 15-minute load averages are not available, return a
3153 shortened list, containing only those averages which are available.
3155 On some systems, this won't work due to permissions on /dev/kmem,
3156 in which case you can't use this.
3161 int loads = getloadavg (load_ave, countof (load_ave));
3162 Lisp_Object ret = Qnil;
3165 error ("load-average not implemented for this operating system");
3167 signal_simple_error ("Could not get load-average",
3168 lisp_strerror (errno));
3172 Lisp_Object load = (NILP (use_floats) ?
3173 make_int ((int) (100.0 * load_ave[loads]))
3174 : make_float (load_ave[loads]));
3175 ret = Fcons (load, ret);
3181 Lisp_Object Vfeatures;
3183 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3184 Return non-nil if feature FEXP is present in this Emacs.
3185 Use this to conditionalize execution of lisp code based on the
3186 presence or absence of emacs or environment extensions.
3187 FEXP can be a symbol, a number, or a list.
3188 If it is a symbol, that symbol is looked up in the `features' variable,
3189 and non-nil will be returned if found.
3190 If it is a number, the function will return non-nil if this Emacs
3191 has an equal or greater version number than FEXP.
3192 If it is a list whose car is the symbol `and', it will return
3193 non-nil if all the features in its cdr are non-nil.
3194 If it is a list whose car is the symbol `or', it will return non-nil
3195 if any of the features in its cdr are non-nil.
3196 If it is a list whose car is the symbol `not', it will return
3197 non-nil if the feature is not present.
3202 => ; Non-nil on XEmacs.
3204 (featurep '(and xemacs gnus))
3205 => ; Non-nil on XEmacs with Gnus loaded.
3207 (featurep '(or tty-frames (and emacs 19.30)))
3208 => ; Non-nil if this Emacs supports TTY frames.
3210 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3211 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3213 (featurep '(and xemacs 21.02))
3214 => ; Non-nil on XEmacs 21.2 and later.
3216 NOTE: The advanced arguments of this function (anything other than a
3217 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3218 for supporting multiple Emacs variants, lobby Richard Stallman at
3219 <bug-gnu-emacs@gnu.org>.
3223 #ifndef FEATUREP_SYNTAX
3224 CHECK_SYMBOL (fexp);
3225 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3226 #else /* FEATUREP_SYNTAX */
3227 static double featurep_emacs_version;
3229 /* Brute force translation from Erik Naggum's lisp function. */
3232 /* Original definition */
3233 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3235 else if (INTP (fexp) || FLOATP (fexp))
3237 double d = extract_float (fexp);
3239 if (featurep_emacs_version == 0.0)
3241 featurep_emacs_version = XINT (Vemacs_major_version) +
3242 (XINT (Vemacs_minor_version) / 100.0);
3244 return featurep_emacs_version >= d ? Qt : Qnil;
3246 else if (CONSP (fexp))
3248 Lisp_Object tem = XCAR (fexp);
3254 negate = Fcar (tem);
3256 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3258 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3260 else if (EQ (tem, Qand))
3263 /* Use Fcar/Fcdr for error-checking. */
3264 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3268 return NILP (tem) ? Qt : Qnil;
3270 else if (EQ (tem, Qor))
3273 /* Use Fcar/Fcdr for error-checking. */
3274 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3278 return NILP (tem) ? Qnil : Qt;
3282 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3287 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3290 #endif /* FEATUREP_SYNTAX */
3292 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3293 Announce that FEATURE is a feature of the current Emacs.
3294 This function updates the value of the variable `features'.
3299 CHECK_SYMBOL (feature);
3300 if (!NILP (Vautoload_queue))
3301 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3302 tem = Fmemq (feature, Vfeatures);
3304 Vfeatures = Fcons (feature, Vfeatures);
3305 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3309 DEFUN ("require", Frequire, 1, 2, 0, /*
3310 If feature FEATURE is not loaded, load it from FILENAME.
3311 If FEATURE is not a member of the list `features', then the feature
3312 is not loaded; so load the file FILENAME.
3313 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3315 (feature, file_name))
3318 CHECK_SYMBOL (feature);
3319 tem = Fmemq (feature, Vfeatures);
3320 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3325 int speccount = specpdl_depth ();
3327 /* Value saved here is to be restored into Vautoload_queue */
3328 record_unwind_protect (un_autoload, Vautoload_queue);
3329 Vautoload_queue = Qt;
3331 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3334 tem = Fmemq (feature, Vfeatures);
3336 error ("Required feature %s was not provided",
3337 string_data (XSYMBOL (feature)->name));
3339 /* Once loading finishes, don't undo it. */
3340 Vautoload_queue = Qt;
3341 return unbind_to (speccount, feature);
3345 /* base64 encode/decode functions.
3347 Originally based on code from GNU recode. Ported to FSF Emacs by
3348 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3349 subsequently heavily hacked by Hrvoje Niksic. */
3351 #define MIME_LINE_LENGTH 72
3353 #define IS_ASCII(Character) \
3355 #define IS_BASE64(Character) \
3356 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3358 /* Table of characters coding the 64 values. */
3359 static char base64_value_to_char[64] =
3361 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3362 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3363 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3364 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3365 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3366 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3367 '8', '9', '+', '/' /* 60-63 */
3370 /* Table of base64 values for first 128 characters. */
3371 static short base64_char_to_value[128] =
3373 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3374 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3375 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3376 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3377 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3378 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3379 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3380 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3381 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3382 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3383 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3384 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3385 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3388 /* The following diagram shows the logical steps by which three octets
3389 get transformed into four base64 characters.
3391 .--------. .--------. .--------.
3392 |aaaaaabb| |bbbbcccc| |ccdddddd|
3393 `--------' `--------' `--------'
3395 .--------+--------+--------+--------.
3396 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3397 `--------+--------+--------+--------'
3399 .--------+--------+--------+--------.
3400 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3401 `--------+--------+--------+--------'
3403 The octets are divided into 6 bit chunks, which are then encoded into
3404 base64 characters. */
3406 #define ADVANCE_INPUT(c, stream) \
3407 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3409 (signal_simple_error ("Non-ascii character in base64 input", \
3410 make_char (ec)), 0) \
3411 : (c = (Bufbyte)ec), 1))
3414 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3416 EMACS_INT counter = 0;
3424 if (!ADVANCE_INPUT (c, istream))
3427 /* Wrap line every 76 characters. */
3430 if (counter < MIME_LINE_LENGTH / 4)
3439 /* Process first byte of a triplet. */
3440 *e++ = base64_value_to_char[0x3f & c >> 2];
3441 value = (0x03 & c) << 4;
3443 /* Process second byte of a triplet. */
3444 if (!ADVANCE_INPUT (c, istream))
3446 *e++ = base64_value_to_char[value];
3452 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3453 value = (0x0f & c) << 2;
3455 /* Process third byte of a triplet. */
3456 if (!ADVANCE_INPUT (c, istream))
3458 *e++ = base64_value_to_char[value];
3463 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3464 *e++ = base64_value_to_char[0x3f & c];
3469 #undef ADVANCE_INPUT
3471 /* Get next character from the stream, except that non-base64
3472 characters are ignored. This is in accordance with rfc2045. EC
3473 should be an Emchar, so that it can hold -1 as the value for EOF. */
3474 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3475 ec = Lstream_get_emchar (stream); \
3477 /* IS_BASE64 may not be called with negative arguments so check for \
3479 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3483 #define STORE_BYTE(pos, val, ccnt) do { \
3484 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3489 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3493 EMACS_INT streampos = 0;
3498 unsigned long value;
3500 /* Process first byte of a quadruplet. */
3501 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3505 signal_simple_error ("Illegal `=' character while decoding base64",
3506 make_int (streampos));
3507 value = base64_char_to_value[ec] << 18;
3509 /* Process second byte of a quadruplet. */
3510 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3512 error ("Premature EOF while decoding base64");
3514 signal_simple_error ("Illegal `=' character while decoding base64",
3515 make_int (streampos));
3516 value |= base64_char_to_value[ec] << 12;
3517 STORE_BYTE (e, value >> 16, ccnt);
3519 /* Process third byte of a quadruplet. */
3520 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3522 error ("Premature EOF while decoding base64");
3526 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3528 error ("Premature EOF while decoding base64");
3530 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3531 make_int (streampos));
3535 value |= base64_char_to_value[ec] << 6;
3536 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3538 /* Process fourth byte of a quadruplet. */
3539 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3541 error ("Premature EOF while decoding base64");
3545 value |= base64_char_to_value[ec];
3546 STORE_BYTE (e, 0xff & value, ccnt);
3552 #undef ADVANCE_INPUT
3553 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3557 free_malloced_ptr (Lisp_Object unwind_obj)
3559 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3561 free_opaque_ptr (unwind_obj);
3565 /* Don't use alloca for regions larger than this, lest we overflow
3567 #define MAX_ALLOCA 65536
3569 /* We need to setup proper unwinding, because there is a number of
3570 ways these functions can blow up, and we don't want to have memory
3571 leaks in those cases. */
3572 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3573 size_t XOA_len = (len); \
3574 if (XOA_len > MAX_ALLOCA) \
3576 ptr = xnew_array (type, XOA_len); \
3577 record_unwind_protect (free_malloced_ptr, \
3578 make_opaque_ptr ((void *)ptr)); \
3581 ptr = alloca_array (type, XOA_len); \
3584 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3585 if ((len) > MAX_ALLOCA) \
3586 unbind_to (speccount, Qnil); \
3589 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3590 Base64-encode the region between BEG and END.
3591 Return the length of the encoded text.
3592 Optional third argument NO-LINE-BREAK means do not break long lines
3595 (beg, end, no_line_break))
3598 Bytind encoded_length;
3599 Charcount allength, length;
3600 struct buffer *buf = current_buffer;
3601 Bufpos begv, zv, old_pt = BUF_PT (buf);
3603 int speccount = specpdl_depth();
3605 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3606 barf_if_buffer_read_only (buf, begv, zv);
3608 /* We need to allocate enough room for encoding the text.
3609 We need 33 1/3% more space, plus a newline every 76
3610 characters, and then we round up. */
3612 allength = length + length/3 + 1;
3613 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3615 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3616 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3617 base64 characters will be single-byte. */
3618 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3619 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3620 NILP (no_line_break));
3621 if (encoded_length > allength)
3623 Lstream_delete (XLSTREAM (input));
3625 /* Now we have encoded the region, so we insert the new contents
3626 and delete the old. (Insert first in order to preserve markers.) */
3627 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3628 XMALLOC_UNBIND (encoded, allength, speccount);
3629 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3631 /* Simulate FSF Emacs implementation of this function: if point was
3632 in the region, place it at the beginning. */
3633 if (old_pt >= begv && old_pt < zv)
3634 BUF_SET_PT (buf, begv);
3636 /* We return the length of the encoded text. */
3637 return make_int (encoded_length);
3640 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3641 Base64 encode STRING and return the result.
3643 (string, no_line_break))
3645 Charcount allength, length;
3646 Bytind encoded_length;
3648 Lisp_Object input, result;
3649 int speccount = specpdl_depth();
3651 CHECK_STRING (string);
3653 length = XSTRING_CHAR_LENGTH (string);
3654 allength = length + length/3 + 1;
3655 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3657 input = make_lisp_string_input_stream (string, 0, -1);
3658 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3659 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3660 NILP (no_line_break));
3661 if (encoded_length > allength)
3663 Lstream_delete (XLSTREAM (input));
3664 result = make_string (encoded, encoded_length);
3665 XMALLOC_UNBIND (encoded, allength, speccount);
3669 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3670 Base64-decode the region between BEG and END.
3671 Return the length of the decoded text.
3672 If the region can't be decoded, return nil and don't modify the buffer.
3673 Characters out of the base64 alphabet are ignored.
3677 struct buffer *buf = current_buffer;
3678 Bufpos begv, zv, old_pt = BUF_PT (buf);
3680 Bytind decoded_length;
3681 Charcount length, cc_decoded_length;
3683 int speccount = specpdl_depth();
3685 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3686 barf_if_buffer_read_only (buf, begv, zv);
3690 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3691 /* We need to allocate enough room for decoding the text. */
3692 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3693 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3694 if (decoded_length > length * MAX_EMCHAR_LEN)
3696 Lstream_delete (XLSTREAM (input));
3698 /* Now we have decoded the region, so we insert the new contents
3699 and delete the old. (Insert first in order to preserve markers.) */
3700 BUF_SET_PT (buf, begv);
3701 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3702 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3703 buffer_delete_range (buf, begv + cc_decoded_length,
3704 zv + cc_decoded_length, 0);
3706 /* Simulate FSF Emacs implementation of this function: if point was
3707 in the region, place it at the beginning. */
3708 if (old_pt >= begv && old_pt < zv)
3709 BUF_SET_PT (buf, begv);
3711 return make_int (cc_decoded_length);
3714 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3715 Base64-decode STRING and return the result.
3716 Characters out of the base64 alphabet are ignored.
3721 Bytind decoded_length;
3722 Charcount length, cc_decoded_length;
3723 Lisp_Object input, result;
3724 int speccount = specpdl_depth();
3726 CHECK_STRING (string);
3728 length = XSTRING_CHAR_LENGTH (string);
3729 /* We need to allocate enough room for decoding the text. */
3730 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3732 input = make_lisp_string_input_stream (string, 0, -1);
3733 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3734 &cc_decoded_length);
3735 if (decoded_length > length * MAX_EMCHAR_LEN)
3737 Lstream_delete (XLSTREAM (input));
3739 result = make_string (decoded, decoded_length);
3740 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3744 Lisp_Object Qyes_or_no_p;
3749 INIT_LRECORD_IMPLEMENTATION (bit_vector);
3751 defsymbol (&Qstring_lessp, "string-lessp");
3752 defsymbol (&Qidentity, "identity");
3753 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3755 DEFSUBR (Fidentity);
3758 DEFSUBR (Fsafe_length);
3759 DEFSUBR (Fstring_equal);
3760 DEFSUBR (Fstring_lessp);
3761 DEFSUBR (Fstring_modified_tick);
3765 DEFSUBR (Fbvconcat);
3766 DEFSUBR (Fcopy_list);
3767 DEFSUBR (Fcopy_sequence);
3768 DEFSUBR (Fcopy_alist);
3769 DEFSUBR (Fcopy_tree);
3770 DEFSUBR (Fsubstring);
3777 DEFSUBR (Fnbutlast);
3779 DEFSUBR (Fold_member);
3781 DEFSUBR (Fold_memq);
3783 DEFSUBR (Fold_assoc);
3785 DEFSUBR (Fold_assq);
3787 DEFSUBR (Fold_rassoc);
3789 DEFSUBR (Fold_rassq);
3791 DEFSUBR (Fold_delete);
3793 DEFSUBR (Fold_delq);
3794 DEFSUBR (Fremassoc);
3796 DEFSUBR (Fremrassoc);
3797 DEFSUBR (Fremrassq);
3798 DEFSUBR (Fnreverse);
3801 DEFSUBR (Fplists_eq);
3802 DEFSUBR (Fplists_equal);
3803 DEFSUBR (Flax_plists_eq);
3804 DEFSUBR (Flax_plists_equal);
3805 DEFSUBR (Fplist_get);
3806 DEFSUBR (Fplist_put);
3807 DEFSUBR (Fplist_remprop);
3808 DEFSUBR (Fplist_member);
3809 DEFSUBR (Fcheck_valid_plist);
3810 DEFSUBR (Fvalid_plist_p);
3811 DEFSUBR (Fcanonicalize_plist);
3812 DEFSUBR (Flax_plist_get);
3813 DEFSUBR (Flax_plist_put);
3814 DEFSUBR (Flax_plist_remprop);
3815 DEFSUBR (Flax_plist_member);
3816 DEFSUBR (Fcanonicalize_lax_plist);
3817 DEFSUBR (Fdestructive_alist_to_plist);
3821 DEFSUBR (Fobject_plist);
3823 DEFSUBR (Fold_equal);
3824 DEFSUBR (Ffillarray);
3827 DEFSUBR (Fmapvector);
3828 DEFSUBR (Fmapc_internal);
3829 DEFSUBR (Fmapconcat);
3830 DEFSUBR (Freplace_list);
3831 DEFSUBR (Fload_average);
3832 DEFSUBR (Ffeaturep);
3835 DEFSUBR (Fbase64_encode_region);
3836 DEFSUBR (Fbase64_encode_string);
3837 DEFSUBR (Fbase64_decode_region);
3838 DEFSUBR (Fbase64_decode_string);
3842 init_provide_once (void)
3844 DEFVAR_LISP ("features", &Vfeatures /*
3845 A list of symbols which are the features of the executing emacs.
3846 Used by `featurep' and `require', and altered by `provide'.
3850 Fprovide (intern ("base64"));