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 SXEmacs
7 SXEmacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 SXEmacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
21 /* Synched up with: Mule 2.0, FSF 19.30. */
23 /* This file has been Mule-ized. */
25 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
27 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
31 /* Note on some machines this defines `vector' as a typedef,
32 so make sure we don't use that name in this file. */
42 #include "ui/device.h"
43 #include "events/events.h"
47 #include "ui/insdel.h"
50 /* for the categorial views */
53 /* for all the map* funs */
57 /* NOTE: This symbol is also used in lread.c */
58 #define FEATUREP_SYNTAX
60 Lisp_Object Qstring_lessp, Qstring_greaterp;
61 Lisp_Object Qidentity;
63 static int internal_old_equal(Lisp_Object, Lisp_Object, int);
64 Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth);
65 int internal_equalp(Lisp_Object, Lisp_Object, int);
67 static Lisp_Object mark_bit_vector(Lisp_Object obj)
73 print_bit_vector(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
76 Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
77 size_t len = bit_vector_length(v);
80 if (INTP(Vprint_length))
81 last = min((EMACS_INT) len, XINT(Vprint_length));
82 write_c_string("#*", printcharfun);
83 for (i = 0; i < last; i++) {
84 if (bit_vector_bit(v, i))
85 write_c_string("1", printcharfun);
87 write_c_string("0", printcharfun);
91 write_c_string("...", printcharfun);
94 static int bit_vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
96 Lisp_Bit_Vector *v1 = XBIT_VECTOR(obj1);
97 Lisp_Bit_Vector *v2 = XBIT_VECTOR(obj2);
99 return ((bit_vector_length(v1) == bit_vector_length(v2)) &&
100 !memcmp(v1->bits, v2->bits,
101 BIT_VECTOR_LONG_STORAGE(bit_vector_length(v1)) *
105 static unsigned long bit_vector_hash(Lisp_Object obj, int depth)
107 Lisp_Bit_Vector *v = XBIT_VECTOR(obj);
108 return HASH2(bit_vector_length(v),
110 BIT_VECTOR_LONG_STORAGE(bit_vector_length(v)) *
114 static size_t size_bit_vector(const void *lheader)
116 const Lisp_Bit_Vector *v = (const Lisp_Bit_Vector *) lheader;
117 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
119 BIT_VECTOR_LONG_STORAGE
120 (bit_vector_length(v)));
123 static const struct lrecord_description bit_vector_description[] = {
124 {XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next)},
128 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION("bit-vector", bit_vector,
129 mark_bit_vector, print_bit_vector,
132 bit_vector_description,
133 size_bit_vector, Lisp_Bit_Vector);
135 DEFUN("identity", Fidentity, 1, 1, 0, /*
136 Return the argument unchanged.
143 extern long get_random(void);
144 extern void seed_random(long arg);
146 DEFUN("random", Frandom, 0, 1, 0, /*
147 Return a pseudo-random number.
148 All integers representable in Lisp are equally likely.
149 On most systems, this is 31 bits' worth.
151 With positive integer argument LIMIT, return random number
152 in interval [0,LIMIT). LIMIT can be a big integer, in which
153 case the range of possible values is extended.
155 With argument t, set the random number seed from the
156 current time and pid.
161 unsigned long denominator;
164 seed_random(getpid() + time(NULL));
165 if (NATNUMP(limit) && !ZEROP(limit)) {
166 /* Try to take our random number from the higher bits of VAL,
167 not the lower, since (says Gentzel) the low bits of `random'
168 are less random than the higher ones. We do this by using the
169 quotient rather than the remainder. At the high end of the RNG
170 it's possible to get a quotient larger than limit; discarding
171 these values eliminates the bias that would otherwise appear
172 when using a large limit. */
173 denominator = ((unsigned long)1 << INT_VALBITS) / XINT(limit);
175 val = get_random() / denominator;
176 while (val >= XINT(limit));
177 } else if (ZEROP(limit)) {
178 return wrong_type_argument(Qpositivep, limit);
179 #if defined HAVE_MPZ && defined WITH_GMP
180 } else if (BIGZP(limit)) {
184 if (bigz_sign(XBIGZ_DATA(limit)) <= 0)
185 return wrong_type_argument(Qpositivep, limit);
189 bigz_random(bz, XBIGZ_DATA(limit));
190 result = ent_mpz_downgrade_maybe(bz);
194 #endif /* HAVE_MPZ */
198 return make_int(val);
201 #if defined(WITH_GMP) && defined(HAVE_MPZ)
202 DEFUN("randomb", Frandomb, 1, 1, 0, /*
203 Return a uniform pseudo-random number in the range [0, 2^LIMIT).
211 CHECK_INTEGER(limit);
213 if (NILP(Fnonnegativep(limit)))
214 return wrong_type_argument(Qnonnegativep, limit);
215 else if (INTP(limit))
217 else if (BIGZP(limit) && bigz_fits_ulong_p(XBIGZ_DATA(limit)))
218 limui = bigz_to_ulong(XBIGZ_DATA(limit));
220 return wrong_type_argument(Qintegerp, limit);
224 mpz_urandomb(bz, random_state, limui);
225 result = make_bigz_bz(bz);
230 #endif /* HAVE_MPZ */
233 /* Random data-structure functions */
235 #ifdef LOSING_BYTECODE
237 /* #### Delete this shit */
239 /* Charcount is a misnomer here as we might be dealing with the
240 length of a vector or list, but emphasizes that we're not dealing
241 with Bytecounts in strings */
242 static Charcount length_with_bytecode_hack(Lisp_Object seq)
244 if (!COMPILED_FUNCTIONP(seq))
245 return XINT(Flength(seq));
247 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(seq);
249 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
250 f->flags.domainp ? COMPILED_DOMAIN :
256 #endif /* LOSING_BYTECODE */
258 void check_losing_bytecode(const char *function, Lisp_Object seq)
260 if (COMPILED_FUNCTIONP(seq))
263 "As of 20.3, `%s' no longer works with compiled-function objects",
267 DEFUN("length", Flength, 1, 1, 0, /*
268 Return the length of vector, bit vector, list or string SEQUENCE.
273 /* that's whither we have to get */
274 if (LIKELY(!NILP(sequence))) {
275 return make_int(seq_length((seq_t)sequence));
281 if (LIKELY(STRINGP(sequence) ||
285 BIT_VECTORP(sequence))) {
286 return make_int(seq_length(sequence));
287 } else if (NILP(sequence)) {
290 check_losing_bytecode("length", sequence);
291 sequence = wrong_type_argument(Qsequencep, sequence);
296 if (STRINGP(sequence))
297 return make_int(XSTRING_CHAR_LENGTH(sequence));
298 else if (CONSP(sequence)) {
299 return make_int(seq_length(sequence));
300 } else if (VECTORP(sequence))
301 return make_int(seq_length(sequence));
302 else if (DLLISTP(sequence))
303 return make_int(XDLLIST_SIZE(sequence));
304 else if (NILP(sequence))
306 else if (BIT_VECTORP(sequence))
307 return make_int(bit_vector_length(XBIT_VECTOR(sequence)));
309 check_losing_bytecode("length", sequence);
310 sequence = wrong_type_argument(Qsequencep, sequence);
316 DEFUN("safe-length", Fsafe_length, 1, 1, 0, /*
317 Return the length of a list, but avoid error or infinite loop.
318 This function never gets an error. If LIST is not really a list,
319 it returns 0. If LIST is circular, it returns a finite value
320 which is at least the number of distinct elements.
324 Lisp_Object hare, tortoise;
327 for (hare = tortoise = list, len = 0;
328 CONSP(hare) && (!EQ(hare, tortoise) || len == 0);
329 hare = XCDR(hare), len++) {
331 tortoise = XCDR(tortoise);
334 return make_int(len);
337 /*** string functions. ***/
339 DEFUN("string-equal", Fstring_equal, 2, 2, 0, /*
340 Return t if two strings have identical contents.
341 Case is significant. Text properties are ignored.
342 \(Under SXEmacs, `equal' also ignores text properties and extents in
343 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
344 `equal' is the same as in SXEmacs, in that respect.)
345 Symbols are also allowed; their print names are used instead.
350 Lisp_String *p1, *p2;
352 if (SYMBOLP(string1))
353 p1 = XSYMBOL(string1)->name;
355 CHECK_STRING(string1);
356 p1 = XSTRING(string1);
359 if (SYMBOLP(string2))
360 p2 = XSYMBOL(string2)->name;
362 CHECK_STRING(string2);
363 p2 = XSTRING(string2);
366 return (((len = string_length(p1)) == string_length(p2)) &&
367 !memcmp(string_data(p1), string_data(p2), len)) ? Qt : Qnil;
370 DEFUN("string-lessp", Fstring_lessp, 2, 2, 0, /*
371 Return t if first arg string is less than second in lexicographic order.
372 If I18N2 support (but not Mule support) was compiled in, ordering is
373 determined by the locale. (Case is significant for the default C locale.)
374 In all other cases, comparison is simply done on a character-by-
375 character basis using the numeric value of a character. (Note that
376 this may not produce particularly meaningful results under Mule if
377 characters from different charsets are being compared.)
379 Symbols are also allowed; their print names are used instead.
381 The reason that the I18N2 locale-specific collation is not used under
382 Mule is that the locale model of internationalization does not handle
383 multiple charsets and thus has no hope of working properly under Mule.
384 What we really should do is create a collation table over all built-in
385 charsets. This is extremely difficult to do from scratch, however.
387 Unicode is a good first step towards solving this problem. In fact,
388 it is quite likely that a collation table exists (or will exist) for
389 Unicode. When Unicode support is added to SXEmacs/Mule, this problem
394 Lisp_String *p1, *p2;
398 if (SYMBOLP(string1))
399 p1 = XSYMBOL(string1)->name;
401 CHECK_STRING(string1);
402 p1 = XSTRING(string1);
405 if (SYMBOLP(string2))
406 p2 = XSYMBOL(string2)->name;
408 CHECK_STRING(string2);
409 p2 = XSTRING(string2);
412 end = string_char_length(p1);
413 len2 = string_char_length(p2);
417 #if defined (I18N2) && !defined (MULE)
418 /* There is no hope of this working under Mule. Even if we converted
419 the data into an external format so that strcoll() processed it
420 properly, it would still not work because strcoll() does not
421 handle multiple locales. This is the fundamental flaw in the
424 Bytecount bcend = charcount_to_bytecount(string_data(p1), end);
425 /* Compare strings using collation order of locale. */
426 /* Need to be tricky to handle embedded nulls. */
428 for (i = 0; i < bcend;
429 i += strlen((char *)string_data(p1) + i) + 1) {
430 int val = strcoll((char *)string_data(p1) + i,
431 (char *)string_data(p2) + i);
438 #else /* not I18N2, or MULE */
440 Bufbyte *ptr1 = string_data(p1);
441 Bufbyte *ptr2 = string_data(p2);
443 /* #### It is not really necessary to do this: We could compare
444 byte-by-byte and still get a reasonable comparison, since this
445 would compare characters with a charset in the same way. With
446 a little rearrangement of the leading bytes, we could make most
447 inter-charset comparisons work out the same, too; even if some
448 don't, this is not a big deal because inter-charset comparisons
449 aren't really well-defined anyway. */
450 for (i = 0; i < end; i++) {
451 if (charptr_emchar(ptr1) != charptr_emchar(ptr2))
452 return charptr_emchar(ptr1) <
453 charptr_emchar(ptr2) ? Qt : Qnil;
458 #endif /* not I18N2, or MULE */
459 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
460 won't work right in I18N2 case */
461 return end < len2 ? Qt : Qnil;
464 DEFUN("string-greaterp", Fstring_greaterp, 2, 2, 0, /*
465 Return t if first arg string is greater than second in lexicographic order.
466 If I18N2 support (but not Mule support) was compiled in, ordering is
467 determined by the locale. (Case is significant for the default C locale.)
468 In all other cases, comparison is simply done on a character-by-
469 character basis using the numeric value of a character. (Note that
470 this may not produce particularly meaningful results under Mule if
471 characters from different charsets are being compared.)
473 Symbols are also allowed; their print names are used instead.
475 The reason that the I18N2 locale-specific collation is not used under
476 Mule is that the locale model of internationalization does not handle
477 multiple charsets and thus has no hope of working properly under Mule.
478 What we really should do is create a collation table over all built-in
479 charsets. This is extremely difficult to do from scratch, however.
481 Unicode is a good first step towards solving this problem. In fact,
482 it is quite likely that a collation table exists (or will exist) for
483 Unicode. When Unicode support is added to SXEmacs/Mule, this problem
488 return Fstring_lessp(string2, string1);
491 DEFUN("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
492 Return STRING's tick counter, incremented for each change to the string.
493 Each string has a tick counter which is incremented each time the contents
494 of the string are changed (e.g. with `aset'). It wraps around occasionally.
500 CHECK_STRING(string);
502 if (CONSP(s->plist) && INTP(XCAR(s->plist)))
503 return XCAR(s->plist);
508 void bump_string_modiff(Lisp_Object str)
510 Lisp_String *s = XSTRING(str);
511 Lisp_Object *ptr = &s->plist;
514 /* #### remove the `string-translatable' property from the string,
517 /* skip over extent info if it's there */
518 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
520 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
521 XSETINT(XCAR(*ptr), 1 + XINT(XCAR(*ptr)));
523 *ptr = Fcons(make_int(1), *ptr);
526 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector, c_dllist };
527 static Lisp_Object concat(int nargs, Lisp_Object * args,
528 enum concat_target_type target_type,
531 Lisp_Object concat2(Lisp_Object string1, Lisp_Object string2)
536 return concat(2, args, c_string, 0);
540 concat3(Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
546 return concat(3, args, c_string, 0);
549 Lisp_Object vconcat2(Lisp_Object vec1, Lisp_Object vec2)
554 return concat(2, args, c_vector, 0);
557 Lisp_Object vconcat3(Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
563 return concat(3, args, c_vector, 0);
566 DEFUN("append", Fappend, 0, MANY, 0, /*
567 Concatenate all the arguments and make the result a list.
568 The result is a list whose elements are the elements of all the arguments.
569 Each argument may be a list, vector, bit vector, or string.
570 The last argument is not copied, just used as the tail of the new list.
573 (int nargs, Lisp_Object * args))
575 return concat(nargs, args, c_cons, 1);
578 DEFUN("concat", Fconcat, 0, MANY, 0, /*
579 Concatenate all the arguments and make the result a string.
580 The result is a string whose elements are the elements of all the arguments.
581 Each argument may be a string or a list or vector of characters.
583 As of XEmacs 21.0, this function does NOT accept individual integers
584 as arguments. Old code that relies on, for example, (concat "foo" 50)
585 returning "foo50" will fail. To fix such code, either apply
586 `int-to-string' to the integer argument, or use `format'.
588 (int nargs, Lisp_Object * args))
590 return concat(nargs, args, c_string, 0);
593 DEFUN("vconcat", Fvconcat, 0, MANY, 0, /*
594 Concatenate all the arguments and make the result a vector.
595 The result is a vector whose elements are the elements of all the arguments.
596 Each argument may be a list, vector, bit vector, or string.
598 (int nargs, Lisp_Object * args))
600 return concat(nargs, args, c_vector, 0);
603 DEFUN("bvconcat", Fbvconcat, 0, MANY, 0, /*
604 Concatenate all the arguments and make the result a bit vector.
605 The result is a bit vector whose elements are the elements of all the
606 arguments. Each argument may be a list, vector, bit vector, or string.
608 (int nargs, Lisp_Object * args))
610 return concat(nargs, args, c_bit_vector, 0);
613 /* Copy a (possibly dotted) list. LIST must be a cons.
614 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
615 static Lisp_Object copy_list(Lisp_Object list)
617 Lisp_Object list_copy = Fcons(XCAR(list), XCDR(list));
618 Lisp_Object last = list_copy;
619 Lisp_Object hare, tortoise;
622 for (tortoise = hare = XCDR(list), len = 1;
623 CONSP(hare); hare = XCDR(hare), len++) {
624 XCDR(last) = Fcons(XCAR(hare), XCDR(hare));
627 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
630 tortoise = XCDR(tortoise);
631 if (EQ(tortoise, hare))
632 signal_circular_list_error(list);
638 DEFUN("copy-list", Fcopy_list, 1, 1, 0, /*
639 Return a copy of list LIST, which may be a dotted list.
640 The elements of LIST are not copied; they are shared
649 return copy_list(list);
651 list = wrong_type_argument(Qlistp, list);
655 DEFUN("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
656 Return a copy of list, dllist, vector, bit vector or string SEQUENCE.
657 The elements of a list or vector are not copied; they are shared
658 with the original. SEQUENCE may be a dotted list.
666 return copy_list(sequence);
667 if (DLLISTP(sequence))
668 return Fcopy_dllist(sequence);
669 if (STRINGP(sequence))
670 return concat(1, &sequence, c_string, 0);
671 if (VECTORP(sequence))
672 return concat(1, &sequence, c_vector, 0);
673 if (BIT_VECTORP(sequence))
674 return concat(1, &sequence, c_bit_vector, 0);
676 check_losing_bytecode("copy-sequence", sequence);
677 sequence = wrong_type_argument(Qsequencep, sequence);
681 struct merge_string_extents_struct {
683 Bytecount entry_offset;
684 Bytecount entry_length;
688 concat(int nargs, Lisp_Object * args,
689 enum concat_target_type target_type, int last_special)
692 Lisp_Object tail = Qnil;
695 Lisp_Object last_tail;
697 struct merge_string_extents_struct *args_mse = 0;
698 Bufbyte *string_result = NULL;
699 Bufbyte *string_result_ptr = NULL;
701 int speccount = specpdl_depth();
702 Charcount total_length;
705 /* The modus operandi in Emacs is "caller gc-protects args".
706 However, concat is called many times in Emacs on freshly
707 created stuff. So we help those callers out by protecting
708 the args ourselves to save them a lot of temporary-variable
714 /* #### if the result is a string and any of the strings have a string
715 for the `string-translatable' property, then concat should also
716 concat the args but use the `string-translatable' strings, and store
717 the result in the returned string's `string-translatable' property. */
719 if (target_type == c_string)
720 XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
722 /* In append, the last arg isn't treated like the others */
723 if (last_special && nargs > 0) {
725 last_tail = args[nargs];
729 /* Check and coerce the arguments. */
730 for (argnum = 0; argnum < nargs; argnum++) {
731 Lisp_Object seq = args[argnum];
732 if (LISTP(seq) || DLLISTP(seq)) ;
733 else if (VECTORP(seq) || STRINGP(seq) || BIT_VECTORP(seq)) ;
734 #ifdef LOSING_BYTECODE
735 else if (COMPILED_FUNCTIONP(seq))
736 /* Urk! We allow this, for "compatibility"... */
739 #if 0 /* removed for XEmacs 21 */
741 /* This is too revolting to think about but maintains
742 compatibility with FSF (and lots and lots of old code). */
743 args[argnum] = Fnumber_to_string(seq);
746 check_losing_bytecode("concat", seq);
747 args[argnum] = wrong_type_argument(Qsequencep, seq);
752 args_mse[argnum].string = seq;
754 args_mse[argnum].string = Qnil;
759 /* Charcount is a misnomer here as we might be dealing with the
760 length of a vector or list, but emphasizes that we're not dealing
761 with Bytecounts in strings */
762 /* Charcount total_length; */
764 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) {
765 #ifdef LOSING_BYTECODE
767 length_with_bytecode_hack(args[argnum]);
769 Charcount thislen = XINT(Flength(args[argnum]));
771 total_length += thislen;
774 switch (target_type) {
776 if (total_length == 0) {
777 /* In append, if all but last arg are nil,
779 XMALLOC_UNBIND(args_mse, nargs, speccount);
780 RETURN_UNGCPRO(last_tail);
782 val = Fmake_list(make_int(total_length), Qnil);
785 if (total_length == 0) {
786 /* In append, if all but last arg are nil,
788 XMALLOC_UNBIND(args_mse, nargs, speccount);
789 RETURN_UNGCPRO(last_tail);
791 val = Fmake_list(make_int(total_length), Qnil);
794 val = make_vector(total_length, Qnil);
797 val = make_bit_vector(total_length, Qzero);
800 /* We don't make the string yet because we don't know
801 the actual number of bytes. This loop was formerly
802 written to call Fmake_string() here and then call
803 set_string_char() for each char. This seems logical
804 enough but is waaaaaaaay slow -- set_string_char()
805 has to scan the whole string up to the place where
806 the substitution is called for in order to find the
807 place to change, and may have to do some realloc()ing
808 in order to make the char fit properly. O(N^2)
811 XMALLOC_ATOMIC_OR_ALLOCA( string_result,
812 total_length * MAX_EMCHAR_LEN,
814 string_result_ptr = string_result;
823 tail = val, toindex = -1; /* -1 in toindex is flag we are
830 for (argnum = 0; argnum < nargs; argnum++) {
831 Charcount thisleni = 0;
832 Charcount thisindex = 0;
833 Lisp_Object seq = args[argnum];
834 Bufbyte *string_source_ptr = 0;
835 Bufbyte *string_prev_result_ptr = string_result_ptr;
838 #ifdef LOSING_BYTECODE
839 thisleni = length_with_bytecode_hack(seq);
841 thisleni = XINT(Flength(seq));
845 string_source_ptr = XSTRING_DATA(seq);
850 /* We've come to the end of this arg, so exit. */
854 /* Fetch next element of `seq' arg into `elt' */
859 if (thisindex >= thisleni)
864 make_char(charptr_emchar
865 (string_source_ptr));
866 INC_CHARPTR(string_source_ptr);
867 } else if (VECTORP(seq))
868 elt = XVECTOR_DATA(seq)[thisindex];
869 else if (BIT_VECTORP(seq))
871 make_int(bit_vector_bit
875 elt = Felt(seq, make_int(thisindex));
879 /* Store into result */
881 /* toindex negative means we are making a list */
885 } else if (VECTORP(val))
886 XVECTOR_DATA(val)[toindex++] = elt;
887 else if (BIT_VECTORP(val)) {
889 set_bit_vector_bit(XBIT_VECTOR(val), toindex++,
892 CHECK_CHAR_COERCE_INT(elt);
893 if(string_result_ptr != NULL) {
895 set_charptr_emchar(string_result_ptr,
903 args_mse[argnum].entry_offset =
904 string_prev_result_ptr - string_result;
905 args_mse[argnum].entry_length =
906 string_result_ptr - string_prev_result_ptr;
910 /* Now we finally make the string. */
911 if (target_type == c_string) {
913 make_string(string_result,
914 string_result_ptr - string_result);
915 if (args_mse != NULL) {
916 for (argnum = 0; argnum < nargs; argnum++) {
917 if (STRINGP(args_mse[argnum].string))
918 copy_string_extents(val,
919 args_mse[argnum].string,
925 XMALLOC_UNBIND(string_result,
926 total_length * MAX_EMCHAR_LEN, speccount);
927 XMALLOC_UNBIND(args_mse, nargs, speccount);
934 XCDR(prev) = last_tail;
939 DEFUN("copy-alist", Fcopy_alist, 1, 1, 0, /*
940 Return a copy of ALIST.
941 This is an alist which represents the same mapping from objects to objects,
942 but does not share the alist structure with ALIST.
943 The objects mapped (cars and cdrs of elements of the alist)
945 Elements of ALIST that are not conses are also shared.
955 alist = concat(1, &alist, c_cons, 0);
956 for (tail = alist; CONSP(tail); tail = XCDR(tail)) {
957 Lisp_Object car = XCAR(tail);
960 XCAR(tail) = Fcons(XCAR(car), XCDR(car));
965 DEFUN("copy-tree", Fcopy_tree, 1, 2, 0, /*
966 Return a copy of a list and substructures.
967 The argument is copied, and any lists contained within it are copied
968 recursively. Circularities and shared substructures are not preserved.
969 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
974 return safe_copy_tree(arg, vecp, 0);
977 Lisp_Object safe_copy_tree(Lisp_Object arg, Lisp_Object vecp, int depth)
980 signal_simple_error("Stack overflow in copy-tree", arg);
984 rest = arg = Fcopy_sequence(arg);
985 while (CONSP(rest)) {
986 Lisp_Object elt = XCAR(rest);
988 if (CONSP(elt) || VECTORP(elt))
990 safe_copy_tree(elt, vecp, depth + 1);
991 if (VECTORP(XCDR(rest))) /* hack for (a b . [c d]) */
993 safe_copy_tree(XCDR(rest), vecp, depth + 1);
996 } else if (VECTORP(arg) && !NILP(vecp)) {
997 int i = XVECTOR_LENGTH(arg);
999 arg = Fcopy_sequence(arg);
1000 for (j = 0; j < i; j++) {
1001 Lisp_Object elt = XVECTOR_DATA(arg)[j];
1003 if (CONSP(elt) || VECTORP(elt))
1004 XVECTOR_DATA(arg)[j] =
1005 safe_copy_tree(elt, vecp, depth + 1);
1011 DEFUN("substring", Fsubstring, 2, 3, 0, /*
1012 Return the substring of STRING starting at START and ending before END.
1013 END may be nil or omitted; then the substring runs to the end of STRING.
1014 If START or END is negative, it counts from the end.
1015 Relevant parts of the string-extent-data are copied to the new string.
1017 (string, start, end))
1019 Charcount ccstart, ccend;
1020 Bytecount bstart, blen;
1023 CHECK_STRING(string);
1025 get_string_range_char(string, start, end, &ccstart, &ccend,
1026 GB_HISTORICAL_STRING_BEHAVIOR);
1027 bstart = charcount_to_bytecount(XSTRING_DATA(string), ccstart);
1029 charcount_to_bytecount(XSTRING_DATA(string) + bstart,
1031 val = make_string(XSTRING_DATA(string) + bstart, blen);
1032 /* Copy any applicable extent information into the new string. */
1033 copy_string_extents(val, string, 0, bstart, blen);
1037 DEFUN("subseq", Fsubseq, 2, 3, 0, /*
1038 Return the subsequence of SEQUENCE starting at START and ending before END.
1039 END may be omitted; then the subsequence runs to the end of SEQUENCE.
1040 If START or END is negative, it counts from the end.
1041 The returned subsequence is always of the same type as SEQUENCE.
1042 If SEQUENCE is a string, relevant parts of the string-extent-data
1043 are copied to the new string.
1045 (sequence, start, end))
1047 EMACS_INT len, s, e;
1049 if (STRINGP(sequence))
1050 return Fsubstring(sequence, start, end);
1052 len = XINT(Flength(sequence));
1068 if (!(0 <= s && s <= e && e <= len))
1069 args_out_of_range_3(sequence, make_int(s), make_int(e));
1071 if (VECTORP(sequence)) {
1072 Lisp_Object result = make_vector(e - s, Qnil);
1074 Lisp_Object *in_elts = XVECTOR_DATA(sequence);
1075 Lisp_Object *out_elts = XVECTOR_DATA(result);
1077 for (i = s; i < e; i++)
1078 out_elts[i - s] = in_elts[i];
1080 } else if (LISTP(sequence)) {
1081 Lisp_Object result = Qnil;
1084 sequence = Fnthcdr(make_int(s), sequence);
1086 for (i = s; i < e; i++) {
1087 result = Fcons(Fcar(sequence), result);
1088 sequence = Fcdr(sequence);
1091 return Fnreverse(result);
1092 } else if (BIT_VECTORP(sequence)) {
1093 Lisp_Object result = make_bit_vector(e - s, Qzero);
1096 for (i = s; i < e; i++)
1097 set_bit_vector_bit(XBIT_VECTOR(result), i - s,
1098 bit_vector_bit(XBIT_VECTOR(sequence),
1102 abort(); /* unreachable, since Flength (sequence) did not get
1108 DEFUN("nthcdr", Fnthcdr, 2, 2, 0, /*
1109 Take cdr N times on LIST, and return the result.
1114 REGISTER Lisp_Object tail = list;
1116 for (i = XINT(n); i; i--) {
1119 else if (NILP(tail))
1122 tail = wrong_type_argument(Qlistp, tail);
1129 DEFUN("nth", Fnth, 2, 2, 0, /*
1130 Return the Nth element of LIST.
1131 N counts from zero. If LIST is not that long, nil is returned.
1135 return Fcar(Fnthcdr(n, list));
1138 DEFUN("elt", Felt, 2, 2, 0, /*
1139 Return element of SEQUENCE at index N.
1144 if (!(INTP(n) || CHARP(n))) {
1145 n = wrong_type_argument(Qinteger_or_char_p, n);
1149 if (LISTP(sequence)) {
1150 Lisp_Object tem = Fnthcdr(n, sequence);
1151 /* #### Utterly, completely, fucking disgusting.
1152 * #### The whole point of "elt" is that it operates on
1153 * #### sequences, and does error- (bounds-) checking.
1159 /* This is The Way It Has Always Been. */
1162 /* This is The Way Mly and Cltl2 say It Should Be. */
1163 args_out_of_range(sequence, n);
1165 } else if (DLLISTP(sequence)) {
1166 dllist_item_t elm = NULL;
1169 EMACS_INT rn = ent_int(n);
1172 args_out_of_range(sequence, n);
1176 if (rn * 2 < (EMACS_INT)XDLLIST_SIZE(sequence)) {
1177 /* start at the front */
1178 elm = XDLLIST_FIRST(sequence);
1181 /* start at the end */
1182 elm = XDLLIST_LAST(sequence);
1184 i = XDLLIST_SIZE(sequence) - rn - 1;
1187 for (; i > 0 && elm != NULL; i--)
1194 return (Lisp_Object)elm->item;
1198 } else if (STRINGP(sequence) ||
1199 VECTORP(sequence) || BIT_VECTORP(sequence))
1200 return Faref(sequence, n);
1201 #ifdef LOSING_BYTECODE
1202 else if (COMPILED_FUNCTIONP(sequence)) {
1203 EMACS_INT idx = ent_int(n);
1206 args_out_of_range(sequence, n);
1208 /* Utter perversity */
1210 Lisp_Compiled_Function *f =
1211 XCOMPILED_FUNCTION(sequence);
1213 case COMPILED_ARGLIST:
1214 return compiled_function_arglist(f);
1215 case COMPILED_INSTRUCTIONS:
1216 return compiled_function_instructions(f);
1217 case COMPILED_CONSTANTS:
1218 return compiled_function_constants(f);
1219 case COMPILED_STACK_DEPTH:
1220 return compiled_function_stack_depth(f);
1221 case COMPILED_DOC_STRING:
1222 return compiled_function_documentation(f);
1223 case COMPILED_DOMAIN:
1224 return compiled_function_domain(f);
1225 case COMPILED_INTERACTIVE:
1226 if (f->flags.interactivep)
1227 return compiled_function_interactive(f);
1228 /* if we return nil, can't tell interactive with no args
1229 from noninteractive. */
1236 #endif /* LOSING_BYTECODE */
1238 check_losing_bytecode("elt", sequence);
1239 sequence = wrong_type_argument(Qsequencep, sequence);
1244 DEFUN("last", Flast, 1, 2, 0, /*
1245 Return the tail of list LIST, of length N (default 1).
1246 LIST may be a dotted list, but not a circular list.
1247 Optional argument N must be a non-negative integer.
1248 If N is zero, then the atom that terminates the list is returned.
1249 If N is greater than the length of LIST, then LIST itself is returned.
1253 EMACS_INT int_n, count;
1254 Lisp_Object retval, tortoise, hare;
1257 return Fdllist_rac(list);
1268 for (retval = tortoise = hare = list, count = 0;
1271 (int_n-- <= 0 ? ((void)(retval = XCDR(retval))) : (void)0),
1273 if (count < CIRCULAR_LIST_SUSPICION_LENGTH)
1277 tortoise = XCDR(tortoise);
1278 if (EQ(hare, tortoise))
1279 signal_circular_list_error(list);
1285 DEFUN("nbutlast", Fnbutlast, 1, 2, 0, /*
1286 Modify LIST to remove the last N (default 1) elements.
1287 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1303 Lisp_Object last_cons = list;
1305 EXTERNAL_LIST_LOOP_1(list) {
1307 last_cons = XCDR(last_cons);
1313 XCDR(last_cons) = Qnil;
1318 DEFUN("butlast", Fbutlast, 1, 2, 0, /*
1319 Return a copy of LIST with the last N (default 1) elements removed.
1320 If LIST has N or fewer elements, nil is returned.
1336 Lisp_Object retval = Qnil;
1337 Lisp_Object tail = list;
1339 EXTERNAL_LIST_LOOP_1(list) {
1341 retval = Fcons(XCAR(tail), retval);
1346 return Fnreverse(retval);
1350 DEFUN("member", Fmember, 2, 2, 0, /*
1351 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1352 The value is actually the tail of LIST whose car is ELT.
1356 EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1357 if (internal_equal(elt, list_elt, 0))
1363 DEFUN("old-member", Fold_member, 2, 2, 0, /*
1364 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1365 The value is actually the tail of LIST whose car is ELT.
1366 This function is provided only for byte-code compatibility with v19.
1371 EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1372 if (internal_old_equal(elt, list_elt, 0))
1378 DEFUN("memq", Fmemq, 2, 2, 0, /*
1379 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1380 The value is actually the tail of LIST whose car is ELT.
1384 EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1385 if (EQ_WITH_EBOLA_NOTICE(elt, list_elt))
1391 DEFUN("old-memq", Fold_memq, 2, 2, 0, /*
1392 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1393 The value is actually the tail of LIST whose car is ELT.
1394 This function is provided only for byte-code compatibility with v19.
1399 EXTERNAL_LIST_LOOP_3(list_elt, list, tail) {
1400 if (HACKEQ_UNSAFE(elt, list_elt))
1406 Lisp_Object memq_no_quit(Lisp_Object elt, Lisp_Object list)
1408 LIST_LOOP_3(list_elt, list, tail) {
1409 if (EQ_WITH_EBOLA_NOTICE(elt, list_elt))
1415 DEFUN("assoc", Fassoc, 2, 2, 0, /*
1416 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1417 The value is actually the element of ALIST whose car equals KEY.
1421 /* This function can GC. */
1422 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1423 if (internal_equal(key, elt_car, 0))
1429 DEFUN("old-assoc", Fold_assoc, 2, 2, 0, /*
1430 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
1431 The value is actually the element of ALIST whose car equals KEY.
1435 /* This function can GC. */
1436 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1437 if (internal_old_equal(key, elt_car, 0))
1443 Lisp_Object assoc_no_quit(Lisp_Object key, Lisp_Object alist)
1445 int speccount = specpdl_depth();
1446 specbind(Qinhibit_quit, Qt);
1447 return unbind_to(speccount, Fassoc(key, alist));
1450 DEFUN("assq", Fassq, 2, 2, 0, /*
1451 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1452 The value is actually the element of ALIST whose car is KEY.
1453 Elements of ALIST that are not conses are ignored.
1457 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1458 if (EQ_WITH_EBOLA_NOTICE(key, elt_car))
1464 DEFUN("old-assq", Fold_assq, 2, 2, 0, /*
1465 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
1466 The value is actually the element of ALIST whose car is KEY.
1467 Elements of ALIST that are not conses are ignored.
1468 This function is provided only for byte-code compatibility with v19.
1473 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1474 if (HACKEQ_UNSAFE(key, elt_car))
1480 /* Like Fassq but never report an error and do not allow quits.
1481 Use only on lists known never to be circular. */
1483 Lisp_Object assq_no_quit(Lisp_Object key, Lisp_Object alist)
1485 /* This cannot GC. */
1486 LIST_LOOP_2(elt, alist) {
1487 Lisp_Object elt_car = XCAR(elt);
1488 if (EQ_WITH_EBOLA_NOTICE(key, elt_car))
1494 DEFUN("rassoc", Frassoc, 2, 2, 0, /*
1495 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1496 The value is actually the element of ALIST whose cdr equals VALUE.
1500 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1501 if (internal_equal(value, elt_cdr, 0))
1507 DEFUN("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1508 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
1509 The value is actually the element of ALIST whose cdr equals VALUE.
1513 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1514 if (internal_old_equal(value, elt_cdr, 0))
1520 DEFUN("rassq", Frassq, 2, 2, 0, /*
1521 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1522 The value is actually the element of ALIST whose cdr is VALUE.
1526 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1527 if (EQ_WITH_EBOLA_NOTICE(value, elt_cdr))
1533 DEFUN("old-rassq", Fold_rassq, 2, 2, 0, /*
1534 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
1535 The value is actually the element of ALIST whose cdr is VALUE.
1539 EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, alist) {
1540 if (HACKEQ_UNSAFE(value, elt_cdr))
1546 /* Like Frassq, but caller must ensure that ALIST is properly
1547 nil-terminated and ebola-free. */
1548 Lisp_Object rassq_no_quit(Lisp_Object value, Lisp_Object alist)
1550 LIST_LOOP_2(elt, alist) {
1551 Lisp_Object elt_cdr = XCDR(elt);
1552 if (EQ_WITH_EBOLA_NOTICE(value, elt_cdr))
1558 DEFUN("delete", Fdelete, 2, 2, 0, /*
1559 Delete by side effect any occurrences of ELT as a member of LIST.
1560 The modified LIST is returned. Comparison is done with `equal'.
1561 If the first member of LIST is ELT, there is no way to remove it by side
1562 effect; therefore, write `(setq foo (delete element foo))' to be sure
1563 of changing the value of `foo'.
1568 EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1569 (internal_equal(elt, list_elt, 0)));
1573 DEFUN("old-delete", Fold_delete, 2, 2, 0, /*
1574 Delete by side effect any occurrences of ELT as a member of LIST.
1575 The modified LIST is returned. Comparison is done with `old-equal'.
1576 If the first member of LIST is ELT, there is no way to remove it by side
1577 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1578 of changing the value of `foo'.
1582 EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1583 (internal_old_equal(elt, list_elt, 0)));
1587 DEFUN("delq", Fdelq, 2, 2, 0, /*
1588 Delete by side effect any occurrences of ELT as a member of LIST.
1589 The modified LIST is returned. Comparison is done with `eq'.
1590 If the first member of LIST is ELT, there is no way to remove it by side
1591 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1592 changing the value of `foo'.
1596 EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1597 (EQ_WITH_EBOLA_NOTICE(elt, list_elt)));
1601 DEFUN("old-delq", Fold_delq, 2, 2, 0, /*
1602 Delete by side effect any occurrences of ELT as a member of LIST.
1603 The modified LIST is returned. Comparison is done with `old-eq'.
1604 If the first member of LIST is ELT, there is no way to remove it by side
1605 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1606 changing the value of `foo'.
1610 EXTERNAL_LIST_LOOP_DELETE_IF(list_elt, list,
1611 (HACKEQ_UNSAFE(elt, list_elt)));
1615 /* Like Fdelq, but caller must ensure that LIST is properly
1616 nil-terminated and ebola-free. */
1618 Lisp_Object delq_no_quit(Lisp_Object elt, Lisp_Object list)
1620 LIST_LOOP_DELETE_IF(list_elt, list,
1621 (EQ_WITH_EBOLA_NOTICE(elt, list_elt)));
1625 /* Be VERY careful with this. This is like delq_no_quit() but
1626 also calls free_cons() on the removed conses. You must be SURE
1627 that no pointers to the freed conses remain around (e.g.
1628 someone else is pointing to part of the list). This function
1629 is useful on internal lists that are used frequently and where
1630 the actual list doesn't escape beyond known code bounds. */
1632 Lisp_Object delq_no_quit_and_free_cons(Lisp_Object elt, Lisp_Object list)
1634 REGISTER Lisp_Object tail = list;
1635 REGISTER Lisp_Object prev = Qnil;
1637 while (!NILP(tail)) {
1638 REGISTER Lisp_Object tem = XCAR(tail);
1640 Lisp_Object cons_to_free = tail;
1644 XCDR(prev) = XCDR(tail);
1646 free_cons(XCONS(cons_to_free));
1655 DEFUN("remassoc", Fremassoc, 2, 2, 0, /*
1656 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
1657 The modified ALIST is returned. If the first member of ALIST has a car
1658 that is `equal' to KEY, there is no way to remove it by side effect;
1659 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1664 EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1666 internal_equal(key, XCAR(elt), 0)));
1670 Lisp_Object remassoc_no_quit(Lisp_Object key, Lisp_Object alist)
1672 int speccount = specpdl_depth();
1673 specbind(Qinhibit_quit, Qt);
1674 return unbind_to(speccount, Fremassoc(key, alist));
1677 DEFUN("remassq", Fremassq, 2, 2, 0, /*
1678 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
1679 The modified ALIST is returned. If the first member of ALIST has a car
1680 that is `eq' to KEY, there is no way to remove it by side effect;
1681 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1686 EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1688 EQ_WITH_EBOLA_NOTICE(key, XCAR(elt))));
1692 /* no quit, no errors; be careful */
1694 Lisp_Object remassq_no_quit(Lisp_Object key, Lisp_Object alist)
1696 LIST_LOOP_DELETE_IF(elt, alist,
1698 EQ_WITH_EBOLA_NOTICE(key, XCAR(elt))));
1702 DEFUN("remrassoc", Fremrassoc, 2, 2, 0, /*
1703 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
1704 The modified ALIST is returned. If the first member of ALIST has a car
1705 that is `equal' to VALUE, there is no way to remove it by side effect;
1706 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1711 EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1713 internal_equal(value, XCDR(elt), 0)));
1717 DEFUN("remrassq", Fremrassq, 2, 2, 0, /*
1718 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
1719 The modified ALIST is returned. If the first member of ALIST has a car
1720 that is `eq' to VALUE, there is no way to remove it by side effect;
1721 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1726 EXTERNAL_LIST_LOOP_DELETE_IF(elt, alist,
1728 EQ_WITH_EBOLA_NOTICE(value, XCDR(elt))));
1732 /* Like Fremrassq, fast and unsafe; be careful */
1733 Lisp_Object remrassq_no_quit(Lisp_Object value, Lisp_Object alist)
1735 LIST_LOOP_DELETE_IF(elt, alist,
1737 EQ_WITH_EBOLA_NOTICE(value, XCDR(elt))));
1741 DEFUN("nreverse", Fnreverse, 1, 1, 0, /*
1742 Reverse LIST by destructively modifying cdr pointers.
1743 Return the beginning of the reversed list.
1744 Also see: `reverse'.
1748 struct gcpro gcpro1, gcpro2;
1749 REGISTER Lisp_Object prev = Qnil;
1750 REGISTER Lisp_Object tail = list;
1752 /* We gcpro our args; see `nconc' */
1754 while (!NILP(tail)) {
1755 REGISTER Lisp_Object next;
1756 CONCHECK_CONS(tail);
1766 DEFUN("reverse", Freverse, 1, 1, 0, /*
1767 Reverse LIST, copying. Return the beginning of the reversed list.
1768 See also the function `nreverse', which is used more often.
1772 Lisp_Object reversed_list = Qnil;
1773 EXTERNAL_LIST_LOOP_2(elt, list) {
1774 reversed_list = Fcons(elt, reversed_list);
1776 return reversed_list;
1779 static Lisp_Object list_merge(Lisp_Object org_l1, Lisp_Object org_l2,
1780 Lisp_Object lisp_arg,
1781 int (*pred_fn) (Lisp_Object, Lisp_Object,
1782 Lisp_Object lisp_arg));
1785 list_sort(Lisp_Object list,
1786 Lisp_Object lisp_arg,
1787 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1789 struct gcpro gcpro1, gcpro2, gcpro3;
1790 Lisp_Object back, tem;
1791 Lisp_Object front = list;
1792 Lisp_Object len = Flength(list);
1797 len = make_int(XINT(len) / 2 - 1);
1798 tem = Fnthcdr(len, list);
1802 GCPRO3(front, back, lisp_arg);
1803 front = list_sort(front, lisp_arg, pred_fn);
1804 back = list_sort(back, lisp_arg, pred_fn);
1806 return list_merge(front, back, lisp_arg, pred_fn);
1810 merge_pred_function(Lisp_Object obj1, Lisp_Object obj2, Lisp_Object pred)
1814 /* prevents the GC from happening in call2 */
1815 int speccount = specpdl_depth();
1816 /* Emacs' GC doesn't actually relocate pointers, so this probably
1817 isn't strictly necessary */
1818 record_unwind_protect(restore_gc_inhibit,
1819 make_int(gc_currently_forbidden));
1820 gc_currently_forbidden = 1;
1821 tmp = call2(pred, obj1, obj2);
1822 unbind_to(speccount, Qnil);
1830 DEFUN("sort", Fsort, 2, 2, 0, /*
1831 Sort LIST, stably, comparing elements using PREDICATE.
1832 Returns the sorted list. LIST is modified by side effects.
1833 PREDICATE is called with two elements of LIST, and should return T
1834 if the first element is "less" than the second.
1838 return list_sort(list, predicate, merge_pred_function);
1841 Lisp_Object merge(Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1843 return list_merge(org_l1, org_l2, pred, merge_pred_function);
1847 list_merge(Lisp_Object org_l1, Lisp_Object org_l2,
1848 Lisp_Object lisp_arg,
1849 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1855 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1862 /* It is sufficient to protect org_l1 and org_l2.
1863 When l1 and l2 are updated, we copy the new values
1864 back into the org_ vars. */
1866 GCPRO4(org_l1, org_l2, lisp_arg, value);
1884 if (((*pred_fn) (Fcar(l2), Fcar(l1), lisp_arg)) < 0) {
1901 /************************************************************************/
1902 /* property-list functions */
1903 /************************************************************************/
1905 /* For properties of text, we need to do order-insensitive comparison of
1906 plists. That is, we need to compare two plists such that they are the
1907 same if they have the same set of keys, and equivalent values.
1908 So (a 1 b 2) would be equal to (b 2 a 1).
1910 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1911 LAXP means use `equal' for comparisons.
1914 plists_differ(Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1915 int laxp, int depth)
1917 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1918 int la, lb, m, i, fill;
1919 Lisp_Object *keys, *vals;
1922 int speccount = specpdl_depth();
1924 if (NILP(a) && NILP(b))
1927 Fcheck_valid_plist(a);
1928 Fcheck_valid_plist(b);
1930 la = XINT(Flength(a));
1931 lb = XINT(Flength(b));
1932 m = (la > lb ? la : lb);
1934 XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
1935 XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
1936 XMALLOC_ATOMIC_OR_ALLOCA(flags, m, char);
1938 /* First extract the pairs from A. */
1939 for (rest = a; !NILP(rest); rest = XCDR(XCDR(rest))) {
1940 Lisp_Object k = XCAR(rest);
1941 Lisp_Object v = XCAR(XCDR(rest));
1942 /* Maybe be Ebolified. */
1943 if (nil_means_not_present && NILP(v))
1950 /* Now iterate over B, and stop if we find something that's not in A,
1951 or that doesn't match. As we match, mark them. */
1952 for (rest = b; !NILP(rest); rest = XCDR(XCDR(rest))) {
1953 Lisp_Object k = XCAR(rest);
1954 Lisp_Object v = XCAR(XCDR(rest));
1955 /* Maybe be Ebolified. */
1956 if (nil_means_not_present && NILP(v))
1958 for (i = 0; i < fill; i++) {
1959 if (!laxp ? EQ(k, keys[i]) :
1960 internal_equal(k, keys[i], depth)) {
1962 /* We narrowly escaped being Ebolified
1964 ? !EQ_WITH_EBOLA_NOTICE(v, vals[i])
1965 : !internal_equal(v, vals[i], depth))
1966 /* a property in B has a different value
1974 /* there are some properties in B that are not in A */
1977 /* Now check to see that all the properties in A were also in B */
1978 for (i = 0; i < fill; i++)
1982 XMALLOC_UNBIND(flags, m, speccount);
1983 XMALLOC_UNBIND(vals, m, speccount);
1984 XMALLOC_UNBIND(keys, m, speccount);
1989 XMALLOC_UNBIND(flags, m, speccount);
1990 XMALLOC_UNBIND(vals, m, speccount);
1991 XMALLOC_UNBIND(keys, m, speccount);
1995 DEFUN("plists-eq", Fplists_eq, 2, 3, 0, /*
1996 Return non-nil if property lists A and B are `eq'.
1997 A property list is an alternating list of keywords and values.
1998 This function does order-insensitive comparisons of the property lists:
1999 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2000 Comparison between values is done using `eq'. See also `plists-equal'.
2001 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2002 a nil value is ignored. This feature is a virus that has infected
2003 old Lisp implementations, but should not be used except for backward
2006 (a, b, nil_means_not_present))
2008 return (plists_differ(a, b, !NILP(nil_means_not_present), 0, -1)
2012 DEFUN("plists-equal", Fplists_equal, 2, 3, 0, /*
2013 Return non-nil if property lists A and B are `equal'.
2014 A property list is an alternating list of keywords and values. This
2015 function does order-insensitive comparisons of the property lists: For
2016 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2017 Comparison between values is done using `equal'. See also `plists-eq'.
2018 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2019 a nil value is ignored. This feature is a virus that has infected
2020 old Lisp implementations, but should not be used except for backward
2023 (a, b, nil_means_not_present))
2025 return (plists_differ(a, b, !NILP(nil_means_not_present), 0, 1)
2029 DEFUN("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
2030 Return non-nil if lax property lists A and B are `eq'.
2031 A property list is an alternating list of keywords and values.
2032 This function does order-insensitive comparisons of the property lists:
2033 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2034 Comparison between values is done using `eq'. See also `plists-equal'.
2035 A lax property list is like a regular one except that comparisons between
2036 keywords is done using `equal' instead of `eq'.
2037 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2038 a nil value is ignored. This feature is a virus that has infected
2039 old Lisp implementations, but should not be used except for backward
2042 (a, b, nil_means_not_present))
2044 return (plists_differ(a, b, !NILP(nil_means_not_present), 1, -1)
2048 DEFUN("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2049 Return non-nil if lax property lists A and B are `equal'.
2050 A property list is an alternating list of keywords and values. This
2051 function does order-insensitive comparisons of the property lists: For
2052 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2053 Comparison between values is done using `equal'. See also `plists-eq'.
2054 A lax property list is like a regular one except that comparisons between
2055 keywords is done using `equal' instead of `eq'.
2056 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2057 a nil value is ignored. This feature is a virus that has infected
2058 old Lisp implementations, but should not be used except for backward
2061 (a, b, nil_means_not_present))
2063 return (plists_differ(a, b, !NILP(nil_means_not_present), 1, 1)
2067 /* Return the value associated with key PROPERTY in property list PLIST.
2068 Return nil if key not found. This function is used for internal
2069 property lists that cannot be directly manipulated by the user.
2072 Lisp_Object internal_plist_get(Lisp_Object plist, Lisp_Object property)
2076 for (tail = plist; !NILP(tail); tail = XCDR(XCDR(tail))) {
2077 if (EQ(XCAR(tail), property))
2078 return XCAR(XCDR(tail));
2084 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2085 internal_plist_get(). */
2088 internal_plist_put(Lisp_Object * plist, Lisp_Object property, Lisp_Object value)
2092 for (tail = *plist; !NILP(tail); tail = XCDR(XCDR(tail))) {
2093 if (EQ(XCAR(tail), property)) {
2094 XCAR(XCDR(tail)) = value;
2099 *plist = Fcons(property, Fcons(value, *plist));
2102 int internal_remprop(Lisp_Object * plist, Lisp_Object property)
2104 Lisp_Object tail, prev;
2106 for (tail = *plist, prev = Qnil; !NILP(tail); tail = XCDR(XCDR(tail))) {
2107 if (EQ(XCAR(tail), property)) {
2109 *plist = XCDR(XCDR(tail));
2111 XCDR(XCDR(prev)) = XCDR(XCDR(tail));
2120 /* Called on a malformed property list. BADPLACE should be some
2121 place where truncating will form a good list -- i.e. we shouldn't
2122 result in a list with an odd length. */
2125 bad_bad_bunny(Lisp_Object * plist, Lisp_Object * badplace, Error_behavior errb)
2127 if (ERRB_EQ(errb, ERROR_ME))
2128 return Fsignal(Qmalformed_property_list,
2129 list2(*plist, *badplace));
2131 if (ERRB_EQ(errb, ERROR_ME_WARN)) {
2132 warn_when_safe_lispobj
2135 ("Malformed property list -- list has been truncated"),
2143 /* Called on a circular property list. BADPLACE should be some place
2144 where truncating will result in an even-length list, as above.
2145 If doesn't particularly matter where we truncate -- anywhere we
2146 truncate along the entire list will break the circularity, because
2147 it will create a terminus and the list currently doesn't have one.
2151 bad_bad_turtle(Lisp_Object * plist, Lisp_Object * badplace, Error_behavior errb)
2153 if (ERRB_EQ(errb, ERROR_ME))
2154 return Fsignal(Qcircular_property_list, list1(*plist));
2156 if (ERRB_EQ(errb, ERROR_ME_WARN)) {
2157 warn_when_safe_lispobj
2160 ("Circular property list -- list has been truncated"),
2168 /* Advance the tortoise pointer by two (one iteration of a property-list
2169 loop) and the hare pointer by four and verify that no malformations
2170 or circularities exist. If so, return zero and store a value into
2171 RETVAL that should be returned by the calling function. Otherwise,
2172 return 1. See external_plist_get().
2176 advance_plist_pointers(Lisp_Object * plist,
2177 Lisp_Object ** tortoise, Lisp_Object ** hare,
2178 Error_behavior errb, Lisp_Object * retval)
2181 Lisp_Object *tortsave = *tortoise;
2183 /* Note that our "fixing" may be more brutal than necessary,
2184 but it's the user's own problem, not ours, if they went in and
2185 manually fucked up a plist. */
2187 for (i = 0; i < 2; i++) {
2188 /* This is a standard iteration of a defensive-loop-checking
2189 loop. We just do it twice because we want to advance past
2190 both the property and its value.
2192 If the pointer indirection is confusing you, remember that
2193 one level of indirection on the hare and tortoise pointers
2194 is only due to pass-by-reference for this function. The other
2195 level is so that the plist can be fixed in place. */
2197 /* When we reach the end of a well-formed plist, **HARE is
2198 nil. In that case, we don't do anything at all except
2199 advance TORTOISE by one. Otherwise, we advance HARE
2200 by two (making sure it's OK to do so), then advance
2201 TORTOISE by one (it will always be OK to do so because
2202 the HARE is always ahead of the TORTOISE and will have
2203 already verified the path), then make sure TORTOISE and
2204 HARE don't contain the same non-nil object -- if the
2205 TORTOISE and the HARE ever meet, then obviously we're
2206 in a circularity, and if we're in a circularity, then
2207 the TORTOISE and the HARE can't cross paths without
2208 meeting, since the HARE only gains one step over the
2209 TORTOISE per iteration. */
2211 if (!NILP(**hare)) {
2212 Lisp_Object *haresave = *hare;
2213 if (!CONSP(**hare)) {
2214 *retval = bad_bad_bunny(plist, haresave, errb);
2217 *hare = &XCDR(**hare);
2218 /* In a non-plist, we'd check here for a nil value for
2219 **HARE, which is OK (it just means the list has an
2220 odd number of elements). In a plist, it's not OK
2221 for the list to have an odd number of elements. */
2222 if (!CONSP(**hare)) {
2223 *retval = bad_bad_bunny(plist, haresave, errb);
2226 *hare = &XCDR(**hare);
2229 *tortoise = &XCDR(**tortoise);
2230 if (!NILP(**hare) && EQ(**tortoise, **hare)) {
2231 *retval = bad_bad_turtle(plist, tortsave, errb);
2239 /* Return the value of PROPERTY from PLIST, or Qunbound if
2240 property is not on the list.
2242 PLIST is a Lisp-accessible property list, meaning that it
2243 has to be checked for malformations and circularities.
2245 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2246 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2247 on finding a malformation or a circularity, it issues a warning and
2248 attempts to silently fix the problem.
2250 A pointer to PLIST is passed in so that PLIST can be successfully
2251 "fixed" even if the error is at the beginning of the plist. */
2254 external_plist_get(Lisp_Object * plist, Lisp_Object property,
2255 int laxp, Error_behavior errb)
2257 Lisp_Object *tortoise = plist;
2258 Lisp_Object *hare = plist;
2260 while (!NILP(*tortoise)) {
2261 Lisp_Object *tortsave = tortoise;
2264 /* We do the standard tortoise/hare march. We isolate the
2265 grungy stuff to do this in advance_plist_pointers(), though.
2266 To us, all this function does is advance the tortoise
2267 pointer by two and the hare pointer by four and make sure
2268 everything's OK. We first advance the pointers and then
2269 check if a property matched; this ensures that our
2270 check for a matching property is safe. */
2272 if (!advance_plist_pointers
2273 (plist, &tortoise, &hare, errb, &retval))
2276 if (!laxp ? EQ(XCAR(*tortsave), property)
2277 : internal_equal(XCAR(*tortsave), property, 0))
2278 return XCAR(XCDR(*tortsave));
2284 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2285 malformed or circular plist. Analogous to external_plist_get(). */
2288 external_plist_put(Lisp_Object * plist, Lisp_Object property,
2289 Lisp_Object value, int laxp, Error_behavior errb)
2291 Lisp_Object *tortoise = plist;
2292 Lisp_Object *hare = plist;
2294 while (!NILP(*tortoise)) {
2295 Lisp_Object *tortsave = tortoise;
2299 if (!advance_plist_pointers
2300 (plist, &tortoise, &hare, errb, &retval))
2303 if (!laxp ? EQ(XCAR(*tortsave), property)
2304 : internal_equal(XCAR(*tortsave), property, 0)) {
2305 XCAR(XCDR(*tortsave)) = value;
2310 *plist = Fcons(property, Fcons(value, *plist));
2314 external_remprop(Lisp_Object * plist, Lisp_Object property,
2315 int laxp, Error_behavior errb)
2317 Lisp_Object *tortoise = plist;
2318 Lisp_Object *hare = plist;
2320 while (!NILP(*tortoise)) {
2321 Lisp_Object *tortsave = tortoise;
2325 if (!advance_plist_pointers
2326 (plist, &tortoise, &hare, errb, &retval))
2329 if (!laxp ? EQ(XCAR(*tortsave), property)
2330 : internal_equal(XCAR(*tortsave), property, 0)) {
2331 /* Now you see why it's so convenient to have that level
2333 *tortsave = XCDR(XCDR(*tortsave));
2341 DEFUN("plist-get", Fplist_get, 2, 3, 0, /*
2342 Extract a value from a property list.
2343 PLIST is a property list, which is a list of the form
2344 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
2345 PROPERTY is usually a symbol.
2346 This function returns the value corresponding to the PROPERTY,
2347 or DEFAULT if PROPERTY is not one of the properties on the list.
2349 (plist, property, default_))
2351 Lisp_Object value = external_plist_get(&plist, property, 0, ERROR_ME);
2352 return UNBOUNDP(value) ? default_ : value;
2355 DEFUN("plist-put", Fplist_put, 3, 3, 0, /*
2356 Change value in PLIST of PROPERTY to VALUE.
2357 PLIST is a property list, which is a list of the form
2358 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2359 PROPERTY is usually a symbol and VALUE is any object.
2360 If PROPERTY is already a property on the list, its value is set to VALUE,
2361 otherwise the new PROPERTY VALUE pair is added.
2362 The new plist is returned; use `(setq x (plist-put x property value))'
2363 to be sure to use the new value. PLIST is modified by side effect.
2365 (plist, property, value))
2367 external_plist_put(&plist, property, value, 0, ERROR_ME);
2371 DEFUN("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2372 Remove from PLIST the property PROPERTY and its value.
2373 PLIST is a property list, which is a list of the form
2374 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
2375 PROPERTY is usually a symbol.
2376 The new plist is returned; use `(setq x (plist-remprop x property))'
2377 to be sure to use the new value. PLIST is modified by side effect.
2381 external_remprop(&plist, property, 0, ERROR_ME);
2385 DEFUN("plist-member", Fplist_member, 2, 2, 0, /*
2386 Return t if PROPERTY has a value specified in PLIST.
2390 Lisp_Object value = Fplist_get(plist, property, Qunbound);
2391 return UNBOUNDP(value) ? Qnil : Qt;
2394 DEFUN("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2395 Given a plist, signal an error if there is anything wrong with it.
2396 This means that it's a malformed or circular plist.
2400 Lisp_Object *tortoise;
2406 while (!NILP(*tortoise)) {
2410 if (!advance_plist_pointers(&plist, &tortoise, &hare, ERROR_ME,
2418 DEFUN("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2419 Given a plist, return non-nil if its format is correct.
2420 If it returns nil, `check-valid-plist' will signal an error when given
2421 the plist; that means it's a malformed or circular plist.
2425 Lisp_Object *tortoise;
2430 while (!NILP(*tortoise)) {
2434 if (!advance_plist_pointers
2435 (&plist, &tortoise, &hare, ERROR_ME_NOT, &retval))
2442 DEFUN("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2443 Destructively remove any duplicate entries from a plist.
2444 In such cases, the first entry applies.
2446 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2447 a nil value is removed. This feature is a virus that has infected
2448 old Lisp implementations, but should not be used except for backward
2451 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2452 return value may not be EQ to the passed-in value, so make sure to
2453 `setq' the value back into where it came from.
2455 (plist, nil_means_not_present))
2457 Lisp_Object head = plist;
2459 Fcheck_valid_plist(plist);
2461 while (!NILP(plist)) {
2462 Lisp_Object prop = Fcar(plist);
2463 Lisp_Object next = Fcdr(plist);
2465 CHECK_CONS(next); /* just make doubly sure we catch any errors */
2466 if (!NILP(nil_means_not_present) && NILP(Fcar(next))) {
2467 if (EQ(head, plist))
2472 /* external_remprop returns 1 if it removed any property.
2473 We have to loop till it didn't remove anything, in case
2474 the property occurs many times. */
2475 while (external_remprop(&XCDR(next), prop, 0, ERROR_ME))
2483 DEFUN("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2484 Extract a value from a lax property list.
2485 LAX-PLIST is a lax property list, which is a list of the form
2486 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2487 properties is done using `equal' instead of `eq'.
2488 PROPERTY is usually a symbol.
2489 This function returns the value corresponding to PROPERTY,
2490 or DEFAULT if PROPERTY is not one of the properties on the list.
2492 (lax_plist, property, default_))
2495 external_plist_get(&lax_plist, property, 1, ERROR_ME);
2496 return UNBOUNDP(value) ? default_ : value;
2499 DEFUN("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2500 Change value in LAX-PLIST of PROPERTY to VALUE.
2501 LAX-PLIST is a lax property list, which is a list of the form
2502 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2503 properties is done using `equal' instead of `eq'.
2504 PROPERTY is usually a symbol and VALUE is any object.
2505 If PROPERTY is already a property on the list, its value is set to
2506 VALUE, otherwise the new PROPERTY VALUE pair is added.
2507 The new plist is returned; use `(setq x (lax-plist-put x property value))'
2508 to be sure to use the new value. LAX-PLIST is modified by side effect.
2510 (lax_plist, property, value))
2512 external_plist_put(&lax_plist, property, value, 1, ERROR_ME);
2516 DEFUN("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2517 Remove from LAX-PLIST the property PROPERTY and its value.
2518 LAX-PLIST is a lax property list, which is a list of the form
2519 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2520 properties is done using `equal' instead of `eq'.
2521 PROPERTY is usually a symbol.
2522 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
2523 to be sure to use the new value. LAX-PLIST is modified by side effect.
2525 (lax_plist, property))
2527 external_remprop(&lax_plist, property, 1, ERROR_ME);
2531 DEFUN("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2532 Return t if PROPERTY has a value specified in LAX-PLIST.
2533 LAX-PLIST is a lax property list, which is a list of the form
2534 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
2535 properties is done using `equal' instead of `eq'.
2537 (lax_plist, property))
2539 return UNBOUNDP(Flax_plist_get(lax_plist, property, Qunbound)) ? Qnil :
2543 DEFUN("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2544 Destructively remove any duplicate entries from a lax plist.
2545 In such cases, the first entry applies.
2547 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2548 a nil value is removed. This feature is a virus that has infected
2549 old Lisp implementations, but should not be used except for backward
2552 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2553 return value may not be EQ to the passed-in value, so make sure to
2554 `setq' the value back into where it came from.
2556 (lax_plist, nil_means_not_present))
2558 Lisp_Object head = lax_plist;
2560 Fcheck_valid_plist(lax_plist);
2562 while (!NILP(lax_plist)) {
2563 Lisp_Object prop = Fcar(lax_plist);
2564 Lisp_Object next = Fcdr(lax_plist);
2566 CHECK_CONS(next); /* just make doubly sure we catch any errors */
2567 if (!NILP(nil_means_not_present) && NILP(Fcar(next))) {
2568 if (EQ(head, lax_plist))
2570 lax_plist = Fcdr(next);
2573 /* external_remprop returns 1 if it removed any property.
2574 We have to loop till it didn't remove anything, in case
2575 the property occurs many times. */
2576 while (external_remprop(&XCDR(next), prop, 1, ERROR_ME))
2578 lax_plist = Fcdr(next);
2584 /* In C because the frame props stuff uses it */
2586 DEFUN("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2587 Convert association list ALIST into the equivalent property-list form.
2588 The plist is returned. This converts from
2590 \((a . 1) (b . 2) (c . 3))
2596 The original alist is destroyed in the process of constructing the plist.
2597 See also `alist-to-plist'.
2601 Lisp_Object head = alist;
2602 while (!NILP(alist)) {
2603 /* remember the alist element. */
2604 Lisp_Object el = Fcar(alist);
2606 Fsetcar(alist, Fcar(el));
2607 Fsetcar(el, Fcdr(el));
2608 Fsetcdr(el, Fcdr(alist));
2610 alist = Fcdr(Fcdr(alist));
2616 DEFUN("get", Fget, 2, 3, 0, /*
2617 Return the value of OBJECT's PROPERTY property.
2618 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2619 If there is no such property, return optional third arg DEFAULT
2620 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2621 face, or glyph. See also `put', `remprop', and `object-plist'.
2623 (object, property, default_))
2625 /* Various places in emacs call Fget() and expect it not to quit,
2629 if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->getprop)
2631 XRECORD_LHEADER_IMPLEMENTATION(object)->getprop(object,
2634 signal_simple_error("Object type has no properties", object);
2636 return UNBOUNDP(val) ? default_ : val;
2639 DEFUN("put", Fput, 3, 3, 0, /*
2640 Set OBJECT's PROPERTY to VALUE.
2641 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2642 OBJECT can be a symbol, face, extent, or string.
2643 For a string, no properties currently have predefined meanings.
2644 For the predefined properties for extents, see `set-extent-property'.
2645 For the predefined properties for faces, see `set-face-property'.
2646 See also `get', `remprop', and `object-plist'.
2648 (object, property, value))
2650 CHECK_LISP_WRITEABLE(object);
2652 if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->putprop) {
2653 if (!XRECORD_LHEADER_IMPLEMENTATION(object)->putprop
2654 (object, property, value))
2655 signal_simple_error("Can't set property on object",
2658 signal_simple_error("Object type has no settable properties",
2664 DEFUN("remprop", Fremprop, 2, 2, 0, /*
2665 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2666 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2667 if the property list was actually modified (i.e. if PROPERTY was present
2668 in the property list). See also `get', `put', and `object-plist'.
2674 CHECK_LISP_WRITEABLE(object);
2676 if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->remprop) {
2678 XRECORD_LHEADER_IMPLEMENTATION(object)->remprop(object,
2681 signal_simple_error("Can't remove property from object",
2684 signal_simple_error("Object type has no removable properties",
2687 return ret ? Qt : Qnil;
2690 DEFUN("object-plist", Fobject_plist, 1, 1, 0, /*
2691 Return a property list of OBJECT's properties.
2692 For a symbol, this is equivalent to `symbol-plist'.
2693 OBJECT can be a symbol, string, extent, face, or glyph.
2694 Do not modify the returned property list directly;
2695 this may or may not have the desired effects. Use `put' instead.
2699 if (LRECORDP(object) && XRECORD_LHEADER_IMPLEMENTATION(object)->plist)
2700 return XRECORD_LHEADER_IMPLEMENTATION(object)->plist(object);
2702 signal_simple_error("Object type has no properties", object);
2707 int internal_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2710 error("Stack overflow in equal");
2712 if (EQ_WITH_EBOLA_NOTICE(obj1, obj2))
2714 /* Note that (equal 20 20.0) should be nil */
2715 if (XTYPE(obj1) != XTYPE(obj2))
2717 if (LRECORDP(obj1)) {
2718 const struct lrecord_implementation
2719 *imp1 = XRECORD_LHEADER_IMPLEMENTATION(obj1),
2720 *imp2 = XRECORD_LHEADER_IMPLEMENTATION(obj2);
2722 return (imp1 == imp2) &&
2723 /* EQ-ness of the objects was noticed above */
2724 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2731 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2734 error ("Stack overflow in equalp");
2736 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2739 if (NUMBERP(obj1) && NUMBERP(obj2)) {
2740 return ent_binrel(ASE_BINARY_REL_EQUALP, obj1, obj2);
2743 if (CHARP(obj1) && CHARP(obj2))
2744 return XCHAR(obj1) == XCHAR(obj2);
2745 if (XTYPE(obj1) != XTYPE(obj2))
2747 if (LRECORDP(obj1)) {
2748 const struct lrecord_implementation
2749 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2750 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2752 /* #### not yet implemented properly, needs another flag to specify
2754 return (imp1 == imp2) &&
2755 /* EQ-ness of the objects was noticed above */
2756 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2763 /* Note that we may be calling sub-objects that will use
2764 internal_equal() (instead of internal_old_equal()). Oh well.
2765 We will get an Ebola note if there's any possibility of confusion,
2766 but that seems unlikely. */
2768 static int internal_old_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2771 error("Stack overflow in equal");
2773 if (HACKEQ_UNSAFE(obj1, obj2))
2775 /* Note that (equal 20 20.0) should be nil */
2776 if (XTYPE(obj1) != XTYPE(obj2))
2779 return internal_equal(obj1, obj2, depth);
2782 DEFUN("equal", Fequal, 2, 2, 0, /*
2783 Return t if two Lisp objects have similar structure and contents.
2784 They must have the same data type.
2785 Conses are compared by comparing the cars and the cdrs.
2786 Vectors and strings are compared element by element.
2787 Numbers are compared by value. Symbols must match exactly.
2791 return internal_equal(object1, object2, 0) ? Qt : Qnil;
2794 DEFUN("old-equal", Fold_equal, 2, 2, 0, /*
2795 Return t if two Lisp objects have similar structure and contents.
2796 They must have the same data type.
2797 \(Note, however, that an exception is made for characters and integers;
2798 this is known as the "char-int confoundance disease." See `eq' and
2800 This function is provided only for byte-code compatibility with v19.
2805 return internal_old_equal(object1, object2, 0) ? Qt : Qnil;
2808 DEFUN("fillarray", Ffillarray, 2, 2, 0, /*
2809 Destructively modify ARRAY by replacing each element with ITEM.
2810 ARRAY is a vector, bit vector, or string.
2815 if (STRINGP(array)) {
2816 Lisp_String *s = XSTRING(array);
2817 Bytecount old_bytecount = string_length(s);
2818 Bytecount new_bytecount;
2819 Bytecount item_bytecount;
2820 Bufbyte item_buf[MAX_EMCHAR_LEN];
2824 CHECK_CHAR_COERCE_INT(item);
2825 CHECK_LISP_WRITEABLE(array);
2827 item_bytecount = set_charptr_emchar(item_buf, XCHAR(item));
2828 new_bytecount = item_bytecount * string_char_length(s);
2830 resize_string(s, -1, new_bytecount - old_bytecount);
2832 for (p = string_data(s), end = p + new_bytecount;
2833 p < end; p += item_bytecount)
2834 memcpy(p, item_buf, item_bytecount);
2837 bump_string_modiff(array);
2838 } else if (VECTORP(array)) {
2839 Lisp_Object *p = XVECTOR_DATA(array);
2840 size_t len = XVECTOR_LENGTH(array);
2841 CHECK_LISP_WRITEABLE(array);
2844 } else if (BIT_VECTORP(array)) {
2845 Lisp_Bit_Vector *v = XBIT_VECTOR(array);
2846 size_t len = bit_vector_length(v);
2850 CHECK_LISP_WRITEABLE(array);
2852 set_bit_vector_bit(v, len, bit);
2854 array = wrong_type_argument(Qarrayp, array);
2860 Lisp_Object nconc2(Lisp_Object arg1, Lisp_Object arg2)
2862 Lisp_Object args[2] = {arg1, arg2};
2863 struct gcpro gcpro1;
2865 GCPROn(args, countof(args));
2866 RETURN_UNGCPRO(bytecode_nconc2(args));
2869 Lisp_Object bytecode_nconc2(Lisp_Object * args)
2873 if (CONSP(args[0])) {
2874 /* (setcdr (last args[0]) args[1]) */
2875 Lisp_Object tortoise, hare;
2878 for (hare = tortoise = args[0], count = 0;
2879 CONSP(XCDR(hare)); hare = XCDR(hare), count++) {
2880 if (count < CIRCULAR_LIST_SUSPICION_LENGTH)
2884 tortoise = XCDR(tortoise);
2885 if (EQ(hare, tortoise))
2886 signal_circular_list_error(args[0]);
2888 XCDR(hare) = args[1];
2890 } else if (NILP(args[0])) {
2893 args[0] = wrong_type_argument(args[0], Qlistp);
2898 DEFUN("nconc", Fnconc, 0, MANY, 0, /*
2899 Concatenate any number of lists by altering them.
2900 Only the last argument is not altered, and need not be a list.
2902 If the first argument is nil, there is no way to modify it by side
2903 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2904 changing the value of `foo'.
2906 (int nargs, Lisp_Object * args))
2909 struct gcpro gcpro1;
2911 /* The modus operandi in Emacs is "caller gc-protects args".
2912 However, nconc (particularly nconc2 ()) is called many times
2913 in Emacs on freshly created stuff (e.g. you see the idiom
2914 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2915 callers out by protecting the args ourselves to save them
2916 a lot of temporary-variable grief. */
2918 GCPROn(args, nargs);
2920 while (argnum < nargs) {
2925 /* `val' is the first cons, which will be our return
2927 * `last_cons' will be the cons cell to mutate. */
2928 Lisp_Object last_cons = val;
2929 Lisp_Object tortoise = val;
2931 for (argnum++; argnum < nargs; argnum++) {
2932 Lisp_Object next = args[argnum];
2934 if (CONSP(next) || argnum == nargs - 1) {
2935 /* (setcdr (last val) next) */
2939 CONSP(XCDR(last_cons));
2941 XCDR(last_cons), count++) {
2943 CIRCULAR_LIST_SUSPICION_LENGTH)
2949 if (EQ(last_cons, tortoise))
2950 signal_circular_list_error
2953 XCDR(last_cons) = next;
2954 } else if (NILP(next)) {
2958 wrong_type_argument(Qlistp, next);
2962 RETURN_UNGCPRO(val);
2963 } else if (NILP(val))
2965 else if (argnum == nargs - 1) /* last arg? */
2966 RETURN_UNGCPRO(val);
2968 args[argnum] = wrong_type_argument(Qlistp, val);
2972 RETURN_UNGCPRO(Qnil); /* No non-nil args provided. */
2976 DEFUN("replace-list", Freplace_list, 2, 2, 0, /*
2977 Destructively replace the list OLD with NEW.
2978 This is like (copy-sequence NEW) except that it reuses the
2979 conses in OLD as much as possible. If OLD and NEW are the same
2980 length, no consing will take place.
2984 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
2986 EXTERNAL_LIST_LOOP(tail, new) {
2987 if (!NILP(oldtail)) {
2988 CHECK_CONS(oldtail);
2989 XCAR(oldtail) = XCAR(tail);
2990 } else if (!NILP(prevoldtail)) {
2991 XCDR(prevoldtail) = Fcons(XCAR(tail), Qnil);
2992 prevoldtail = XCDR(prevoldtail);
2994 old = oldtail = Fcons(XCAR(tail), Qnil);
2996 if (!NILP(oldtail)) {
2997 prevoldtail = oldtail;
2998 oldtail = XCDR(oldtail);
3002 if (!NILP(prevoldtail))
3003 XCDR(prevoldtail) = Qnil;
3010 /* #### this function doesn't belong in this file! */
3012 #ifdef HAVE_GETLOADAVG
3013 #ifdef HAVE_SYS_LOADAVG_H
3014 #include <sys/loadavg.h>
3017 int getloadavg(double loadavg[], int nelem); /* Defined in getloadavg.c */
3020 DEFUN("load-average", Fload_average, 0, 1, 0, /*
3021 Return list of 1 minute, 5 minute and 15 minute load averages.
3022 Each of the three load averages is multiplied by 100,
3023 then converted to integer.
3025 When USE-FLOATS is non-nil, floats will be used instead of integers.
3026 These floats are not multiplied by 100.
3028 If the 5-minute or 15-minute load averages are not available, return a
3029 shortened list, containing only those averages which are available.
3031 On some systems, this won't work due to permissions on /dev/kmem,
3032 in which case you can't use this.
3037 int loads = getloadavg(load_ave, countof(load_ave));
3038 Lisp_Object ret = Qnil;
3041 error("load-average not implemented for this operating system");
3043 signal_simple_error("Could not get load-average",
3044 lisp_strerror(errno));
3046 while (loads-- > 0) {
3047 Lisp_Object load = (NILP(use_floats) ?
3048 make_int((int)(100.0 * load_ave[loads]))
3049 : make_float(load_ave[loads]));
3050 ret = Fcons(load, ret);
3055 Lisp_Object Vfeatures;
3057 DEFUN("featurep", Ffeaturep, 1, 1, 0, /*
3058 Return non-nil if feature FEXP is present in this Emacs.
3059 Use this to conditionalize execution of lisp code based on the
3060 presence or absence of emacs or environment extensions.
3061 FEXP can be a symbol, a number, or a list.
3062 If it is a symbol, that symbol is looked up in the `features' variable,
3063 and non-nil will be returned if found.
3064 If it is a number, the function will return non-nil if this Emacs
3065 has an equal or greater version number than FEXP.
3066 If it is a list whose car is the symbol `and', it will return
3067 non-nil if all the features in its cdr are non-nil.
3068 If it is a list whose car is the symbol `or', it will return non-nil
3069 if any of the features in its cdr are non-nil.
3070 If it is a list whose car is the symbol `not', it will return
3071 non-nil if the feature is not present.
3076 => ; Non-nil on SXEmacs.
3078 (featurep '(and sxemacs gnus))
3079 => ; Non-nil on SXEmacs with Gnus loaded.
3081 (featurep '(or tty-frames (and emacs 19.30)))
3082 => ; Non-nil if this Emacs supports TTY frames.
3084 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3085 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3087 (featurep '(and xemacs 21.02))
3088 => ; Non-nil on XEmacs 21.2 and later.
3090 NOTE: The advanced arguments of this function (anything other than a
3091 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3092 for supporting multiple Emacs variants, lobby Richard Stallman at
3093 <bug-gnu-emacs@gnu.org>.
3097 #ifndef FEATUREP_SYNTAX
3099 return NILP(Fmemq(fexp, Vfeatures)) ? Qnil : Qt;
3100 #else /* FEATUREP_SYNTAX */
3101 static double featurep_emacs_version;
3103 /* Brute force translation from Erik Naggum's lisp function. */
3104 if (SYMBOLP(fexp)) {
3105 /* Original definition */
3106 return NILP(Fmemq(fexp, Vfeatures)) ? Qnil : Qt;
3107 } else if (INTP(fexp) || FLOATP(fexp)) {
3108 double d = extract_float(fexp);
3110 if (featurep_emacs_version == 0.0) {
3111 featurep_emacs_version = XINT(Vemacs_major_version) +
3112 (XINT(Vemacs_minor_version) / 100.0);
3114 return featurep_emacs_version >= d ? Qt : Qnil;
3115 } else if (CONSP(fexp)) {
3116 Lisp_Object tem = XCAR(fexp);
3117 if (EQ(tem, Qnot)) {
3123 return NILP(call1(Qfeaturep, negate)) ? Qt :
3126 return Fsignal(Qinvalid_read_syntax,
3128 } else if (EQ(tem, Qand)) {
3130 /* Use Fcar/Fcdr for error-checking. */
3131 while (!NILP(tem) && !NILP(call1(Qfeaturep, Fcar(tem)))) {
3134 return NILP(tem) ? Qt : Qnil;
3135 } else if (EQ(tem, Qor)) {
3137 /* Use Fcar/Fcdr for error-checking. */
3138 while (!NILP(tem) && NILP(call1(Qfeaturep, Fcar(tem)))) {
3141 return NILP(tem) ? Qnil : Qt;
3143 return Fsignal(Qinvalid_read_syntax, list1(XCDR(fexp)));
3146 return Fsignal(Qinvalid_read_syntax, list1(fexp));
3149 #endif /* FEATUREP_SYNTAX */
3151 DEFUN("provide", Fprovide, 1, 1, 0, /*
3152 Announce that FEATURE is a feature of the current Emacs.
3153 This function updates the value of the variable `features'.
3158 CHECK_SYMBOL(feature);
3159 if (!NILP(Vautoload_queue))
3161 Fcons(Fcons(Vfeatures, Qnil), Vautoload_queue);
3162 tem = Fmemq(feature, Vfeatures);
3164 Vfeatures = Fcons(feature, Vfeatures);
3165 LOADHIST_ATTACH(Fcons(Qprovide, feature));
3169 DEFUN("require", Frequire, 1, 3, 0, /*
3170 Ensure that FEATURE is present in the Lisp environment.
3171 FEATURE is a symbol naming a collection of resources (functions, etc).
3172 Optional FILENAME is a library from which to load resources; it defaults to
3173 the print name of FEATURE.
3174 Optional NOERROR, if non-nil, causes require to return nil rather than signal
3175 an error if loading the library fails.
3177 If feature FEATURE is present in `features', update `load-history' to reflect
3178 the require and return FEATURE. Otherwise, try to load it from a library.
3179 The normal messages at start and end of loading are suppressed.
3180 If the library is successfully loaded and it calls `(provide FEATURE)', add
3181 FEATURE to `features', update `load-history' and return FEATURE.
3182 If the load succeeds but FEATURE is not provided by the library, signal
3185 The byte-compiler treats top-level calls to `require' specially, by evaluating
3186 them at compile time (and then compiling them normally). Thus a library may
3187 request that definitions that should be inlined such as macros and defsubsts
3188 be loaded into its compilation environment. Achieving this in other contexts
3189 requires an explicit \(eval-and-compile ...\) block.
3191 (feature, filename, noerror))
3195 CHECK_SYMBOL(feature);
3196 tem = Fmemq(feature, Vfeatures);
3197 LOADHIST_ATTACH(Fcons(Qrequire, feature));
3202 int speccount = specpdl_depth();
3204 /* Value saved here is to be restored into Vautoload_queue */
3205 record_unwind_protect(un_autoload, Vautoload_queue);
3206 Vautoload_queue = Qt;
3208 tem = call4(Qload, NILP(filename) ? Fsymbol_name(feature) : filename,
3209 noerror, Qrequire, Qnil);
3210 /* If load failed entirely, return nil. */
3212 return unbind_to(speccount, Qnil);
3214 tem = Fmemq(feature, Vfeatures);
3215 if (NILP(tem) && NILP(noerror)) {
3216 signal_type_error(Qinvalid_state,
3217 "Required feature was not provided",
3219 } else if (!NILP(noerror)) {
3220 return unbind_to(speccount, Qnil);
3223 /* Once loading finishes, don't undo it. */
3224 Vautoload_queue = Qt;
3225 return unbind_to(speccount, feature);
3229 DEFUN("revoke", Frevoke, 1, 1, 0, /*
3230 Announce that FEATURE is no longer a feature of the current Emacs.
3234 CHECK_SYMBOL(feature);
3235 if (!NILP(Vautoload_queue))
3237 Fcons(Fcons(Vfeatures, Qnil), Vautoload_queue);
3239 if (LIKELY(CONSP(Vfeatures) && EQ(XCAR(Vfeatures), feature))) {
3240 /* special case where feature is the head of 'features */
3241 Vfeatures = XCDR(Vfeatures);
3244 for (Lisp_Object tmp = Vfeatures;
3245 CONSP(tmp) && CONSP(XCDR(tmp));
3247 if (EQ(XCAR(XCDR(tmp)), feature)) {
3248 XCDR(tmp) = XCDR(XCDR(tmp));
3255 /* base64 encode/decode functions.
3257 Originally based on code from GNU recode. Ported to FSF Emacs by
3258 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3259 subsequently heavily hacked by Hrvoje Niksic. */
3261 #define MIME_LINE_LENGTH 72
3263 #define IS_ASCII(Character) \
3265 #define IS_BASE64(Character) \
3266 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3268 /* Table of characters coding the 64 values. */
3269 static char base64_value_to_char[64] = {
3270 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3271 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3272 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3273 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3274 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3275 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3276 '8', '9', '+', '/' /* 60-63 */
3279 /* Table of base64 values for first 128 characters. */
3280 static short base64_char_to_value[128] = {
3281 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3282 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3283 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3284 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3285 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3286 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3287 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3288 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3289 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3290 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3291 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3292 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3293 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3296 /* The following diagram shows the logical steps by which three octets
3297 get transformed into four base64 characters.
3299 .--------. .--------. .--------.
3300 |aaaaaabb| |bbbbcccc| |ccdddddd|
3301 `--------' `--------' `--------'
3303 .--------+--------+--------+--------.
3304 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3305 `--------+--------+--------+--------'
3307 .--------+--------+--------+--------.
3308 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3309 `--------+--------+--------+--------'
3311 The octets are divided into 6 bit chunks, which are then encoded into
3312 base64 characters. */
3314 #define ADVANCE_INPUT(c, stream) \
3315 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3317 (signal_simple_error ("Non-ascii character in base64 input", \
3318 make_char (ec)), 0) \
3319 : (c = (Bufbyte)ec), 1))
3321 static Bytind base64_encode_1(Lstream * istream, Bufbyte * to, int line_break)
3323 EMACS_INT counter = 0;
3330 if (!ADVANCE_INPUT(c, istream))
3333 /* Wrap line every 76 characters. */
3335 if (counter < MIME_LINE_LENGTH / 4)
3343 /* Process first byte of a triplet. */
3344 *e++ = base64_value_to_char[0x3f & c >> 2];
3345 value = (0x03 & c) << 4;
3347 /* Process second byte of a triplet. */
3348 if (!ADVANCE_INPUT(c, istream)) {
3349 *e++ = base64_value_to_char[value];
3355 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3356 value = (0x0f & c) << 2;
3358 /* Process third byte of a triplet. */
3359 if (!ADVANCE_INPUT(c, istream)) {
3360 *e++ = base64_value_to_char[value];
3365 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3366 *e++ = base64_value_to_char[0x3f & c];
3372 #undef ADVANCE_INPUT
3374 /* Get next character from the stream, except that non-base64
3375 characters are ignored. This is in accordance with rfc2045. EC
3376 should be an Emchar, so that it can hold -1 as the value for EOF. */
3377 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3378 ec = Lstream_get_emchar (stream); \
3380 /* IS_BASE64 may not be called with negative arguments so check for \
3382 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3386 #define STORE_BYTE(pos, val, ccnt) do { \
3387 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3392 base64_decode_1(Lstream * istream, Bufbyte * to, Charcount * ccptr)
3396 EMACS_INT streampos = 0;
3400 unsigned long value;
3402 /* Process first byte of a quadruplet. */
3403 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3408 ("Illegal `=' character while decoding base64",
3409 make_int(streampos));
3410 value = base64_char_to_value[ec] << 18;
3412 /* Process second byte of a quadruplet. */
3413 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3415 error("Premature EOF while decoding base64");
3418 ("Illegal `=' character while decoding base64",
3419 make_int(streampos));
3420 value |= base64_char_to_value[ec] << 12;
3421 STORE_BYTE(e, value >> 16, ccnt);
3423 /* Process third byte of a quadruplet. */
3424 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3426 error("Premature EOF while decoding base64");
3429 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3431 error("Premature EOF while decoding base64");
3434 ("Padding `=' expected but not found while decoding base64",
3435 make_int(streampos));
3439 value |= base64_char_to_value[ec] << 6;
3440 STORE_BYTE(e, 0xff & value >> 8, ccnt);
3442 /* Process fourth byte of a quadruplet. */
3443 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3445 error("Premature EOF while decoding base64");
3449 value |= base64_char_to_value[ec];
3450 STORE_BYTE(e, 0xff & value, ccnt);
3457 #undef ADVANCE_INPUT
3458 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3461 DEFUN("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3462 Base64-encode the region between START and END.
3463 Return the length of the encoded text.
3464 Optional third argument NO-LINE-BREAK means do not break long lines
3467 (start, end, no_line_break))
3470 Bytind encoded_length;
3471 Charcount allength, length;
3472 struct buffer *buf = current_buffer;
3473 Bufpos begv, zv, old_pt = BUF_PT(buf);
3475 int speccount = specpdl_depth();
3477 get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3478 barf_if_buffer_read_only(buf, begv, zv);
3480 /* We need to allocate enough room for encoding the text.
3481 We need 33 1/3% more space, plus a newline every 76
3482 characters, and then we round up. */
3484 allength = length + length / 3 + 1;
3485 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3487 input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3488 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3489 base64 characters will be single-byte. */
3490 XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3491 encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3492 NILP(no_line_break));
3493 if (encoded_length > allength) {
3496 Lstream_delete(XLSTREAM(input));
3498 /* Now we have encoded the region, so we insert the new contents
3499 and delete the old. (Insert first in order to preserve markers.) */
3500 buffer_insert_raw_string_1(buf, begv, encoded, encoded_length, 0);
3501 XMALLOC_UNBIND(encoded, allength, speccount);
3502 buffer_delete_range(buf, begv + encoded_length, zv + encoded_length, 0);
3504 /* Simulate FSF Emacs implementation of this function: if point was
3505 in the region, place it at the beginning. */
3506 if (old_pt >= begv && old_pt < zv) {
3507 BUF_SET_PT(buf, begv);
3510 /* We return the length of the encoded text. */
3511 return make_int(encoded_length);
3514 DEFUN("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3515 Base64 encode STRING and return the result.
3516 Optional argument NO-LINE-BREAK means do not break long lines
3519 (string, no_line_break))
3521 Charcount allength, length;
3522 Bytind encoded_length;
3524 Lisp_Object input, result;
3525 int speccount = specpdl_depth();
3527 CHECK_STRING(string);
3529 length = XSTRING_CHAR_LENGTH(string);
3530 allength = length + length / 3 + 1;
3531 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3533 input = make_lisp_string_input_stream(string, 0, -1);
3534 XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3535 encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3536 NILP(no_line_break));
3537 if (encoded_length > allength) {
3540 Lstream_delete(XLSTREAM(input));
3541 result = make_string(encoded, encoded_length);
3542 XMALLOC_UNBIND(encoded, allength, speccount);
3546 DEFUN("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3547 Base64-decode the region between START and END.
3548 Return the length of the decoded text.
3549 If the region can't be decoded, return nil and don't modify the buffer.
3550 Characters out of the base64 alphabet are ignored.
3554 struct buffer *buf = current_buffer;
3555 Bufpos begv, zv, old_pt = BUF_PT(buf);
3557 Bytind decoded_length;
3558 Charcount length, cc_decoded_length;
3560 int speccount = specpdl_depth();
3562 get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3563 barf_if_buffer_read_only(buf, begv, zv);
3567 input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3568 /* We need to allocate enough room for decoding the text. */
3569 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3571 base64_decode_1(XLSTREAM(input), decoded, &cc_decoded_length);
3572 if (decoded_length > length * MAX_EMCHAR_LEN) {
3575 Lstream_delete(XLSTREAM(input));
3577 /* Now we have decoded the region, so we insert the new contents
3578 and delete the old. (Insert first in order to preserve markers.) */
3579 BUF_SET_PT(buf, begv);
3580 buffer_insert_raw_string_1(buf, begv, decoded, decoded_length, 0);
3581 XMALLOC_UNBIND(decoded, length * MAX_EMCHAR_LEN, speccount);
3582 buffer_delete_range(buf, begv + cc_decoded_length,
3583 zv + cc_decoded_length, 0);
3585 /* Simulate FSF Emacs implementation of this function: if point was
3586 in the region, place it at the beginning. */
3587 if (old_pt >= begv && old_pt < zv) {
3588 BUF_SET_PT(buf, begv);
3591 return make_int(cc_decoded_length);
3594 DEFUN("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3595 Base64-decode STRING and return the result.
3596 Characters out of the base64 alphabet are ignored.
3601 Bytind decoded_length;
3602 Charcount length, cc_decoded_length;
3603 Lisp_Object input, result;
3604 int speccount = specpdl_depth();
3606 CHECK_STRING(string);
3608 length = XSTRING_CHAR_LENGTH(string);
3609 /* We need to allocate enough room for decoding the text. */
3610 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3612 input = make_lisp_string_input_stream(string, 0, -1);
3613 decoded_length = base64_decode_1(XLSTREAM(input), decoded,
3614 &cc_decoded_length);
3615 if (decoded_length > length * MAX_EMCHAR_LEN) {
3618 Lstream_delete(XLSTREAM(input));
3620 result = make_string(decoded, decoded_length);
3621 XMALLOC_UNBIND(decoded, length * MAX_EMCHAR_LEN, speccount);
3625 /* base16 encode/decode functions. */
3627 base16_encode_1(Lstream * istream, int length, Bufbyte * to, int max)
3632 for (i=0; i < length; i++) {
3633 ec = Lstream_get_emchar (istream);
3634 sz = snprintf((char *)to+2*i, 3, "%02x", ec);
3635 assert( sz >= 0 && sz < 3);
3643 base16_decode_1(Lstream * istream, int length, Bufbyte * to)
3646 Emchar high = 0, low = 0;
3647 int high_set_p = 0, ignore_p = 0;
3650 /* high and low perform flip flop operation */
3652 ec = Lstream_get_emchar (istream);
3657 else if (isupper(ec))
3658 low = ec - 'A' + 10;
3659 else if (islower(ec))
3660 low = ec - 'a' + 10;
3664 if (low < 0 || low >= 16)
3672 to[i] = high*16+low;
3682 DEFUN("base16-encode-string", Fbase16_encode_string, 1, 1, 0, /*
3683 Base16 encode (i.e. hex dump) STRING and return the result.
3684 Optional argument NO-LINE-BREAK means do not break long lines
3691 Lisp_Object input, result;
3693 int speccount = specpdl_depth();
3695 CHECK_STRING(string);
3697 length = XSTRING_CHAR_LENGTH(string);
3699 input = make_lisp_string_input_stream(string, 0, -1);
3700 XMALLOC_ATOMIC_OR_ALLOCA(encoded, sz+1, Bufbyte);
3701 base16_encode_1(XLSTREAM(input), length, encoded, sz);
3702 Lstream_delete(XLSTREAM(input));
3703 result = make_string(encoded, sz);
3704 XMALLOC_UNBIND(encoded, sz+1, speccount);
3706 XSTRING(result)->plist = XSTRING(string)->plist;
3711 DEFUN("base16-decode-string", Fbase16_decode_string, 1, 1, 0, /*
3712 Base16-decode (i.e. read hex data from) STRING and return the result.
3713 Characters out of the base16 alphabet are ignored.
3718 Bytind decoded_length;
3720 Lisp_Object input, result;
3721 int speccount = specpdl_depth();
3723 CHECK_STRING(string);
3725 length = XSTRING_CHAR_LENGTH(string);
3726 /* We need to allocate enough room for decoding the text. */
3727 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length, Bufbyte);
3729 input = make_lisp_string_input_stream(string, 0, -1);
3730 decoded_length = base16_decode_1(XLSTREAM(input), length, decoded);
3731 Lstream_delete(XLSTREAM(input));
3733 /* this result might be raw, we declare it binary */
3734 result = make_ext_string((char *)decoded, decoded_length, Qbinary);
3735 XMALLOC_UNBIND(decoded, length, speccount);
3737 XSTRING(result)->plist = XSTRING(string)->plist;
3742 Lisp_Object Qyes_or_no_p;
3744 DEFUN("foobar", Ffoobar, 2, 2, 0, /*
3748 return make_int(__nbits_right_of(XINT(n), XINT(b)));
3751 void syms_of_fns(void)
3753 INIT_LRECORD_IMPLEMENTATION(bit_vector);
3755 defsymbol(&Qstring_lessp, "string-lessp");
3756 defsymbol(&Qstring_greaterp, "string-greaterp");
3757 defsymbol(&Qidentity, "identity");
3758 defsymbol(&Qyes_or_no_p, "yes-or-no-p");
3764 #if defined(WITH_GMP) && defined(HAVE_MPZ)
3768 DEFSUBR(Fsafe_length);
3769 DEFSUBR(Fstring_equal);
3770 DEFSUBR(Fstring_lessp);
3771 DEFSUBR(Fstring_greaterp);
3772 DEFSUBR(Fstring_modified_tick);
3777 DEFSUBR(Fcopy_list);
3778 DEFSUBR(Fcopy_sequence);
3779 DEFSUBR(Fcopy_alist);
3780 DEFSUBR(Fcopy_tree);
3781 DEFSUBR(Fsubstring);
3790 DEFSUBR(Fold_member);
3794 DEFSUBR(Fold_assoc);
3798 DEFSUBR(Fold_rassoc);
3800 DEFSUBR(Fold_rassq);
3802 DEFSUBR(Fold_delete);
3807 DEFSUBR(Fremrassoc);
3812 DEFSUBR(Fplists_eq);
3813 DEFSUBR(Fplists_equal);
3814 DEFSUBR(Flax_plists_eq);
3815 DEFSUBR(Flax_plists_equal);
3816 DEFSUBR(Fplist_get);
3817 DEFSUBR(Fplist_put);
3818 DEFSUBR(Fplist_remprop);
3819 DEFSUBR(Fplist_member);
3820 DEFSUBR(Fcheck_valid_plist);
3821 DEFSUBR(Fvalid_plist_p);
3822 DEFSUBR(Fcanonicalize_plist);
3823 DEFSUBR(Flax_plist_get);
3824 DEFSUBR(Flax_plist_put);
3825 DEFSUBR(Flax_plist_remprop);
3826 DEFSUBR(Flax_plist_member);
3827 DEFSUBR(Fcanonicalize_lax_plist);
3828 DEFSUBR(Fdestructive_alist_to_plist);
3832 DEFSUBR(Fobject_plist);
3834 DEFSUBR(Fold_equal);
3835 DEFSUBR(Ffillarray);
3837 DEFSUBR(Freplace_list);
3838 DEFSUBR(Fload_average);
3843 DEFSUBR(Fbase64_encode_region);
3844 DEFSUBR(Fbase64_encode_string);
3845 DEFSUBR(Fbase64_decode_region);
3846 DEFSUBR(Fbase64_decode_string);
3847 DEFSUBR(Fbase16_encode_string);
3848 DEFSUBR(Fbase16_decode_string);
3855 void init_provide_once(void)
3857 DEFVAR_LISP("features", &Vfeatures /*
3858 A list of symbols which are the features of the executing emacs.
3859 Used by `featurep' and `require', and altered by `provide'.
3863 Fprovide(intern("base64"));
3864 Fprovide(intern("base16"));
3866 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3867 /* it's fuck ugly to define that here :( */
3868 Fprovide(intern("bdwgc"));