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, 2, 0, /*
3170 If feature FEATURE is not loaded, load it from FILENAME.
3171 If FEATURE is not a member of the list `features', then the feature
3172 is not loaded; so load the file FILENAME.
3173 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3175 (feature, filename))
3179 CHECK_SYMBOL(feature);
3180 tem = Fmemq(feature, Vfeatures);
3181 LOADHIST_ATTACH(Fcons(Qrequire, feature));
3186 int speccount = specpdl_depth();
3188 /* Value saved here is to be restored into Vautoload_queue */
3189 record_unwind_protect(un_autoload, Vautoload_queue);
3190 Vautoload_queue = Qt;
3192 /* defined in code-files.el */
3193 call4(Qload, NILP(filename) ? Fsymbol_name(feature) : filename,
3196 tem = Fmemq(feature, Vfeatures);
3198 error("Required feature %s was not provided",
3199 string_data(XSYMBOL(feature)->name));
3201 /* Once loading finishes, don't undo it. */
3202 Vautoload_queue = Qt;
3203 return unbind_to(speccount, feature);
3207 DEFUN("revoke", Frevoke, 1, 1, 0, /*
3208 Announce that FEATURE is no longer a feature of the current Emacs.
3212 CHECK_SYMBOL(feature);
3213 if (!NILP(Vautoload_queue))
3215 Fcons(Fcons(Vfeatures, Qnil), Vautoload_queue);
3217 if (LIKELY(CONSP(Vfeatures) && EQ(XCAR(Vfeatures), feature))) {
3218 /* special case where feature is the head of 'features */
3219 Vfeatures = XCDR(Vfeatures);
3222 for (Lisp_Object tmp = Vfeatures;
3223 CONSP(tmp) && CONSP(XCDR(tmp));
3225 if (EQ(XCAR(XCDR(tmp)), feature)) {
3226 XCDR(tmp) = XCDR(XCDR(tmp));
3233 /* base64 encode/decode functions.
3235 Originally based on code from GNU recode. Ported to FSF Emacs by
3236 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3237 subsequently heavily hacked by Hrvoje Niksic. */
3239 #define MIME_LINE_LENGTH 72
3241 #define IS_ASCII(Character) \
3243 #define IS_BASE64(Character) \
3244 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3246 /* Table of characters coding the 64 values. */
3247 static char base64_value_to_char[64] = {
3248 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3249 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3250 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3251 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3252 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3253 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3254 '8', '9', '+', '/' /* 60-63 */
3257 /* Table of base64 values for first 128 characters. */
3258 static short base64_char_to_value[128] = {
3259 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3260 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3261 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3262 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3263 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3264 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3265 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3266 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3267 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3268 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3269 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3270 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3271 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3274 /* The following diagram shows the logical steps by which three octets
3275 get transformed into four base64 characters.
3277 .--------. .--------. .--------.
3278 |aaaaaabb| |bbbbcccc| |ccdddddd|
3279 `--------' `--------' `--------'
3281 .--------+--------+--------+--------.
3282 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3283 `--------+--------+--------+--------'
3285 .--------+--------+--------+--------.
3286 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3287 `--------+--------+--------+--------'
3289 The octets are divided into 6 bit chunks, which are then encoded into
3290 base64 characters. */
3292 #define ADVANCE_INPUT(c, stream) \
3293 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3295 (signal_simple_error ("Non-ascii character in base64 input", \
3296 make_char (ec)), 0) \
3297 : (c = (Bufbyte)ec), 1))
3299 static Bytind base64_encode_1(Lstream * istream, Bufbyte * to, int line_break)
3301 EMACS_INT counter = 0;
3308 if (!ADVANCE_INPUT(c, istream))
3311 /* Wrap line every 76 characters. */
3313 if (counter < MIME_LINE_LENGTH / 4)
3321 /* Process first byte of a triplet. */
3322 *e++ = base64_value_to_char[0x3f & c >> 2];
3323 value = (0x03 & c) << 4;
3325 /* Process second byte of a triplet. */
3326 if (!ADVANCE_INPUT(c, istream)) {
3327 *e++ = base64_value_to_char[value];
3333 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3334 value = (0x0f & c) << 2;
3336 /* Process third byte of a triplet. */
3337 if (!ADVANCE_INPUT(c, istream)) {
3338 *e++ = base64_value_to_char[value];
3343 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3344 *e++ = base64_value_to_char[0x3f & c];
3350 #undef ADVANCE_INPUT
3352 /* Get next character from the stream, except that non-base64
3353 characters are ignored. This is in accordance with rfc2045. EC
3354 should be an Emchar, so that it can hold -1 as the value for EOF. */
3355 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3356 ec = Lstream_get_emchar (stream); \
3358 /* IS_BASE64 may not be called with negative arguments so check for \
3360 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3364 #define STORE_BYTE(pos, val, ccnt) do { \
3365 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3370 base64_decode_1(Lstream * istream, Bufbyte * to, Charcount * ccptr)
3374 EMACS_INT streampos = 0;
3378 unsigned long value;
3380 /* Process first byte of a quadruplet. */
3381 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3386 ("Illegal `=' character while decoding base64",
3387 make_int(streampos));
3388 value = base64_char_to_value[ec] << 18;
3390 /* Process second byte of a quadruplet. */
3391 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3393 error("Premature EOF while decoding base64");
3396 ("Illegal `=' character while decoding base64",
3397 make_int(streampos));
3398 value |= base64_char_to_value[ec] << 12;
3399 STORE_BYTE(e, value >> 16, ccnt);
3401 /* Process third byte of a quadruplet. */
3402 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3404 error("Premature EOF while decoding base64");
3407 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3409 error("Premature EOF while decoding base64");
3412 ("Padding `=' expected but not found while decoding base64",
3413 make_int(streampos));
3417 value |= base64_char_to_value[ec] << 6;
3418 STORE_BYTE(e, 0xff & value >> 8, ccnt);
3420 /* Process fourth byte of a quadruplet. */
3421 ADVANCE_INPUT_IGNORE_NONBASE64(ec, istream, streampos);
3423 error("Premature EOF while decoding base64");
3427 value |= base64_char_to_value[ec];
3428 STORE_BYTE(e, 0xff & value, ccnt);
3435 #undef ADVANCE_INPUT
3436 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3439 DEFUN("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3440 Base64-encode the region between START and END.
3441 Return the length of the encoded text.
3442 Optional third argument NO-LINE-BREAK means do not break long lines
3445 (start, end, no_line_break))
3448 Bytind encoded_length;
3449 Charcount allength, length;
3450 struct buffer *buf = current_buffer;
3451 Bufpos begv, zv, old_pt = BUF_PT(buf);
3453 int speccount = specpdl_depth();
3455 get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3456 barf_if_buffer_read_only(buf, begv, zv);
3458 /* We need to allocate enough room for encoding the text.
3459 We need 33 1/3% more space, plus a newline every 76
3460 characters, and then we round up. */
3462 allength = length + length / 3 + 1;
3463 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3465 input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3466 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3467 base64 characters will be single-byte. */
3468 XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3469 encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3470 NILP(no_line_break));
3471 if (encoded_length > allength) {
3474 Lstream_delete(XLSTREAM(input));
3476 /* Now we have encoded the region, so we insert the new contents
3477 and delete the old. (Insert first in order to preserve markers.) */
3478 buffer_insert_raw_string_1(buf, begv, encoded, encoded_length, 0);
3479 XMALLOC_UNBIND(encoded, allength, speccount);
3480 buffer_delete_range(buf, begv + encoded_length, zv + encoded_length, 0);
3482 /* Simulate FSF Emacs implementation of this function: if point was
3483 in the region, place it at the beginning. */
3484 if (old_pt >= begv && old_pt < zv) {
3485 BUF_SET_PT(buf, begv);
3488 /* We return the length of the encoded text. */
3489 return make_int(encoded_length);
3492 DEFUN("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3493 Base64 encode STRING and return the result.
3494 Optional argument NO-LINE-BREAK means do not break long lines
3497 (string, no_line_break))
3499 Charcount allength, length;
3500 Bytind encoded_length;
3502 Lisp_Object input, result;
3503 int speccount = specpdl_depth();
3505 CHECK_STRING(string);
3507 length = XSTRING_CHAR_LENGTH(string);
3508 allength = length + length / 3 + 1;
3509 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3511 input = make_lisp_string_input_stream(string, 0, -1);
3512 XMALLOC_ATOMIC_OR_ALLOCA(encoded, allength, Bufbyte);
3513 encoded_length = base64_encode_1(XLSTREAM(input), encoded,
3514 NILP(no_line_break));
3515 if (encoded_length > allength) {
3518 Lstream_delete(XLSTREAM(input));
3519 result = make_string(encoded, encoded_length);
3520 XMALLOC_UNBIND(encoded, allength, speccount);
3524 DEFUN("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3525 Base64-decode the region between START and END.
3526 Return the length of the decoded text.
3527 If the region can't be decoded, return nil and don't modify the buffer.
3528 Characters out of the base64 alphabet are ignored.
3532 struct buffer *buf = current_buffer;
3533 Bufpos begv, zv, old_pt = BUF_PT(buf);
3535 Bytind decoded_length;
3536 Charcount length, cc_decoded_length;
3538 int speccount = specpdl_depth();
3540 get_buffer_range_char(buf, start, end, &begv, &zv, 0);
3541 barf_if_buffer_read_only(buf, begv, zv);
3545 input = make_lisp_buffer_input_stream(buf, begv, zv, 0);
3546 /* We need to allocate enough room for decoding the text. */
3547 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3549 base64_decode_1(XLSTREAM(input), decoded, &cc_decoded_length);
3550 if (decoded_length > length * MAX_EMCHAR_LEN) {
3553 Lstream_delete(XLSTREAM(input));
3555 /* Now we have decoded the region, so we insert the new contents
3556 and delete the old. (Insert first in order to preserve markers.) */
3557 BUF_SET_PT(buf, begv);
3558 buffer_insert_raw_string_1(buf, begv, decoded, decoded_length, 0);
3559 XMALLOC_UNBIND(decoded, length * MAX_EMCHAR_LEN, speccount);
3560 buffer_delete_range(buf, begv + cc_decoded_length,
3561 zv + cc_decoded_length, 0);
3563 /* Simulate FSF Emacs implementation of this function: if point was
3564 in the region, place it at the beginning. */
3565 if (old_pt >= begv && old_pt < zv) {
3566 BUF_SET_PT(buf, begv);
3569 return make_int(cc_decoded_length);
3572 DEFUN("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3573 Base64-decode STRING and return the result.
3574 Characters out of the base64 alphabet are ignored.
3579 Bytind decoded_length;
3580 Charcount length, cc_decoded_length;
3581 Lisp_Object input, result;
3582 int speccount = specpdl_depth();
3584 CHECK_STRING(string);
3586 length = XSTRING_CHAR_LENGTH(string);
3587 /* We need to allocate enough room for decoding the text. */
3588 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3590 input = make_lisp_string_input_stream(string, 0, -1);
3591 decoded_length = base64_decode_1(XLSTREAM(input), decoded,
3592 &cc_decoded_length);
3593 if (decoded_length > length * MAX_EMCHAR_LEN) {
3596 Lstream_delete(XLSTREAM(input));
3598 result = make_string(decoded, decoded_length);
3599 XMALLOC_UNBIND(decoded, length * MAX_EMCHAR_LEN, speccount);
3603 /* base16 encode/decode functions. */
3605 base16_encode_1(Lstream * istream, int length, Bufbyte * to, int max)
3610 for (i=0; i < length; i++) {
3611 ec = Lstream_get_emchar (istream);
3612 sz = snprintf((char *)to+2*i, 3, "%02x", ec);
3613 assert( sz >= 0 && sz < 3);
3621 base16_decode_1(Lstream * istream, int length, Bufbyte * to)
3624 Emchar high = 0, low = 0;
3625 int high_set_p = 0, ignore_p = 0;
3628 /* high and low perform flip flop operation */
3630 ec = Lstream_get_emchar (istream);
3635 else if (isupper(ec))
3636 low = ec - 'A' + 10;
3637 else if (islower(ec))
3638 low = ec - 'a' + 10;
3642 if (low < 0 || low >= 16)
3650 to[i] = high*16+low;
3660 DEFUN("base16-encode-string", Fbase16_encode_string, 1, 1, 0, /*
3661 Base16 encode (i.e. hex dump) STRING and return the result.
3662 Optional argument NO-LINE-BREAK means do not break long lines
3669 Lisp_Object input, result;
3671 int speccount = specpdl_depth();
3673 CHECK_STRING(string);
3675 length = XSTRING_CHAR_LENGTH(string);
3677 input = make_lisp_string_input_stream(string, 0, -1);
3678 XMALLOC_ATOMIC_OR_ALLOCA(encoded, sz+1, Bufbyte);
3679 base16_encode_1(XLSTREAM(input), length, encoded, sz);
3680 Lstream_delete(XLSTREAM(input));
3681 result = make_string(encoded, sz);
3682 XMALLOC_UNBIND(encoded, sz+1, speccount);
3684 XSTRING(result)->plist = XSTRING(string)->plist;
3689 DEFUN("base16-decode-string", Fbase16_decode_string, 1, 1, 0, /*
3690 Base16-decode (i.e. read hex data from) STRING and return the result.
3691 Characters out of the base16 alphabet are ignored.
3696 Bytind decoded_length;
3698 Lisp_Object input, result;
3699 int speccount = specpdl_depth();
3701 CHECK_STRING(string);
3703 length = XSTRING_CHAR_LENGTH(string);
3704 /* We need to allocate enough room for decoding the text. */
3705 XMALLOC_ATOMIC_OR_ALLOCA(decoded, length, Bufbyte);
3707 input = make_lisp_string_input_stream(string, 0, -1);
3708 decoded_length = base16_decode_1(XLSTREAM(input), length, decoded);
3709 Lstream_delete(XLSTREAM(input));
3711 /* this result might be raw, we declare it binary */
3712 result = make_ext_string((char *)decoded, decoded_length, Qbinary);
3713 XMALLOC_UNBIND(decoded, length, speccount);
3715 XSTRING(result)->plist = XSTRING(string)->plist;
3720 Lisp_Object Qyes_or_no_p;
3722 DEFUN("foobar", Ffoobar, 2, 2, 0, /*
3726 return make_int(__nbits_right_of(XINT(n), XINT(b)));
3729 void syms_of_fns(void)
3731 INIT_LRECORD_IMPLEMENTATION(bit_vector);
3733 defsymbol(&Qstring_lessp, "string-lessp");
3734 defsymbol(&Qstring_greaterp, "string-greaterp");
3735 defsymbol(&Qidentity, "identity");
3736 defsymbol(&Qyes_or_no_p, "yes-or-no-p");
3742 #if defined(WITH_GMP) && defined(HAVE_MPZ)
3746 DEFSUBR(Fsafe_length);
3747 DEFSUBR(Fstring_equal);
3748 DEFSUBR(Fstring_lessp);
3749 DEFSUBR(Fstring_greaterp);
3750 DEFSUBR(Fstring_modified_tick);
3755 DEFSUBR(Fcopy_list);
3756 DEFSUBR(Fcopy_sequence);
3757 DEFSUBR(Fcopy_alist);
3758 DEFSUBR(Fcopy_tree);
3759 DEFSUBR(Fsubstring);
3768 DEFSUBR(Fold_member);
3772 DEFSUBR(Fold_assoc);
3776 DEFSUBR(Fold_rassoc);
3778 DEFSUBR(Fold_rassq);
3780 DEFSUBR(Fold_delete);
3785 DEFSUBR(Fremrassoc);
3790 DEFSUBR(Fplists_eq);
3791 DEFSUBR(Fplists_equal);
3792 DEFSUBR(Flax_plists_eq);
3793 DEFSUBR(Flax_plists_equal);
3794 DEFSUBR(Fplist_get);
3795 DEFSUBR(Fplist_put);
3796 DEFSUBR(Fplist_remprop);
3797 DEFSUBR(Fplist_member);
3798 DEFSUBR(Fcheck_valid_plist);
3799 DEFSUBR(Fvalid_plist_p);
3800 DEFSUBR(Fcanonicalize_plist);
3801 DEFSUBR(Flax_plist_get);
3802 DEFSUBR(Flax_plist_put);
3803 DEFSUBR(Flax_plist_remprop);
3804 DEFSUBR(Flax_plist_member);
3805 DEFSUBR(Fcanonicalize_lax_plist);
3806 DEFSUBR(Fdestructive_alist_to_plist);
3810 DEFSUBR(Fobject_plist);
3812 DEFSUBR(Fold_equal);
3813 DEFSUBR(Ffillarray);
3815 DEFSUBR(Freplace_list);
3816 DEFSUBR(Fload_average);
3821 DEFSUBR(Fbase64_encode_region);
3822 DEFSUBR(Fbase64_encode_string);
3823 DEFSUBR(Fbase64_decode_region);
3824 DEFSUBR(Fbase64_decode_string);
3825 DEFSUBR(Fbase16_encode_string);
3826 DEFSUBR(Fbase16_decode_string);
3833 void init_provide_once(void)
3835 DEFVAR_LISP("features", &Vfeatures /*
3836 A list of symbols which are the features of the executing emacs.
3837 Used by `featurep' and `require', and altered by `provide'.
3841 Fprovide(intern("base64"));
3842 Fprovide(intern("base16"));
3844 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3845 /* it's fuck ugly to define that here :( */
3846 Fprovide(intern("bdwgc"));