1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
53 /* NOTE: This symbol is also used in lread.c */
54 #define FEATUREP_SYNTAX
56 Lisp_Object Qstring_lessp;
57 Lisp_Object Qidentity;
59 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
62 mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
68 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
71 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
72 int len = bit_vector_length (v);
75 if (INTP (Vprint_length))
76 last = min (len, XINT (Vprint_length));
77 write_c_string ("#*", printcharfun);
78 for (i = 0; i < last; i++)
80 if (bit_vector_bit (v, i))
81 write_c_string ("1", printcharfun);
83 write_c_string ("0", printcharfun);
87 write_c_string ("...", printcharfun);
91 bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
93 struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1);
94 struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2);
96 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
97 !memcmp (v1->bits, v2->bits,
98 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
103 bit_vector_hash (Lisp_Object obj, int depth)
105 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
106 return HASH2 (bit_vector_length (v),
107 memory_hash (v->bits,
108 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
112 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
113 mark_bit_vector, print_bit_vector, 0,
114 bit_vector_equal, bit_vector_hash,
115 struct Lisp_Bit_Vector);
117 DEFUN ("identity", Fidentity, 1, 1, 0, /*
118 Return the argument unchanged.
125 extern long get_random (void);
126 extern void seed_random (long arg);
128 DEFUN ("random", Frandom, 0, 1, 0, /*
129 Return a pseudo-random number.
130 All integers representable in Lisp are equally likely.
131 On most systems, this is 28 bits' worth.
132 With positive integer argument N, return random number in interval [0,N).
133 With argument t, set the random number seed from the current time and pid.
138 unsigned long denominator;
141 seed_random (getpid () + time (NULL));
142 if (NATNUMP (limit) && !ZEROP (limit))
144 /* Try to take our random number from the higher bits of VAL,
145 not the lower, since (says Gentzel) the low bits of `random'
146 are less random than the higher ones. We do this by using the
147 quotient rather than the remainder. At the high end of the RNG
148 it's possible to get a quotient larger than limit; discarding
149 these values eliminates the bias that would otherwise appear
150 when using a large limit. */
151 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
153 val = get_random () / denominator;
154 while (val >= XINT (limit));
159 return make_int (val);
162 /* Random data-structure functions */
164 #ifdef LOSING_BYTECODE
166 /* #### Delete this shit */
168 /* Charcount is a misnomer here as we might be dealing with the
169 length of a vector or list, but emphasizes that we're not dealing
170 with Bytecounts in strings */
172 length_with_bytecode_hack (Lisp_Object seq)
174 if (!COMPILED_FUNCTIONP (seq))
175 return XINT (Flength (seq));
178 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq);
180 return (b->flags.interactivep ? COMPILED_INTERACTIVE :
181 b->flags.domainp ? COMPILED_DOMAIN :
187 #endif /* LOSING_BYTECODE */
190 check_losing_bytecode (CONST char *function, Lisp_Object seq)
192 if (COMPILED_FUNCTIONP (seq))
195 "As of 20.3, `%s' no longer works with compiled-function objects",
199 DEFUN ("length", Flength, 1, 1, 0, /*
200 Return the length of vector, bit vector, list or string SEQUENCE.
205 if (STRINGP (sequence))
206 return make_int (XSTRING_CHAR_LENGTH (sequence));
207 else if (CONSP (sequence))
212 EXTERNAL_LIST_LOOP (tail, sequence)
220 else if (VECTORP (sequence))
221 return make_int (XVECTOR_LENGTH (sequence));
222 else if (NILP (sequence))
224 else if (BIT_VECTORP (sequence))
225 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
228 check_losing_bytecode ("length", sequence);
229 sequence = wrong_type_argument (Qsequencep, sequence);
234 /* This does not check for quits. That is safe
235 since it must terminate. */
237 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
238 Return the length of a list, but avoid error or infinite loop.
239 This function never gets an error. If LIST is not really a list,
240 it returns 0. If LIST is circular, it returns a finite value
241 which is at least the number of distinct elements.
245 Lisp_Object halftail = list; /* Used to detect circular lists. */
249 for (tail = list; CONSP (tail); tail = XCDR (tail))
251 if (EQ (tail, halftail) && len != 0)
255 halftail = XCDR (halftail);
258 return make_int (len);
261 /*** string functions. ***/
263 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
264 Return t if two strings have identical contents.
265 Case is significant. Text properties are ignored.
266 \(Under XEmacs, `equal' also ignores text properties and extents in
267 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
268 `equal' is the same as in XEmacs, in that respect.)
269 Symbols are also allowed; their print names are used instead.
274 struct Lisp_String *p1, *p2;
277 p1 = XSYMBOL (s1)->name;
285 p2 = XSYMBOL (s2)->name;
292 return (((len = string_length (p1)) == string_length (p2)) &&
293 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
297 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
298 Return t if first arg string is less than second in lexicographic order.
299 If I18N2 support (but not Mule support) was compiled in, ordering is
300 determined by the locale. (Case is significant for the default C locale.)
301 In all other cases, comparison is simply done on a character-by-
302 character basis using the numeric value of a character. (Note that
303 this may not produce particularly meaningful results under Mule if
304 characters from different charsets are being compared.)
306 Symbols are also allowed; their print names are used instead.
308 The reason that the I18N2 locale-specific collation is not used under
309 Mule is that the locale model of internationalization does not handle
310 multiple charsets and thus has no hope of working properly under Mule.
311 What we really should do is create a collation table over all built-in
312 charsets. This is extremely difficult to do from scratch, however.
314 Unicode is a good first step towards solving this problem. In fact,
315 it is quite likely that a collation table exists (or will exist) for
316 Unicode. When Unicode support is added to XEmacs/Mule, this problem
321 struct Lisp_String *p1, *p2;
326 p1 = XSYMBOL (s1)->name;
334 p2 = XSYMBOL (s2)->name;
341 end = string_char_length (p1);
342 len2 = string_char_length (p2);
346 #if defined (I18N2) && !defined (MULE)
347 /* There is no hope of this working under Mule. Even if we converted
348 the data into an external format so that strcoll() processed it
349 properly, it would still not work because strcoll() does not
350 handle multiple locales. This is the fundamental flaw in the
352 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
353 /* Compare strings using collation order of locale. */
354 /* Need to be tricky to handle embedded nulls. */
356 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
358 int val = strcoll ((char *) string_data (p1) + i,
359 (char *) string_data (p2) + i);
365 #else /* not I18N2, or MULE */
366 /* #### It is not really necessary to do this: We could compare
367 byte-by-byte and still get a reasonable comparison, since this
368 would compare characters with a charset in the same way.
369 With a little rearrangement of the leading bytes, we could
370 make most inter-charset comparisons work out the same, too;
371 even if some don't, this is not a big deal because inter-charset
372 comparisons aren't really well-defined anyway. */
373 for (i = 0; i < end; i++)
375 if (string_char (p1, i) != string_char (p2, i))
376 return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
378 #endif /* not I18N2, or MULE */
379 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
380 won't work right in I18N2 case */
381 return end < len2 ? Qt : Qnil;
384 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
385 Return STRING's tick counter, incremented for each change to the string.
386 Each string has a tick counter which is incremented each time the contents
387 of the string are changed (e.g. with `aset'). It wraps around occasionally.
391 struct Lisp_String *s;
393 CHECK_STRING (string);
394 s = XSTRING (string);
395 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
396 return XCAR (s->plist);
402 bump_string_modiff (Lisp_Object str)
404 struct Lisp_String *s = XSTRING (str);
405 Lisp_Object *ptr = &s->plist;
408 /* #### remove the `string-translatable' property from the string,
411 /* skip over extent info if it's there */
412 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
414 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
415 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
417 *ptr = Fcons (make_int (1), *ptr);
421 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
422 static Lisp_Object concat (int nargs, Lisp_Object *args,
423 enum concat_target_type target_type,
427 concat2 (Lisp_Object s1, Lisp_Object s2)
432 return concat (2, args, c_string, 0);
436 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
442 return concat (3, args, c_string, 0);
446 vconcat2 (Lisp_Object s1, Lisp_Object s2)
451 return concat (2, args, c_vector, 0);
455 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
461 return concat (3, args, c_vector, 0);
464 DEFUN ("append", Fappend, 0, MANY, 0, /*
465 Concatenate all the arguments and make the result a list.
466 The result is a list whose elements are the elements of all the arguments.
467 Each argument may be a list, vector, bit vector, or string.
468 The last argument is not copied, just used as the tail of the new list.
471 (int nargs, Lisp_Object *args))
473 return concat (nargs, args, c_cons, 1);
476 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
477 Concatenate all the arguments and make the result a string.
478 The result is a string whose elements are the elements of all the arguments.
479 Each argument may be a string or a list or vector of characters.
481 As of XEmacs 21.0, this function does NOT accept individual integers
482 as arguments. Old code that relies on, for example, (concat "foo" 50)
483 returning "foo50" will fail. To fix such code, either apply
484 `int-to-string' to the integer argument, or use `format'.
486 (int nargs, Lisp_Object *args))
488 return concat (nargs, args, c_string, 0);
491 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
492 Concatenate all the arguments and make the result a vector.
493 The result is a vector whose elements are the elements of all the arguments.
494 Each argument may be a list, vector, bit vector, or string.
496 (int nargs, Lisp_Object *args))
498 return concat (nargs, args, c_vector, 0);
501 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
502 Concatenate all the arguments and make the result a bit vector.
503 The result is a bit vector whose elements are the elements of all the
504 arguments. Each argument may be a list, vector, bit vector, or string.
506 (int nargs, Lisp_Object *args))
508 return concat (nargs, args, c_bit_vector, 0);
511 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
512 Return a copy of a list, vector, bit vector or string.
513 The elements of a list or vector are not copied; they are shared
519 if (NILP (arg)) return arg;
520 /* We handle conses separately because concat() is big and hairy and
521 doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
522 than to fix concat() without worrying about breaking other things.
526 Lisp_Object head = Fcons (XCAR (arg), XCDR (arg));
527 Lisp_Object tail = head;
529 for (arg = XCDR (arg); CONSP (arg); arg = XCDR (arg))
531 XCDR (tail) = Fcons (XCAR (arg), XCDR (arg));
537 if (STRINGP (arg)) return concat (1, &arg, c_string, 0);
538 if (VECTORP (arg)) return concat (1, &arg, c_vector, 0);
539 if (BIT_VECTORP (arg)) return concat (1, &arg, c_bit_vector, 0);
541 check_losing_bytecode ("copy-sequence", arg);
542 arg = wrong_type_argument (Qsequencep, arg);
546 struct merge_string_extents_struct
549 Bytecount entry_offset;
550 Bytecount entry_length;
554 concat (int nargs, Lisp_Object *args,
555 enum concat_target_type target_type,
559 Lisp_Object tail = Qnil;
562 Lisp_Object last_tail;
564 struct merge_string_extents_struct *args_mse = 0;
565 Bufbyte *string_result = 0;
566 Bufbyte *string_result_ptr = 0;
569 /* The modus operandi in Emacs is "caller gc-protects args".
570 However, concat is called many times in Emacs on freshly
571 created stuff. So we help those callers out by protecting
572 the args ourselves to save them a lot of temporary-variable
576 gcpro1.nvars = nargs;
579 /* #### if the result is a string and any of the strings have a string
580 for the `string-translatable' property, then concat should also
581 concat the args but use the `string-translatable' strings, and store
582 the result in the returned string's `string-translatable' property. */
584 if (target_type == c_string)
585 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
587 /* In append, the last arg isn't treated like the others */
588 if (last_special && nargs > 0)
591 last_tail = args[nargs];
596 /* Check and coerce the arguments. */
597 for (argnum = 0; argnum < nargs; argnum++)
599 Lisp_Object seq = args[argnum];
602 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
604 #ifdef LOSING_BYTECODE
605 else if (COMPILED_FUNCTIONP (seq))
606 /* Urk! We allow this, for "compatibility"... */
609 #if 0 /* removed for XEmacs 21 */
611 /* This is too revolting to think about but maintains
612 compatibility with FSF (and lots and lots of old code). */
613 args[argnum] = Fnumber_to_string (seq);
617 check_losing_bytecode ("concat", seq);
618 args[argnum] = wrong_type_argument (Qsequencep, seq);
624 args_mse[argnum].string = seq;
626 args_mse[argnum].string = Qnil;
631 /* Charcount is a misnomer here as we might be dealing with the
632 length of a vector or list, but emphasizes that we're not dealing
633 with Bytecounts in strings */
634 Charcount total_length;
636 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
638 #ifdef LOSING_BYTECODE
639 Charcount thislen = length_with_bytecode_hack (args[argnum]);
641 Charcount thislen = XINT (Flength (args[argnum]));
643 total_length += thislen;
649 if (total_length == 0)
650 /* In append, if all but last arg are nil, return last arg */
651 RETURN_UNGCPRO (last_tail);
652 val = Fmake_list (make_int (total_length), Qnil);
655 val = make_vector (total_length, Qnil);
658 val = make_bit_vector (total_length, Qzero);
661 /* We don't make the string yet because we don't know the
662 actual number of bytes. This loop was formerly written
663 to call Fmake_string() here and then call set_string_char()
664 for each char. This seems logical enough but is waaaaaaaay
665 slow -- set_string_char() has to scan the whole string up
666 to the place where the substitution is called for in order
667 to find the place to change, and may have to do some
668 realloc()ing in order to make the char fit properly.
671 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
672 string_result_ptr = string_result;
681 tail = val, toindex = -1; /* -1 in toindex is flag we are
688 for (argnum = 0; argnum < nargs; argnum++)
690 Charcount thisleni = 0;
691 Charcount thisindex = 0;
692 Lisp_Object seq = args[argnum];
693 Bufbyte *string_source_ptr = 0;
694 Bufbyte *string_prev_result_ptr = string_result_ptr;
698 #ifdef LOSING_BYTECODE
699 thisleni = length_with_bytecode_hack (seq);
701 thisleni = XINT (Flength (seq));
705 string_source_ptr = XSTRING_DATA (seq);
711 /* We've come to the end of this arg, so exit. */
715 /* Fetch next element of `seq' arg into `elt' */
723 if (thisindex >= thisleni)
728 elt = make_char (charptr_emchar (string_source_ptr));
729 INC_CHARPTR (string_source_ptr);
731 else if (VECTORP (seq))
732 elt = XVECTOR_DATA (seq)[thisindex];
733 else if (BIT_VECTORP (seq))
734 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
737 elt = Felt (seq, make_int (thisindex));
741 /* Store into result */
744 /* toindex negative means we are making a list */
749 else if (VECTORP (val))
750 XVECTOR_DATA (val)[toindex++] = elt;
751 else if (BIT_VECTORP (val))
754 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
758 CHECK_CHAR_COERCE_INT (elt);
759 string_result_ptr += set_charptr_emchar (string_result_ptr,
765 args_mse[argnum].entry_offset =
766 string_prev_result_ptr - string_result;
767 args_mse[argnum].entry_length =
768 string_result_ptr - string_prev_result_ptr;
772 /* Now we finally make the string. */
773 if (target_type == c_string)
775 val = make_string (string_result, string_result_ptr - string_result);
776 for (argnum = 0; argnum < nargs; argnum++)
778 if (STRINGP (args_mse[argnum].string))
779 copy_string_extents (val, args_mse[argnum].string,
780 args_mse[argnum].entry_offset, 0,
781 args_mse[argnum].entry_length);
786 XCDR (prev) = last_tail;
788 RETURN_UNGCPRO (val);
791 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
792 Return a copy of ALIST.
793 This is an alist which represents the same mapping from objects to objects,
794 but does not share the alist structure with ALIST.
795 The objects mapped (cars and cdrs of elements of the alist)
797 Elements of ALIST that are not conses are also shared.
807 alist = concat (1, &alist, c_cons, 0);
808 for (tail = alist; CONSP (tail); tail = XCDR (tail))
810 Lisp_Object car = XCAR (tail);
813 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
818 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
819 Return a copy of a list and substructures.
820 The argument is copied, and any lists contained within it are copied
821 recursively. Circularities and shared substructures are not preserved.
822 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
830 rest = arg = Fcopy_sequence (arg);
833 Lisp_Object elt = XCAR (rest);
835 if (CONSP (elt) || VECTORP (elt))
836 XCAR (rest) = Fcopy_tree (elt, vecp);
837 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
838 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
842 else if (VECTORP (arg) && ! NILP (vecp))
844 int i = XVECTOR_LENGTH (arg);
846 arg = Fcopy_sequence (arg);
847 for (j = 0; j < i; j++)
849 Lisp_Object elt = XVECTOR_DATA (arg) [j];
851 if (CONSP (elt) || VECTORP (elt))
852 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
858 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
859 Return a substring of STRING, starting at index FROM and ending before TO.
860 TO may be nil or omitted; then the substring runs to the end of STRING.
861 If FROM or TO is negative, it counts from the end.
862 Relevant parts of the string-extent-data are copied in the new string.
866 Charcount ccfr, ccto;
870 CHECK_STRING (string);
871 /* Historically, FROM could not be omitted. Whatever ... */
873 get_string_range_char (string, from, to, &ccfr, &ccto,
874 GB_HISTORICAL_STRING_BEHAVIOR);
875 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
876 bto = charcount_to_bytecount (XSTRING_DATA (string), ccto);
877 val = make_string (XSTRING_DATA (string) + bfr, bto - bfr);
878 /* Copy any applicable extent information into the new string: */
879 copy_string_extents (val, string, 0, bfr, bto - bfr);
883 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
884 Return a subsequence of SEQ, starting at index FROM and ending before TO.
885 TO may be nil or omitted; then the subsequence runs to the end of SEQ.
886 If FROM or TO is negative, it counts from the end.
887 The resulting subsequence is always the same type as the original
889 If SEQ is a string, relevant parts of the string-extent-data are copied
897 return Fsubstring (seq, from, to);
899 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
901 check_losing_bytecode ("subseq", seq);
902 seq = wrong_type_argument (Qsequencep, seq);
905 len = XINT (Flength (seq));
922 if (!(0 <= f && f <= t && t <= len))
923 args_out_of_range_3 (seq, make_int (f), make_int (t));
927 Lisp_Object result = make_vector (t - f, Qnil);
929 Lisp_Object *in_elts = XVECTOR_DATA (seq);
930 Lisp_Object *out_elts = XVECTOR_DATA (result);
932 for (i = f; i < t; i++)
933 out_elts[i - f] = in_elts[i];
939 Lisp_Object result = Qnil;
942 seq = Fnthcdr (make_int (f), seq);
944 for (i = f; i < t; i++)
946 result = Fcons (Fcar (seq), result);
950 return Fnreverse (result);
955 Lisp_Object result = make_bit_vector (t - f, Qzero);
958 for (i = f; i < t; i++)
959 set_bit_vector_bit (XBIT_VECTOR (result), i - f,
960 bit_vector_bit (XBIT_VECTOR (seq), i));
966 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
967 Take cdr N times on LIST, and return the result.
972 REGISTER Lisp_Object tail = list;
974 for (i = XINT (n); i; i--)
978 else if (NILP (tail))
982 tail = wrong_type_argument (Qlistp, tail);
989 DEFUN ("nth", Fnth, 2, 2, 0, /*
990 Return the Nth element of LIST.
991 N counts from zero. If LIST is not that long, nil is returned.
995 return Fcar (Fnthcdr (n, list));
998 DEFUN ("elt", Felt, 2, 2, 0, /*
999 Return element of SEQUENCE at index N.
1004 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1005 if (LISTP (sequence))
1007 Lisp_Object tem = Fnthcdr (n, sequence);
1008 /* #### Utterly, completely, fucking disgusting.
1009 * #### The whole point of "elt" is that it operates on
1010 * #### sequences, and does error- (bounds-) checking.
1016 /* This is The Way It Has Always Been. */
1019 /* This is The Way Mly and Cltl2 say It Should Be. */
1020 args_out_of_range (sequence, n);
1023 else if (STRINGP (sequence)
1024 || VECTORP (sequence)
1025 || BIT_VECTORP (sequence))
1026 return Faref (sequence, n);
1027 #ifdef LOSING_BYTECODE
1028 else if (COMPILED_FUNCTIONP (sequence))
1034 args_out_of_range (sequence, n);
1036 /* Utter perversity */
1038 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence);
1041 case COMPILED_ARGLIST:
1043 case COMPILED_BYTECODE:
1044 return b->bytecodes;
1045 case COMPILED_CONSTANTS:
1046 return b->constants;
1047 case COMPILED_STACK_DEPTH:
1048 return make_int (b->maxdepth);
1049 case COMPILED_DOC_STRING:
1050 return compiled_function_documentation (b);
1051 case COMPILED_DOMAIN:
1052 return compiled_function_domain (b);
1053 case COMPILED_INTERACTIVE:
1054 if (b->flags.interactivep)
1055 return compiled_function_interactive (b);
1056 /* if we return nil, can't tell interactive with no args
1057 from noninteractive. */
1064 #endif /* LOSING_BYTECODE */
1067 check_losing_bytecode ("elt", sequence);
1068 sequence = wrong_type_argument (Qsequencep, sequence);
1073 DEFUN ("member", Fmember, 2, 2, 0, /*
1074 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1075 The value is actually the tail of LIST whose car is ELT.
1079 REGISTER Lisp_Object tail;
1080 LIST_LOOP (tail, list)
1082 CONCHECK_CONS (tail);
1083 if (internal_equal (elt, XCAR (tail), 0))
1090 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1091 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1092 The value is actually the tail of LIST whose car is ELT.
1093 This function is provided only for byte-code compatibility with v19.
1098 REGISTER Lisp_Object tail;
1099 LIST_LOOP (tail, list)
1101 CONCHECK_CONS (tail);
1102 if (internal_old_equal (elt, XCAR (tail), 0))
1109 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1110 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1111 The value is actually the tail of LIST whose car is ELT.
1115 REGISTER Lisp_Object tail;
1116 LIST_LOOP (tail, list)
1118 REGISTER Lisp_Object tem;
1119 CONCHECK_CONS (tail);
1120 if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
1127 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1128 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1129 The value is actually the tail of LIST whose car is ELT.
1130 This function is provided only for byte-code compatibility with v19.
1135 REGISTER Lisp_Object tail;
1136 LIST_LOOP (tail, list)
1138 REGISTER Lisp_Object tem;
1139 CONCHECK_CONS (tail);
1140 if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
1148 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1150 REGISTER Lisp_Object tail;
1151 for (tail = list; CONSP (tail); tail = XCDR (tail))
1153 REGISTER Lisp_Object tem;
1154 if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
1160 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1161 Return non-nil if KEY is `equal' to the car of an element of LIST.
1162 The value is actually the element of LIST whose car equals KEY.
1166 /* This function can GC. */
1167 REGISTER Lisp_Object tail;
1168 LIST_LOOP (tail, list)
1170 REGISTER Lisp_Object elt;
1171 CONCHECK_CONS (tail);
1173 if (CONSP (elt) && internal_equal (XCAR (elt), key, 0))
1180 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1181 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1182 The value is actually the element of LIST whose car equals KEY.
1186 /* This function can GC. */
1187 REGISTER Lisp_Object tail;
1188 LIST_LOOP (tail, list)
1190 REGISTER Lisp_Object elt;
1191 CONCHECK_CONS (tail);
1193 if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0))
1201 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1203 int speccount = specpdl_depth ();
1204 specbind (Qinhibit_quit, Qt);
1205 return unbind_to (speccount, Fassoc (key, list));
1208 DEFUN ("assq", Fassq, 2, 2, 0, /*
1209 Return non-nil if KEY is `eq' to the car of an element of LIST.
1210 The value is actually the element of LIST whose car is KEY.
1211 Elements of LIST that are not conses are ignored.
1215 REGISTER Lisp_Object tail;
1216 LIST_LOOP (tail, list)
1218 REGISTER Lisp_Object elt, tem;
1219 CONCHECK_CONS (tail);
1221 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1228 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1229 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1230 The value is actually the element of LIST whose car is KEY.
1231 Elements of LIST that are not conses are ignored.
1232 This function is provided only for byte-code compatibility with v19.
1237 REGISTER Lisp_Object tail;
1238 LIST_LOOP (tail, list)
1240 REGISTER Lisp_Object elt, tem;
1241 CONCHECK_CONS (tail);
1243 if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem)))
1250 /* Like Fassq but never report an error and do not allow quits.
1251 Use only on lists known never to be circular. */
1254 assq_no_quit (Lisp_Object key, Lisp_Object list)
1256 /* This cannot GC. */
1257 REGISTER Lisp_Object tail;
1258 for (tail = list; CONSP (tail); tail = XCDR (tail))
1260 REGISTER Lisp_Object tem, elt;
1262 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1268 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1269 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1270 The value is actually the element of LIST whose cdr equals KEY.
1274 REGISTER Lisp_Object tail;
1275 LIST_LOOP (tail, list)
1277 REGISTER Lisp_Object elt;
1278 CONCHECK_CONS (tail);
1280 if (CONSP (elt) && internal_equal (XCDR (elt), key, 0))
1287 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1288 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1289 The value is actually the element of LIST whose cdr equals KEY.
1293 REGISTER Lisp_Object tail;
1294 LIST_LOOP (tail, list)
1296 REGISTER Lisp_Object elt;
1297 CONCHECK_CONS (tail);
1299 if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0))
1306 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1307 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1308 The value is actually the element of LIST whose cdr is KEY.
1312 REGISTER Lisp_Object tail;
1313 LIST_LOOP (tail, list)
1315 REGISTER Lisp_Object elt, tem;
1316 CONCHECK_CONS (tail);
1318 if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1325 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1326 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1327 The value is actually the element of LIST whose cdr is KEY.
1331 REGISTER Lisp_Object tail;
1332 LIST_LOOP (tail, list)
1334 REGISTER Lisp_Object elt, tem;
1335 CONCHECK_CONS (tail);
1337 if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem)))
1345 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1347 REGISTER Lisp_Object tail;
1348 for (tail = list; CONSP (tail); tail = XCDR (tail))
1350 REGISTER Lisp_Object elt, tem;
1352 if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1359 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1360 Delete by side effect any occurrences of ELT as a member of LIST.
1361 The modified LIST is returned. Comparison is done with `equal'.
1362 If the first member of LIST is ELT, there is no way to remove it by side
1363 effect; therefore, write `(setq foo (delete element foo))' to be sure
1364 of changing the value of `foo'.
1369 REGISTER Lisp_Object tail = list;
1370 REGISTER Lisp_Object prev = Qnil;
1372 while (!NILP (tail))
1374 CONCHECK_CONS (tail);
1375 if (internal_equal (elt, XCAR (tail), 0))
1380 XCDR (prev) = XCDR (tail);
1390 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1391 Delete by side effect any occurrences of ELT as a member of LIST.
1392 The modified LIST is returned. Comparison is done with `old-equal'.
1393 If the first member of LIST is ELT, there is no way to remove it by side
1394 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1395 of changing the value of `foo'.
1399 REGISTER Lisp_Object tail = list;
1400 REGISTER Lisp_Object prev = Qnil;
1402 while (!NILP (tail))
1404 CONCHECK_CONS (tail);
1405 if (internal_old_equal (elt, XCAR (tail), 0))
1410 XCDR (prev) = XCDR (tail);
1420 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1421 Delete by side effect any occurrences of ELT as a member of LIST.
1422 The modified LIST is returned. Comparison is done with `eq'.
1423 If the first member of LIST is ELT, there is no way to remove it by side
1424 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1425 changing the value of `foo'.
1429 REGISTER Lisp_Object tail = list;
1430 REGISTER Lisp_Object prev = Qnil;
1432 while (!NILP (tail))
1434 REGISTER Lisp_Object tem;
1435 CONCHECK_CONS (tail);
1436 if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
1441 XCDR (prev) = XCDR (tail);
1451 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1452 Delete by side effect any occurrences of ELT as a member of LIST.
1453 The modified LIST is returned. Comparison is done with `old-eq'.
1454 If the first member of LIST is ELT, there is no way to remove it by side
1455 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1456 changing the value of `foo'.
1460 REGISTER Lisp_Object tail = list;
1461 REGISTER Lisp_Object prev = Qnil;
1463 while (!NILP (tail))
1465 REGISTER Lisp_Object tem;
1466 CONCHECK_CONS (tail);
1467 if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
1472 XCDR (prev) = XCDR (tail);
1482 /* no quit, no errors; be careful */
1485 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1487 REGISTER Lisp_Object tail = list;
1488 REGISTER Lisp_Object prev = Qnil;
1490 while (CONSP (tail))
1492 REGISTER Lisp_Object tem;
1493 if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
1498 XCDR (prev) = XCDR (tail);
1507 /* Be VERY careful with this. This is like delq_no_quit() but
1508 also calls free_cons() on the removed conses. You must be SURE
1509 that no pointers to the freed conses remain around (e.g.
1510 someone else is pointing to part of the list). This function
1511 is useful on internal lists that are used frequently and where
1512 the actual list doesn't escape beyond known code bounds. */
1515 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1517 REGISTER Lisp_Object tail = list;
1518 REGISTER Lisp_Object prev = Qnil;
1519 struct Lisp_Cons *cons_to_free = NULL;
1521 while (CONSP (tail))
1523 REGISTER Lisp_Object tem;
1524 if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
1529 XCDR (prev) = XCDR (tail);
1530 cons_to_free = XCONS (tail);
1537 free_cons (cons_to_free);
1538 cons_to_free = NULL;
1544 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1545 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1546 The modified LIST is returned. If the first member of LIST has a car
1547 that is `equal' to KEY, there is no way to remove it by side effect;
1548 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1553 REGISTER Lisp_Object tail = list;
1554 REGISTER Lisp_Object prev = Qnil;
1556 while (!NILP (tail))
1558 REGISTER Lisp_Object elt;
1559 CONCHECK_CONS (tail);
1561 if (CONSP (elt) && internal_equal (key, XCAR (elt), 0))
1566 XCDR (prev) = XCDR (tail);
1577 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1579 int speccount = specpdl_depth ();
1580 specbind (Qinhibit_quit, Qt);
1581 return unbind_to (speccount, Fremassoc (key, list));
1584 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1585 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1586 The modified LIST is returned. If the first member of LIST has a car
1587 that is `eq' to KEY, there is no way to remove it by side effect;
1588 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1593 REGISTER Lisp_Object tail = list;
1594 REGISTER Lisp_Object prev = Qnil;
1596 while (!NILP (tail))
1598 REGISTER Lisp_Object elt, tem;
1599 CONCHECK_CONS (tail);
1601 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1606 XCDR (prev) = XCDR (tail);
1616 /* no quit, no errors; be careful */
1619 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1621 REGISTER Lisp_Object tail = list;
1622 REGISTER Lisp_Object prev = Qnil;
1624 while (CONSP (tail))
1626 REGISTER Lisp_Object elt, tem;
1628 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
1633 XCDR (prev) = XCDR (tail);
1642 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1643 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1644 The modified LIST is returned. If the first member of LIST has a car
1645 that is `equal' to VALUE, there is no way to remove it by side effect;
1646 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1651 REGISTER Lisp_Object tail = list;
1652 REGISTER Lisp_Object prev = Qnil;
1654 while (!NILP (tail))
1656 REGISTER Lisp_Object elt;
1657 CONCHECK_CONS (tail);
1659 if (CONSP (elt) && internal_equal (value, XCDR (elt), 0))
1664 XCDR (prev) = XCDR (tail);
1674 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1675 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1676 The modified LIST is returned. If the first member of LIST has a car
1677 that is `eq' to VALUE, there is no way to remove it by side effect;
1678 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1683 REGISTER Lisp_Object tail = list;
1684 REGISTER Lisp_Object prev = Qnil;
1686 while (!NILP (tail))
1688 REGISTER Lisp_Object elt, tem;
1689 CONCHECK_CONS (tail);
1691 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
1696 XCDR (prev) = XCDR (tail);
1706 /* no quit, no errors; be careful */
1709 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1711 REGISTER Lisp_Object tail = list;
1712 REGISTER Lisp_Object prev = Qnil;
1714 while (CONSP (tail))
1716 REGISTER Lisp_Object elt, tem;
1718 if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
1723 XCDR (prev) = XCDR (tail);
1732 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1733 Reverse LIST by destructively modifying cdr pointers.
1734 Return the beginning of the reversed list.
1735 Also see: `reverse'.
1739 struct gcpro gcpro1, gcpro2;
1740 REGISTER Lisp_Object prev = Qnil;
1741 REGISTER Lisp_Object tail = list;
1743 /* We gcpro our args; see `nconc' */
1744 GCPRO2 (prev, tail);
1745 while (!NILP (tail))
1747 REGISTER Lisp_Object next;
1749 CONCHECK_CONS (tail);
1759 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1760 Reverse LIST, copying. Return the beginning of the reversed list.
1761 See also the function `nreverse', which is used more often.
1765 REGISTER Lisp_Object tail;
1766 Lisp_Object new = Qnil;
1768 for (tail = list; CONSP (tail); tail = XCDR (tail))
1770 new = Fcons (XCAR (tail), new);
1774 dead_wrong_type_argument (Qlistp, tail);
1778 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1779 Lisp_Object lisp_arg,
1780 int (*pred_fn) (Lisp_Object, Lisp_Object,
1781 Lisp_Object lisp_arg));
1784 list_sort (Lisp_Object list,
1785 Lisp_Object lisp_arg,
1786 int (*pred_fn) (Lisp_Object, Lisp_Object,
1787 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);
1793 int length = XINT (len);
1798 XSETINT (len, (length / 2) - 1);
1799 tem = Fnthcdr (len, list);
1801 Fsetcdr (tem, Qnil);
1803 GCPRO3 (front, back, lisp_arg);
1804 front = list_sort (front, lisp_arg, pred_fn);
1805 back = list_sort (back, lisp_arg, pred_fn);
1807 return list_merge (front, back, lisp_arg, pred_fn);
1812 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1817 /* prevents the GC from happening in call2 */
1818 int speccount = specpdl_depth ();
1819 /* Emacs' GC doesn't actually relocate pointers, so this probably
1820 isn't strictly necessary */
1821 record_unwind_protect (restore_gc_inhibit,
1822 make_int (gc_currently_forbidden));
1823 gc_currently_forbidden = 1;
1824 tmp = call2 (pred, obj1, obj2);
1825 unbind_to (speccount, Qnil);
1833 DEFUN ("sort", Fsort, 2, 2, 0, /*
1834 Sort LIST, stably, comparing elements using PREDICATE.
1835 Returns the sorted list. LIST is modified by side effects.
1836 PREDICATE is called with two elements of LIST, and should return T
1837 if the first element is "less" than the second.
1841 return list_sort (list, pred, merge_pred_function);
1845 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1848 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1853 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1854 Lisp_Object lisp_arg,
1855 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1861 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1868 /* It is sufficient to protect org_l1 and org_l2.
1869 When l1 and l2 are updated, we copy the new values
1870 back into the org_ vars. */
1872 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1893 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1908 Fsetcdr (tail, tem);
1914 /************************************************************************/
1915 /* property-list functions */
1916 /************************************************************************/
1918 /* For properties of text, we need to do order-insensitive comparison of
1919 plists. That is, we need to compare two plists such that they are the
1920 same if they have the same set of keys, and equivalent values.
1921 So (a 1 b 2) would be equal to (b 2 a 1).
1923 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1924 LAXP means use `equal' for comparisons.
1927 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1928 int laxp, int depth)
1930 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
1931 int la, lb, m, i, fill;
1932 Lisp_Object *keys, *vals;
1936 if (NILP (a) && NILP (b))
1939 Fcheck_valid_plist (a);
1940 Fcheck_valid_plist (b);
1942 la = XINT (Flength (a));
1943 lb = XINT (Flength (b));
1944 m = (la > lb ? la : lb);
1946 keys = alloca_array (Lisp_Object, m);
1947 vals = alloca_array (Lisp_Object, m);
1948 flags = alloca_array (char, m);
1950 /* First extract the pairs from A. */
1951 for (rest = a; !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)) continue;
1962 /* Now iterate over B, and stop if we find something that's not in A,
1963 or that doesn't match. As we match, mark them. */
1964 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1966 Lisp_Object k = XCAR (rest);
1967 Lisp_Object v = XCAR (XCDR (rest));
1968 /* Maybe be Ebolified. */
1969 if (nil_means_not_present && NILP (v)) continue;
1970 for (i = 0; i < fill; i++)
1972 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1975 /* We narrowly escaped being Ebolified here. */
1976 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1977 : !internal_equal (v, vals [i], depth)))
1978 /* a property in B has a different value than in A */
1985 /* there are some properties in B that are not in A */
1988 /* Now check to see that all the properties in A were also in B */
1989 for (i = 0; i < fill; i++)
2000 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
2001 Return non-nil if property lists A and B are `eq'.
2002 A property list is an alternating list of keywords and values.
2003 This function does order-insensitive comparisons of the property lists:
2004 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2005 Comparison between values is done using `eq'. See also `plists-equal'.
2006 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2007 a nil value is ignored. This feature is a virus that has infected
2008 old Lisp implementations, but should not be used except for backward
2011 (a, b, nil_means_not_present))
2013 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
2017 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
2018 Return non-nil if property lists A and B are `equal'.
2019 A property list is an alternating list of keywords and values. This
2020 function does order-insensitive comparisons of the property lists: For
2021 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2022 Comparison between values is done using `equal'. See also `plists-eq'.
2023 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2024 a nil value is ignored. This feature is a virus that has infected
2025 old Lisp implementations, but should not be used except for backward
2028 (a, b, nil_means_not_present))
2030 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
2035 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
2036 Return non-nil if lax property lists A and B are `eq'.
2037 A property list is an alternating list of keywords and values.
2038 This function does order-insensitive comparisons of the property lists:
2039 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2040 Comparison between values is done using `eq'. See also `plists-equal'.
2041 A lax property list is like a regular one except that comparisons between
2042 keywords is done using `equal' instead of `eq'.
2043 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2044 a nil value is ignored. This feature is a virus that has infected
2045 old Lisp implementations, but should not be used except for backward
2048 (a, b, nil_means_not_present))
2050 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
2054 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2055 Return non-nil if lax property lists A and B are `equal'.
2056 A property list is an alternating list of keywords and values. This
2057 function does order-insensitive comparisons of the property lists: For
2058 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
2059 Comparison between values is done using `equal'. See also `plists-eq'.
2060 A lax property list is like a regular one except that comparisons between
2061 keywords is done using `equal' instead of `eq'.
2062 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2063 a nil value is ignored. This feature is a virus that has infected
2064 old Lisp implementations, but should not be used except for backward
2067 (a, b, nil_means_not_present))
2069 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
2073 /* Return the value associated with key PROPERTY in property list PLIST.
2074 Return nil if key not found. This function is used for internal
2075 property lists that cannot be directly manipulated by the user.
2079 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2081 Lisp_Object tail = plist;
2083 for (; !NILP (tail); tail = XCDR (XCDR (tail)))
2085 struct Lisp_Cons *c = XCONS (tail);
2086 if (EQ (c->car, property))
2087 return XCAR (c->cdr);
2093 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2094 internal_plist_get(). */
2097 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2102 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2104 if (EQ (XCAR (tail), property))
2106 XCAR (XCDR (tail)) = value;
2111 *plist = Fcons (property, Fcons (value, *plist));
2115 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2117 Lisp_Object tail = *plist;
2122 if (EQ (XCAR (tail), property))
2124 *plist = XCDR (XCDR (tail));
2128 for (tail = XCDR (tail); !NILP (XCDR (tail));
2129 tail = XCDR (XCDR (tail)))
2131 struct Lisp_Cons *c = XCONS (tail);
2132 if (EQ (XCAR (c->cdr), property))
2134 c->cdr = XCDR (XCDR (c->cdr));
2142 /* Called on a malformed property list. BADPLACE should be some
2143 place where truncating will form a good list -- i.e. we shouldn't
2144 result in a list with an odd length. */
2147 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2149 if (ERRB_EQ (errb, ERROR_ME))
2150 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2153 if (ERRB_EQ (errb, ERROR_ME_WARN))
2155 warn_when_safe_lispobj
2158 ("Malformed property list -- list has been truncated"),
2166 /* Called on a circular property list. BADPLACE should be some place
2167 where truncating will result in an even-length list, as above.
2168 If doesn't particularly matter where we truncate -- anywhere we
2169 truncate along the entire list will break the circularity, because
2170 it will create a terminus and the list currently doesn't have one.
2174 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2176 if (ERRB_EQ (errb, ERROR_ME))
2177 /* #### Eek, this will probably result in another error
2178 when PLIST is printed out */
2179 return Fsignal (Qcircular_property_list, list1 (*plist));
2182 if (ERRB_EQ (errb, ERROR_ME_WARN))
2184 warn_when_safe_lispobj
2187 ("Circular property list -- list has been truncated"),
2195 /* Advance the tortoise pointer by two (one iteration of a property-list
2196 loop) and the hare pointer by four and verify that no malformations
2197 or circularities exist. If so, return zero and store a value into
2198 RETVAL that should be returned by the calling function. Otherwise,
2199 return 1. See external_plist_get().
2203 advance_plist_pointers (Lisp_Object *plist,
2204 Lisp_Object **tortoise, Lisp_Object **hare,
2205 Error_behavior errb, Lisp_Object *retval)
2208 Lisp_Object *tortsave = *tortoise;
2210 /* Note that our "fixing" may be more brutal than necessary,
2211 but it's the user's own problem, not ours. if they went in and
2212 manually fucked up a plist. */
2214 for (i = 0; i < 2; i++)
2216 /* This is a standard iteration of a defensive-loop-checking
2217 loop. We just do it twice because we want to advance past
2218 both the property and its value.
2220 If the pointer indirection is confusing you, remember that
2221 one level of indirection on the hare and tortoise pointers
2222 is only due to pass-by-reference for this function. The other
2223 level is so that the plist can be fixed in place. */
2225 /* When we reach the end of a well-formed plist, **HARE is
2226 nil. In that case, we don't do anything at all except
2227 advance TORTOISE by one. Otherwise, we advance HARE
2228 by two (making sure it's OK to do so), then advance
2229 TORTOISE by one (it will always be OK to do so because
2230 the HARE is always ahead of the TORTOISE and will have
2231 already verified the path), then make sure TORTOISE and
2232 HARE don't contain the same non-nil object -- if the
2233 TORTOISE and the HARE ever meet, then obviously we're
2234 in a circularity, and if we're in a circularity, then
2235 the TORTOISE and the HARE can't cross paths without
2236 meeting, since the HARE only gains one step over the
2237 TORTOISE per iteration. */
2241 Lisp_Object *haresave = *hare;
2242 if (!CONSP (**hare))
2244 *retval = bad_bad_bunny (plist, haresave, errb);
2247 *hare = &XCDR (**hare);
2248 /* In a non-plist, we'd check here for a nil value for
2249 **HARE, which is OK (it just means the list has an
2250 odd number of elements). In a plist, it's not OK
2251 for the list to have an odd number of elements. */
2252 if (!CONSP (**hare))
2254 *retval = bad_bad_bunny (plist, haresave, errb);
2257 *hare = &XCDR (**hare);
2260 *tortoise = &XCDR (**tortoise);
2261 if (!NILP (**hare) && EQ (**tortoise, **hare))
2263 *retval = bad_bad_turtle (plist, tortsave, errb);
2271 /* Return the value of PROPERTY from PLIST, or Qunbound if
2272 property is not on the list.
2274 PLIST is a Lisp-accessible property list, meaning that it
2275 has to be checked for malformations and circularities.
2277 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2278 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2279 on finding a malformation or a circularity, it issues a warning and
2280 attempts to silently fix the problem.
2282 A pointer to PLIST is passed in so that PLIST can be successfully
2283 "fixed" even if the error is at the beginning of the plist. */
2286 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2287 int laxp, Error_behavior errb)
2289 Lisp_Object *tortoise = plist;
2290 Lisp_Object *hare = plist;
2292 while (!NILP (*tortoise))
2294 Lisp_Object *tortsave = tortoise;
2297 /* We do the standard tortoise/hare march. We isolate the
2298 grungy stuff to do this in advance_plist_pointers(), though.
2299 To us, all this function does is advance the tortoise
2300 pointer by two and the hare pointer by four and make sure
2301 everything's OK. We first advance the pointers and then
2302 check if a property matched; this ensures that our
2303 check for a matching property is safe. */
2305 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2308 if (!laxp ? EQ (XCAR (*tortsave), property)
2309 : internal_equal (XCAR (*tortsave), property, 0))
2310 return XCAR (XCDR (*tortsave));
2316 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2317 malformed or circular plist. Analogous to external_plist_get(). */
2320 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2321 Lisp_Object value, int laxp, Error_behavior errb)
2323 Lisp_Object *tortoise = plist;
2324 Lisp_Object *hare = plist;
2326 while (!NILP (*tortoise))
2328 Lisp_Object *tortsave = tortoise;
2332 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2335 if (!laxp ? EQ (XCAR (*tortsave), property)
2336 : internal_equal (XCAR (*tortsave), property, 0))
2338 XCAR (XCDR (*tortsave)) = value;
2343 *plist = Fcons (property, Fcons (value, *plist));
2347 external_remprop (Lisp_Object *plist, Lisp_Object property,
2348 int laxp, Error_behavior errb)
2350 Lisp_Object *tortoise = plist;
2351 Lisp_Object *hare = plist;
2353 while (!NILP (*tortoise))
2355 Lisp_Object *tortsave = tortoise;
2359 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2362 if (!laxp ? EQ (XCAR (*tortsave), property)
2363 : internal_equal (XCAR (*tortsave), property, 0))
2365 /* Now you see why it's so convenient to have that level
2367 *tortsave = XCDR (XCDR (*tortsave));
2375 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2376 Extract a value from a property list.
2377 PLIST is a property list, which is a list of the form
2378 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2379 corresponding to the given PROP, or DEFAULT if PROP is not
2380 one of the properties on the list.
2382 (plist, prop, default_))
2384 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2390 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2391 Change value in PLIST of PROP to VAL.
2392 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2393 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2394 If PROP is already a property on the list, its value is set to VAL,
2395 otherwise the new PROP VAL pair is added. The new plist is returned;
2396 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2397 The PLIST is modified by side effects.
2401 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2405 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2406 Remove from PLIST the property PROP and its value.
2407 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2408 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2409 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2410 the new value. The PLIST is modified by side effects.
2414 external_remprop (&plist, prop, 0, ERROR_ME);
2418 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2419 Return t if PROP has a value specified in PLIST.
2423 return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt;
2426 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2427 Given a plist, signal an error if there is anything wrong with it.
2428 This means that it's a malformed or circular plist.
2432 Lisp_Object *tortoise;
2438 while (!NILP (*tortoise))
2443 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2451 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2452 Given a plist, return non-nil if its format is correct.
2453 If it returns nil, `check-valid-plist' will signal an error when given
2454 the plist; that means it's a malformed or circular plist or has non-symbols
2459 Lisp_Object *tortoise;
2464 while (!NILP (*tortoise))
2469 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2477 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2478 Destructively remove any duplicate entries from a plist.
2479 In such cases, the first entry applies.
2481 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2482 a nil value is removed. This feature is a virus that has infected
2483 old Lisp implementations, but should not be used except for backward
2486 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2487 return value may not be EQ to the passed-in value, so make sure to
2488 `setq' the value back into where it came from.
2490 (plist, nil_means_not_present))
2492 Lisp_Object head = plist;
2494 Fcheck_valid_plist (plist);
2496 while (!NILP (plist))
2498 Lisp_Object prop = Fcar (plist);
2499 Lisp_Object next = Fcdr (plist);
2501 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2502 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2504 if (EQ (head, plist))
2506 plist = Fcdr (next);
2509 /* external_remprop returns 1 if it removed any property.
2510 We have to loop till it didn't remove anything, in case
2511 the property occurs many times. */
2512 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME));
2513 plist = Fcdr (next);
2519 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2520 Extract a value from a lax property list.
2522 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2523 VALUE1 PROP2 VALUE2...), where comparions between properties is done
2524 using `equal' instead of `eq'. This function returns the value
2525 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2526 properties on the list.
2528 (lax_plist, prop, default_))
2530 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2536 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2537 Change value in LAX-PLIST of PROP to VAL.
2538 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2539 VALUE1 PROP2 VALUE2...), where comparions between properties is done
2540 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2541 any object. If PROP is already a property on the list, its value is
2542 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2543 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2544 use the new value. The LAX-PLIST is modified by side effects.
2546 (lax_plist, prop, val))
2548 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2552 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2553 Remove from LAX-PLIST the property PROP and its value.
2554 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2555 VALUE1 PROP2 VALUE2...), where comparions between properties is done
2556 using `equal' instead of `eq'. PROP is usually a symbol. The new
2557 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2558 sure to use the new value. The LAX-PLIST is modified by side effects.
2562 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2566 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2567 Return t if PROP has a value specified in LAX-PLIST.
2568 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2569 VALUE1 PROP2 VALUE2...), where comparions between properties is done
2570 using `equal' instead of `eq'.
2574 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2577 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2578 Destructively remove any duplicate entries from a lax plist.
2579 In such cases, the first entry applies.
2581 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2582 a nil value is removed. This feature is a virus that has infected
2583 old Lisp implementations, but should not be used except for backward
2586 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2587 return value may not be EQ to the passed-in value, so make sure to
2588 `setq' the value back into where it came from.
2590 (lax_plist, nil_means_not_present))
2592 Lisp_Object head = lax_plist;
2594 Fcheck_valid_plist (lax_plist);
2596 while (!NILP (lax_plist))
2598 Lisp_Object prop = Fcar (lax_plist);
2599 Lisp_Object next = Fcdr (lax_plist);
2601 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2602 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2604 if (EQ (head, lax_plist))
2606 lax_plist = Fcdr (next);
2609 /* external_remprop returns 1 if it removed any property.
2610 We have to loop till it didn't remove anything, in case
2611 the property occurs many times. */
2612 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME));
2613 lax_plist = Fcdr (next);
2619 /* In C because the frame props stuff uses it */
2621 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2622 Convert association list ALIST into the equivalent property-list form.
2623 The plist is returned. This converts from
2625 \((a . 1) (b . 2) (c . 3))
2631 The original alist is destroyed in the process of constructing the plist.
2632 See also `alist-to-plist'.
2636 Lisp_Object head = alist;
2637 while (!NILP (alist))
2639 /* remember the alist element. */
2640 Lisp_Object el = Fcar (alist);
2642 Fsetcar (alist, Fcar (el));
2643 Fsetcar (el, Fcdr (el));
2644 Fsetcdr (el, Fcdr (alist));
2645 Fsetcdr (alist, el);
2646 alist = Fcdr (Fcdr (alist));
2652 /* Symbol plists are directly accessible, so we need to protect against
2653 invalid property list structure */
2656 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2658 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2660 return UNBOUNDP (val) ? default_ : val;
2664 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2666 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2670 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2672 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2675 /* We store the string's extent info as the first element of the string's
2676 property list; and the string's MODIFF as the first or second element
2677 of the string's property list (depending on whether the extent info
2678 is present), but only if the string has been modified. This is ugly
2679 but it reduces the memory allocated for the string in the vast
2680 majority of cases, where the string is never modified and has no
2684 static Lisp_Object *
2685 string_plist_ptr (struct Lisp_String *s)
2687 Lisp_Object *ptr = &s->plist;
2689 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2691 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2697 string_getprop (struct Lisp_String *s, Lisp_Object property,
2698 Lisp_Object default_)
2700 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2702 return UNBOUNDP (val) ? default_ : val;
2706 string_putprop (struct Lisp_String *s, Lisp_Object property,
2709 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2713 string_remprop (struct Lisp_String *s, Lisp_Object property)
2715 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2719 string_plist (struct Lisp_String *s)
2721 return *string_plist_ptr (s);
2724 DEFUN ("get", Fget, 2, 3, 0, /*
2725 Return the value of OBJECT's PROPNAME property.
2726 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
2727 If there is no such property, return optional third arg DEFAULT
2728 \(which defaults to `nil'). OBJECT can be a symbol, face, extent,
2729 or string. See also `put', `remprop', and `object-plist'.
2731 (object, propname, default_))
2735 /* Various places in emacs call Fget() and expect it not to quit,
2738 /* It's easiest to treat symbols specially because they may not
2740 if (SYMBOLP (object))
2741 val = symbol_getprop (object, propname, default_);
2742 else if (STRINGP (object))
2743 val = string_getprop (XSTRING (object), propname, default_);
2744 else if (LRECORDP (object))
2746 CONST struct lrecord_implementation
2747 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2750 val = (imp->getprop) (object, propname);
2760 signal_simple_error ("Object type has no properties", object);
2766 DEFUN ("put", Fput, 3, 3, 0, /*
2767 Store OBJECT's PROPNAME property with value VALUE.
2768 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
2769 symbol, face, extent, or string.
2771 For a string, no properties currently have predefined meanings.
2772 For the predefined properties for extents, see `set-extent-property'.
2773 For the predefined properties for faces, see `set-face-property'.
2775 See also `get', `remprop', and `object-plist'.
2777 (object, propname, value))
2779 CHECK_SYMBOL (propname);
2780 CHECK_IMPURE (object);
2782 if (SYMBOLP (object))
2783 symbol_putprop (object, propname, value);
2784 else if (STRINGP (object))
2785 string_putprop (XSTRING (object), propname, value);
2786 else if (LRECORDP (object))
2788 CONST struct lrecord_implementation
2789 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2792 if (! (imp->putprop) (object, propname, value))
2793 signal_simple_error ("Can't set property on object", propname);
2801 signal_simple_error ("Object type has no settable properties", object);
2808 pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
2810 Fput (sym, prop, Fpurecopy (val));
2813 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2814 Remove from OBJECT's property list the property PROPNAME and its
2815 value. OBJECT can be a symbol, face, extent, or string. Returns
2816 non-nil if the property list was actually changed (i.e. if PROPNAME
2817 was present in the property list). See also `get', `put', and
2824 CHECK_SYMBOL (propname);
2825 CHECK_IMPURE (object);
2827 if (SYMBOLP (object))
2828 retval = symbol_remprop (object, propname);
2829 else if (STRINGP (object))
2830 retval = string_remprop (XSTRING (object), propname);
2831 else if (LRECORDP (object))
2833 CONST struct lrecord_implementation
2834 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2837 retval = (imp->remprop) (object, propname);
2839 signal_simple_error ("Can't remove property from object",
2848 signal_simple_error ("Object type has no removable properties", object);
2851 return retval ? Qt : Qnil;
2854 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2855 Return a property list of OBJECT's props.
2856 For a symbol this is equivalent to `symbol-plist'.
2857 Do not modify the property list directly; this may or may not have
2858 the desired effects. (In particular, for a property with a special
2859 interpretation, this will probably have no effect at all.)
2863 if (SYMBOLP (object))
2864 return Fsymbol_plist (object);
2865 else if (STRINGP (object))
2866 return string_plist (XSTRING (object));
2867 else if (LRECORDP (object))
2869 CONST struct lrecord_implementation
2870 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2872 return (imp->plist) (object);
2874 signal_simple_error ("Object type has no properties", object);
2877 signal_simple_error ("Object type has no properties", object);
2884 internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
2887 error ("Stack overflow in equal");
2888 #ifndef LRECORD_CONS
2892 if (EQ_WITH_EBOLA_NOTICE (o1, o2))
2894 /* Note that (equal 20 20.0) should be nil */
2895 else if (XTYPE (o1) != XTYPE (o2))
2897 #ifndef LRECORD_CONS
2898 else if (CONSP (o1))
2900 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
2907 #ifndef LRECORD_VECTOR
2908 else if (VECTORP (o1))
2910 Lisp_Object *v1 = XVECTOR_DATA (o1);
2911 Lisp_Object *v2 = XVECTOR_DATA (o2);
2912 int len = XVECTOR_LENGTH (o1);
2913 if (len != XVECTOR_LENGTH (o2))
2916 if (!internal_equal (*v1++, *v2++, depth + 1))
2921 #ifndef LRECORD_STRING
2922 else if (STRINGP (o1))
2925 return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
2926 !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
2929 else if (LRECORDP (o1))
2931 CONST struct lrecord_implementation
2932 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
2933 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
2936 else if (imp1->equal == 0)
2937 /* EQ-ness of the objects was noticed above */
2940 return (imp1->equal) (o1, o2, depth);
2946 /* Note that we may be calling sub-objects that will use
2947 internal_equal() (instead of internal_old_equal()). Oh well.
2948 We will get an Ebola note if there's any possibility of confusion,
2949 but that seems unlikely. */
2952 internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth)
2955 error ("Stack overflow in equal");
2956 #ifndef LRECORD_CONS
2960 if (HACKEQ_UNSAFE (o1, o2))
2962 /* Note that (equal 20 20.0) should be nil */
2963 else if (XTYPE (o1) != XTYPE (o2))
2965 #ifndef LRECORD_CONS
2966 else if (CONSP (o1))
2968 if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1))
2975 #ifndef LRECORD_VECTOR
2976 else if (VECTORP (o1))
2979 int len = XVECTOR_LENGTH (o1);
2980 if (len != XVECTOR_LENGTH (o2))
2982 for (indice = 0; indice < len; indice++)
2984 if (!internal_old_equal (XVECTOR_DATA (o1) [indice],
2985 XVECTOR_DATA (o2) [indice],
2992 #ifndef LRECORD_STRING
2993 else if (STRINGP (o1))
2995 Bytecount len = XSTRING_LENGTH (o1);
2996 if (len != XSTRING_LENGTH (o2))
2998 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
3003 else if (LRECORDP (o1))
3005 CONST struct lrecord_implementation
3006 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
3007 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
3010 else if (imp1->equal == 0)
3011 /* EQ-ness of the objects was noticed above */
3014 return (imp1->equal) (o1, o2, depth);
3020 DEFUN ("equal", Fequal, 2, 2, 0, /*
3021 Return t if two Lisp objects have similar structure and contents.
3022 They must have the same data type.
3023 Conses are compared by comparing the cars and the cdrs.
3024 Vectors and strings are compared element by element.
3025 Numbers are compared by value. Symbols must match exactly.
3029 return internal_equal (o1, o2, 0) ? Qt : Qnil;
3032 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
3033 Return t if two Lisp objects have similar structure and contents.
3034 They must have the same data type.
3035 \(Note, however, that an exception is made for characters and integers;
3036 this is known as the "char-int confoundance disease." See `eq' and
3038 This function is provided only for byte-code compatibility with v19.
3043 return internal_old_equal (o1, o2, 0) ? Qt : Qnil;
3047 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
3048 Store each element of ARRAY with ITEM.
3049 ARRAY is a vector, bit vector, or string.
3054 if (STRINGP (array))
3057 struct Lisp_String *s = XSTRING (array);
3058 Charcount len = string_char_length (s);
3060 CHECK_CHAR_COERCE_INT (item);
3061 CHECK_IMPURE (array);
3062 charval = XCHAR (item);
3063 for (i = 0; i < len; i++)
3064 set_string_char (s, i, charval);
3065 bump_string_modiff (array);
3067 else if (VECTORP (array))
3069 Lisp_Object *p = XVECTOR_DATA (array);
3070 int len = XVECTOR_LENGTH (array);
3071 CHECK_IMPURE (array);
3075 else if (BIT_VECTORP (array))
3077 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
3078 int len = bit_vector_length (v);
3081 CHECK_IMPURE (array);
3084 set_bit_vector_bit (v, len, bit);
3088 array = wrong_type_argument (Qarrayp, array);
3095 nconc2 (Lisp_Object s1, Lisp_Object s2)
3097 Lisp_Object args[2];
3100 return Fnconc (2, args);
3103 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
3104 Concatenate any number of lists by altering them.
3105 Only the last argument is not altered, and need not be a list.
3107 If the first argument is nil, there is no way to modify it by side
3108 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
3109 changing the value of `foo'.
3111 (int nargs, Lisp_Object *args))
3114 struct gcpro gcpro1;
3116 /* The modus operandi in Emacs is "caller gc-protects args".
3117 However, nconc (particularly nconc2 ()) is called many times
3118 in Emacs on freshly created stuff (e.g. you see the idiom
3119 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
3120 callers out by protecting the args ourselves to save them
3121 a lot of temporary-variable grief. */
3124 gcpro1.nvars = nargs;
3126 while (argnum < nargs)
3128 Lisp_Object val = args[argnum];
3131 /* Found the first cons, which will be our return value. */
3132 Lisp_Object last = val;
3134 for (argnum++; argnum < nargs; argnum++)
3136 Lisp_Object next = args[argnum];
3138 if (CONSP (next) || argnum == nargs -1)
3140 /* (setcdr (last val) next) */
3141 while (CONSP (XCDR (last)))
3148 else if (NILP (next))
3154 next = wrong_type_argument (next, Qlistp);
3158 RETURN_UNGCPRO (val);
3160 else if (NILP (val))
3162 else if (argnum == nargs - 1) /* last arg? */
3163 RETURN_UNGCPRO (val);
3165 args[argnum] = wrong_type_argument (val, Qlistp);
3167 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3171 /* This is the guts of all mapping functions.
3172 Apply fn to each element of seq, one by one,
3173 storing the results into elements of vals, a C vector of Lisp_Objects.
3174 leni is the length of vals, which should also be the length of seq.
3176 If VALS is a null pointer, do not accumulate the results. */
3179 mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3182 Lisp_Object dummy = Qnil;
3184 struct gcpro gcpro1, gcpro2, gcpro3;
3187 GCPRO3 (dummy, fn, seq);
3191 /* Don't let vals contain any garbage when GC happens. */
3192 for (i = 0; i < leni; i++)
3195 gcpro1.nvars = leni;
3198 /* We need not explicitly protect `tail' because it is used only on
3199 lists, and 1) lists are not relocated and 2) the list is marked
3200 via `seq' so will not be freed */
3204 for (i = 0; i < leni; i++)
3206 dummy = XVECTOR_DATA (seq)[i];
3207 result = call1 (fn, dummy);
3212 else if (BIT_VECTORP (seq))
3214 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3215 for (i = 0; i < leni; i++)
3217 XSETINT (dummy, bit_vector_bit (v, i));
3218 result = call1 (fn, dummy);
3223 else if (STRINGP (seq))
3225 for (i = 0; i < leni; i++)
3227 result = call1 (fn, make_char (string_char (XSTRING (seq), i)));
3232 else /* Must be a list, since Flength did not get an error */
3235 for (i = 0; i < leni; i++)
3237 result = call1 (fn, Fcar (tail));
3247 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3248 Apply FN to each element of SEQ, and concat the results as strings.
3249 In between each pair of results, stick in SEP.
3250 Thus, " " as SEP results in spaces between the values returned by FN.
3254 int len = XINT (Flength (seq));
3257 struct gcpro gcpro1;
3258 int nargs = len + len - 1;
3260 if (nargs < 0) return build_string ("");
3262 args = alloca_array (Lisp_Object, nargs);
3265 mapcar1 (len, args, fn, seq);
3268 for (i = len - 1; i >= 0; i--)
3269 args[i + i] = args[i];
3271 for (i = 1; i < nargs; i += 2)
3274 return Fconcat (nargs, args);
3277 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3278 Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3279 The result is a list just as long as SEQUENCE.
3280 SEQUENCE may be a list, a vector, a bit vector, or a string.
3284 int len = XINT (Flength (seq));
3285 Lisp_Object *args = alloca_array (Lisp_Object, len);
3287 mapcar1 (len, args, fn, seq);
3289 return Flist (len, args);
3292 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3293 Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
3294 The result is a vector of the same length as SEQUENCE.
3295 SEQUENCE may be a list, a vector or a string.
3299 int len = XINT (Flength (seq));
3300 /* Ideally, this should call make_vector_internal, because we don't
3301 need initialization. */
3302 Lisp_Object result = make_vector (len, Qnil);
3303 struct gcpro gcpro1;
3306 mapcar1 (len, XVECTOR_DATA (result), fn, seq);
3312 DEFUN ("mapc", Fmapc, 2, 2, 0, /*
3313 Apply FUNCTION to each element of SEQUENCE.
3314 SEQUENCE may be a list, a vector, a bit vector, or a string.
3315 This function is like `mapcar' but does not accumulate the results,
3316 which is more efficient if you do not use the results.
3320 mapcar1 (XINT (Flength (seq)), 0, fn, seq);
3326 /* #### this function doesn't belong in this file! */
3328 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3329 Return list of 1 minute, 5 minute and 15 minute load averages.
3330 Each of the three load averages is multiplied by 100,
3331 then converted to integer.
3333 When USE-FLOATS is non-nil, floats will be used instead of integers.
3334 These floats are not multiplied by 100.
3336 If the 5-minute or 15-minute load averages are not available, return a
3337 shortened list, containing only those averages which are available.
3339 On some systems, this won't work due to permissions on /dev/kmem,
3340 in which case you can't use this.
3345 int loads = getloadavg (load_ave, countof (load_ave));
3346 Lisp_Object ret = Qnil;
3349 error ("load-average not implemented for this operating system");
3351 signal_simple_error ("Could not get load-average",
3352 lisp_strerror (errno));
3356 Lisp_Object load = (NILP (use_floats) ?
3357 make_int ((int) (100.0 * load_ave[loads]))
3358 : make_float (load_ave[loads]));
3359 ret = Fcons (load, ret);
3365 Lisp_Object Vfeatures;
3367 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3368 Return non-nil if feature FEXP is present in this Emacs.
3369 Use this to conditionalize execution of lisp code based on the
3370 presence or absence of emacs or environment extensions.
3371 FEXP can be a symbol, a number, or a list.
3372 If it is a symbol, that symbol is looked up in the `features' variable,
3373 and non-nil will be returned if found.
3374 If it is a number, the function will return non-nil if this Emacs
3375 has an equal or greater version number than FEXP.
3376 If it is a list whose car is the symbol `and', it will return
3377 non-nil if all the features in its cdr are non-nil.
3378 If it is a list whose car is the symbol `or', it will return non-nil
3379 if any of the features in its cdr are non-nil.
3380 If it is a list whose car is the symbol `not', it will return
3381 non-nil if the feature is not present.
3386 => ; Non-nil on XEmacs.
3388 (featurep '(and xemacs gnus))
3389 => ; Non-nil on XEmacs with Gnus loaded.
3391 (featurep '(or tty-frames (and emacs 19.30)))
3392 => ; Non-nil if this Emacs supports TTY frames.
3394 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3395 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3397 NOTE: The advanced arguments of this function (anything other than a
3398 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3399 for supporting multiple Emacs variants, lobby Richard Stallman at
3400 <bug-gnu-emacs@prep.ai.mit.edu>.
3404 #ifndef FEATUREP_SYNTAX
3405 CHECK_SYMBOL (fexp);
3406 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3407 #else /* FEATUREP_SYNTAX */
3408 static double featurep_emacs_version;
3410 /* Brute force translation from Erik Naggum's lisp function. */
3413 /* Original definition */
3414 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3416 else if (INTP (fexp) || FLOATP (fexp))
3418 double d = extract_float (fexp);
3420 if (featurep_emacs_version == 0.0)
3422 featurep_emacs_version = XINT (Vemacs_major_version) +
3423 (XINT (Vemacs_minor_version) / 100.0);
3425 return featurep_emacs_version >= d ? Qt : Qnil;
3427 else if (CONSP (fexp))
3429 Lisp_Object tem = XCAR (fexp);
3435 negate = Fcar (tem);
3437 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3439 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3441 else if (EQ (tem, Qand))
3444 /* Use Fcar/Fcdr for error-checking. */
3445 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3449 return NILP (tem) ? Qt : Qnil;
3451 else if (EQ (tem, Qor))
3454 /* Use Fcar/Fcdr for error-checking. */
3455 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3459 return NILP (tem) ? Qnil : Qt;
3463 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3468 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3471 #endif /* FEATUREP_SYNTAX */
3473 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3474 Announce that FEATURE is a feature of the current Emacs.
3475 This function updates the value of the variable `features'.
3480 CHECK_SYMBOL (feature);
3481 if (!NILP (Vautoload_queue))
3482 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3483 tem = Fmemq (feature, Vfeatures);
3485 Vfeatures = Fcons (feature, Vfeatures);
3486 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3490 DEFUN ("require", Frequire, 1, 2, 0, /*
3491 If feature FEATURE is not loaded, load it from FILENAME.
3492 If FEATURE is not a member of the list `features', then the feature
3493 is not loaded; so load the file FILENAME.
3494 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3496 (feature, file_name))
3499 CHECK_SYMBOL (feature);
3500 tem = Fmemq (feature, Vfeatures);
3501 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3506 int speccount = specpdl_depth ();
3508 /* Value saved here is to be restored into Vautoload_queue */
3509 record_unwind_protect (un_autoload, Vautoload_queue);
3510 Vautoload_queue = Qt;
3512 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3515 tem = Fmemq (feature, Vfeatures);
3517 error ("Required feature %s was not provided",
3518 string_data (XSYMBOL (feature)->name));
3520 /* Once loading finishes, don't undo it. */
3521 Vautoload_queue = Qt;
3522 return unbind_to (speccount, feature);
3527 Lisp_Object Qyes_or_no_p;
3532 defsymbol (&Qstring_lessp, "string-lessp");
3533 defsymbol (&Qidentity, "identity");
3534 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3536 DEFSUBR (Fidentity);
3539 DEFSUBR (Fsafe_length);
3540 DEFSUBR (Fstring_equal);
3541 DEFSUBR (Fstring_lessp);
3542 DEFSUBR (Fstring_modified_tick);
3546 DEFSUBR (Fbvconcat);
3547 DEFSUBR (Fcopy_sequence);
3548 DEFSUBR (Fcopy_alist);
3549 DEFSUBR (Fcopy_tree);
3550 DEFSUBR (Fsubstring);
3556 DEFSUBR (Fold_member);
3558 DEFSUBR (Fold_memq);
3560 DEFSUBR (Fold_assoc);
3562 DEFSUBR (Fold_assq);
3564 DEFSUBR (Fold_rassoc);
3566 DEFSUBR (Fold_rassq);
3568 DEFSUBR (Fold_delete);
3570 DEFSUBR (Fold_delq);
3571 DEFSUBR (Fremassoc);
3573 DEFSUBR (Fremrassoc);
3574 DEFSUBR (Fremrassq);
3575 DEFSUBR (Fnreverse);
3578 DEFSUBR (Fplists_eq);
3579 DEFSUBR (Fplists_equal);
3580 DEFSUBR (Flax_plists_eq);
3581 DEFSUBR (Flax_plists_equal);
3582 DEFSUBR (Fplist_get);
3583 DEFSUBR (Fplist_put);
3584 DEFSUBR (Fplist_remprop);
3585 DEFSUBR (Fplist_member);
3586 DEFSUBR (Fcheck_valid_plist);
3587 DEFSUBR (Fvalid_plist_p);
3588 DEFSUBR (Fcanonicalize_plist);
3589 DEFSUBR (Flax_plist_get);
3590 DEFSUBR (Flax_plist_put);
3591 DEFSUBR (Flax_plist_remprop);
3592 DEFSUBR (Flax_plist_member);
3593 DEFSUBR (Fcanonicalize_lax_plist);
3594 DEFSUBR (Fdestructive_alist_to_plist);
3598 DEFSUBR (Fobject_plist);
3600 DEFSUBR (Fold_equal);
3601 DEFSUBR (Ffillarray);
3604 DEFSUBR (Fmapvector);
3606 DEFSUBR (Fmapconcat);
3607 DEFSUBR (Fload_average);
3608 DEFSUBR (Ffeaturep);
3614 init_provide_once (void)
3616 DEFVAR_LISP ("features", &Vfeatures /*
3617 A list of symbols which are the features of the executing emacs.
3618 Used by `featurep' and `require', and altered by `provide'.