1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
23 /* Note on some machines this defines `vector' as a typedef,
24 so make sure we don't use that name in this file. */
33 #include "intervals.h"
36 #define NULL (void *)0
39 extern Lisp_Object
Flookup_key ();
41 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
42 Lisp_Object Qyes_or_no_p_history
;
44 static int internal_equal ();
46 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
47 "Return the argument unchanged.")
54 extern long get_random ();
55 extern void seed_random ();
58 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
59 "Return a pseudo-random number.\n\
60 All integers representable in Lisp are equally likely.\n\
61 On most systems, this is 28 bits' worth.\n\
62 With positive integer argument N, return random number in interval [0,N).\n\
63 With argument t, set the random number seed from the current time and pid.")
68 Lisp_Object lispy_val
;
69 unsigned long denominator
;
72 seed_random (getpid () + time (NULL
));
73 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
75 /* Try to take our random number from the higher bits of VAL,
76 not the lower, since (says Gentzel) the low bits of `random'
77 are less random than the higher ones. We do this by using the
78 quotient rather than the remainder. At the high end of the RNG
79 it's possible to get a quotient larger than limit; discarding
80 these values eliminates the bias that would otherwise appear
81 when using a large limit. */
82 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
84 val
= get_random () / denominator
;
85 while (val
>= XFASTINT (limit
));
89 XSETINT (lispy_val
, val
);
93 /* Random data-structure functions */
95 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
96 "Return the length of vector, list or string SEQUENCE.\n\
97 A byte-code function object is also allowed.")
99 register Lisp_Object obj
;
101 register Lisp_Object tail
, val
;
106 XSETFASTINT (val
, XSTRING (obj
)->size
);
107 else if (VECTORP (obj
))
108 XSETFASTINT (val
, XVECTOR (obj
)->size
);
109 else if (COMPILEDP (obj
))
110 XSETFASTINT (val
, XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
);
111 else if (CONSP (obj
))
113 for (i
= 0, tail
= obj
; !NILP (tail
); i
++)
119 XSETFASTINT (val
, i
);
122 XSETFASTINT (val
, 0);
125 obj
= wrong_type_argument (Qsequencep
, obj
);
131 /* This does not check for quits. That is safe
132 since it must terminate. */
134 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
135 "Return the length of a list, but avoid error or infinite loop.\n\
136 This function never gets an error. If LIST is not really a list,\n\
137 it returns 0. If LIST is circular, it returns a finite value\n\
138 which is at least the number of distinct elements.")
142 Lisp_Object tail
, halftail
, length
;
145 /* halftail is used to detect circular lists. */
147 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
149 if (EQ (tail
, halftail
) && len
!= 0)
153 halftail
= XCONS (halftail
)->cdr
;
156 XSETINT (length
, len
);
160 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
161 "T if two strings have identical contents.\n\
162 Case is significant, but text properties are ignored.\n\
163 Symbols are also allowed; their print names are used instead.")
165 register Lisp_Object s1
, s2
;
168 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
170 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
171 CHECK_STRING (s1
, 0);
172 CHECK_STRING (s2
, 1);
174 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
175 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
180 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
181 "T if first arg string is less than second in lexicographic order.\n\
182 Case is significant.\n\
183 Symbols are also allowed; their print names are used instead.")
185 register Lisp_Object s1
, s2
;
188 register unsigned char *p1
, *p2
;
192 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
194 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
195 CHECK_STRING (s1
, 0);
196 CHECK_STRING (s2
, 1);
198 p1
= XSTRING (s1
)->data
;
199 p2
= XSTRING (s2
)->data
;
200 end
= XSTRING (s1
)->size
;
201 if (end
> XSTRING (s2
)->size
)
202 end
= XSTRING (s2
)->size
;
204 for (i
= 0; i
< end
; i
++)
207 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
209 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
212 static Lisp_Object
concat ();
223 return concat (2, args
, Lisp_String
, 0);
225 return concat (2, &s1
, Lisp_String
, 0);
226 #endif /* NO_ARG_ARRAY */
232 Lisp_Object s1
, s2
, s3
;
239 return concat (3, args
, Lisp_String
, 0);
241 return concat (3, &s1
, Lisp_String
, 0);
242 #endif /* NO_ARG_ARRAY */
245 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
246 "Concatenate all the arguments and make the result a list.\n\
247 The result is a list whose elements are the elements of all the arguments.\n\
248 Each argument may be a list, vector or string.\n\
249 The last argument is not copied, just used as the tail of the new list.")
254 return concat (nargs
, args
, Lisp_Cons
, 1);
257 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
258 "Concatenate all the arguments and make the result a string.\n\
259 The result is a string whose elements are the elements of all the arguments.\n\
260 Each argument may be a string or a list or vector of characters (integers).\n\
262 Do not use individual integers as arguments!\n\
263 The behavior of `concat' in that case will be changed later!\n\
264 If your program passes an integer as an argument to `concat',\n\
265 you should change it right away not to do so.")
270 return concat (nargs
, args
, Lisp_String
, 0);
273 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
274 "Concatenate all the arguments and make the result a vector.\n\
275 The result is a vector whose elements are the elements of all the arguments.\n\
276 Each argument may be a list, vector or string.")
281 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
284 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
285 "Return a copy of a list, vector or string.\n\
286 The elements of a list or vector are not copied; they are shared\n\
291 if (NILP (arg
)) return arg
;
292 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
293 arg
= wrong_type_argument (Qsequencep
, arg
);
294 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
298 concat (nargs
, args
, target_type
, last_special
)
301 enum Lisp_Type target_type
;
306 register Lisp_Object tail
;
307 register Lisp_Object
this;
311 Lisp_Object last_tail
;
314 /* In append, the last arg isn't treated like the others */
315 if (last_special
&& nargs
> 0)
318 last_tail
= args
[nargs
];
323 for (argnum
= 0; argnum
< nargs
; argnum
++)
326 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
327 || COMPILEDP (this)))
330 args
[argnum
] = Fnumber_to_string (this);
332 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
336 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
339 len
= Flength (this);
340 leni
+= XFASTINT (len
);
343 XSETFASTINT (len
, leni
);
345 if (target_type
== Lisp_Cons
)
346 val
= Fmake_list (len
, Qnil
);
347 else if (target_type
== Lisp_Vectorlike
)
348 val
= Fmake_vector (len
, Qnil
);
350 val
= Fmake_string (len
, len
);
352 /* In append, if all but last arg are nil, return last arg */
353 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
357 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
363 for (argnum
= 0; argnum
< nargs
; argnum
++)
367 register int thisindex
= 0;
371 thislen
= Flength (this), thisleni
= XINT (thislen
);
373 if (STRINGP (this) && STRINGP (val
)
374 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
376 copy_text_properties (make_number (0), thislen
, this,
377 make_number (toindex
), val
, Qnil
);
382 register Lisp_Object elt
;
384 /* Fetch next element of `this' arg into `elt', or break if
385 `this' is exhausted. */
386 if (NILP (this)) break;
388 elt
= Fcar (this), this = Fcdr (this);
391 if (thisindex
>= thisleni
) break;
393 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
395 elt
= XVECTOR (this)->contents
[thisindex
++];
398 /* Store into result */
401 XCONS (tail
)->car
= elt
;
403 tail
= XCONS (tail
)->cdr
;
405 else if (VECTORP (val
))
406 XVECTOR (val
)->contents
[toindex
++] = elt
;
409 while (!INTEGERP (elt
))
410 elt
= wrong_type_argument (Qintegerp
, elt
);
412 #ifdef MASSC_REGISTER_BUG
413 /* Even removing all "register"s doesn't disable this bug!
414 Nothing simpler than this seems to work. */
415 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
418 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
425 XCONS (prev
)->cdr
= last_tail
;
430 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
431 "Return a copy of ALIST.\n\
432 This is an alist which represents the same mapping from objects to objects,\n\
433 but does not share the alist structure with ALIST.\n\
434 The objects mapped (cars and cdrs of elements of the alist)\n\
435 are shared, however.\n\
436 Elements of ALIST that are not conses are also shared.")
440 register Lisp_Object tem
;
442 CHECK_LIST (alist
, 0);
445 alist
= concat (1, &alist
, Lisp_Cons
, 0);
446 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
448 register Lisp_Object car
;
449 car
= XCONS (tem
)->car
;
452 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
457 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
458 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
459 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
460 If FROM or TO is negative, it counts from the end.")
463 register Lisp_Object from
, to
;
467 CHECK_STRING (string
, 0);
468 CHECK_NUMBER (from
, 1);
470 to
= Flength (string
);
472 CHECK_NUMBER (to
, 2);
475 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
477 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
478 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
479 && XINT (to
) <= XSTRING (string
)->size
))
480 args_out_of_range_3 (string
, from
, to
);
482 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
483 XINT (to
) - XINT (from
));
484 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
488 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
489 "Take cdr N times on LIST, returns the result.")
492 register Lisp_Object list
;
497 for (i
= 0; i
< num
&& !NILP (list
); i
++)
505 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
506 "Return the Nth element of LIST.\n\
507 N counts from zero. If LIST is not that long, nil is returned.")
511 return Fcar (Fnthcdr (n
, list
));
514 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
515 "Return element of SEQUENCE at index N.")
517 register Lisp_Object seq
, n
;
522 if (CONSP (seq
) || NILP (seq
))
523 return Fcar (Fnthcdr (n
, seq
));
524 else if (STRINGP (seq
) || VECTORP (seq
))
525 return Faref (seq
, n
);
527 seq
= wrong_type_argument (Qsequencep
, seq
);
531 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
532 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
533 The value is actually the tail of LIST whose car is ELT.")
535 register Lisp_Object elt
;
538 register Lisp_Object tail
;
539 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
541 register Lisp_Object tem
;
543 if (! NILP (Fequal (elt
, tem
)))
550 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
551 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
552 The value is actually the tail of LIST whose car is ELT.")
554 register Lisp_Object elt
;
557 register Lisp_Object tail
;
558 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
560 register Lisp_Object tem
;
562 if (EQ (elt
, tem
)) return tail
;
568 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
569 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
570 The value is actually the element of LIST whose car is KEY.\n\
571 Elements of LIST that are not conses are ignored.")
573 register Lisp_Object key
;
576 register Lisp_Object tail
;
577 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
579 register Lisp_Object elt
, tem
;
581 if (!CONSP (elt
)) continue;
583 if (EQ (key
, tem
)) return elt
;
589 /* Like Fassq but never report an error and do not allow quits.
590 Use only on lists known never to be circular. */
593 assq_no_quit (key
, list
)
594 register Lisp_Object key
;
597 register Lisp_Object tail
;
598 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
600 register Lisp_Object elt
, tem
;
602 if (!CONSP (elt
)) continue;
604 if (EQ (key
, tem
)) return elt
;
609 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
610 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
611 The value is actually the element of LIST whose car equals KEY.")
613 register Lisp_Object key
;
616 register Lisp_Object tail
;
617 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
619 register Lisp_Object elt
, tem
;
621 if (!CONSP (elt
)) continue;
622 tem
= Fequal (Fcar (elt
), key
);
623 if (!NILP (tem
)) return elt
;
629 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
630 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
631 The value is actually the element of LIST whose cdr is ELT.")
633 register Lisp_Object key
;
636 register Lisp_Object tail
;
637 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
639 register Lisp_Object elt
, tem
;
641 if (!CONSP (elt
)) continue;
643 if (EQ (key
, tem
)) return elt
;
649 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
650 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
651 The value is actually the element of LIST whose cdr equals KEY.")
653 register Lisp_Object key
;
656 register Lisp_Object tail
;
657 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
659 register Lisp_Object elt
, tem
;
661 if (!CONSP (elt
)) continue;
662 tem
= Fequal (Fcdr (elt
), key
);
663 if (!NILP (tem
)) return elt
;
669 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
670 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
671 The modified LIST is returned. Comparison is done with `eq'.\n\
672 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
673 therefore, write `(setq foo (delq element foo))'\n\
674 to be sure of changing the value of `foo'.")
676 register Lisp_Object elt
;
679 register Lisp_Object tail
, prev
;
680 register Lisp_Object tem
;
692 Fsetcdr (prev
, Fcdr (tail
));
702 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
703 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
704 The modified LIST is returned. Comparison is done with `equal'.\n\
705 If the first member of LIST is ELT, deleting it is not a side effect;\n\
706 it is simply using a different list.\n\
707 Therefore, write `(setq foo (delete element foo))'\n\
708 to be sure of changing the value of `foo'.")
710 register Lisp_Object elt
;
713 register Lisp_Object tail
, prev
;
714 register Lisp_Object tem
;
721 if (! NILP (Fequal (elt
, tem
)))
726 Fsetcdr (prev
, Fcdr (tail
));
736 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
737 "Reverse LIST by modifying cdr pointers.\n\
738 Returns the beginning of the reversed list.")
742 register Lisp_Object prev
, tail
, next
;
744 if (NILP (list
)) return list
;
751 Fsetcdr (tail
, prev
);
758 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
759 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
760 See also the function `nreverse', which is used more often.")
765 register Lisp_Object
*vec
;
766 register Lisp_Object tail
;
769 length
= Flength (list
);
770 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
771 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
772 vec
[i
] = Fcar (tail
);
774 return Flist (XINT (length
), vec
);
777 Lisp_Object
merge ();
779 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
780 "Sort LIST, stably, comparing elements using PREDICATE.\n\
781 Returns the sorted list. LIST is modified by side effects.\n\
782 PREDICATE is called with two elements of LIST, and should return T\n\
783 if the first element is \"less\" than the second.")
785 Lisp_Object list
, pred
;
787 Lisp_Object front
, back
;
788 register Lisp_Object len
, tem
;
789 struct gcpro gcpro1
, gcpro2
;
793 len
= Flength (list
);
798 XSETINT (len
, (length
/ 2) - 1);
799 tem
= Fnthcdr (len
, list
);
803 GCPRO2 (front
, back
);
804 front
= Fsort (front
, pred
);
805 back
= Fsort (back
, pred
);
807 return merge (front
, back
, pred
);
811 merge (org_l1
, org_l2
, pred
)
812 Lisp_Object org_l1
, org_l2
;
816 register Lisp_Object tail
;
818 register Lisp_Object l1
, l2
;
819 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
826 /* It is sufficient to protect org_l1 and org_l2.
827 When l1 and l2 are updated, we copy the new values
828 back into the org_ vars. */
829 GCPRO4 (org_l1
, org_l2
, pred
, value
);
849 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
871 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
872 "Extract a value from a property list.\n\
873 PLIST is a property list, which is a list of the form\n\
874 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
875 corresponding to the given PROP, or nil if PROP is not\n\
876 one of the properties on the list.")
879 register Lisp_Object prop
;
881 register Lisp_Object tail
;
882 for (tail
= val
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
884 register Lisp_Object tem
;
887 return Fcar (Fcdr (tail
));
892 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
893 "Return the value of SYMBOL's PROPNAME property.\n\
894 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
896 Lisp_Object symbol
, propname
;
898 CHECK_SYMBOL (symbol
, 0);
899 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
902 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
903 "Change value in PLIST of PROP to VAL.\n\
904 PLIST is a property list, which is a list of the form\n\
905 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
906 If PROP is already a property on the list, its value is set to VAL,\n\
907 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
908 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
909 The PLIST is modified by side effects.")
912 register Lisp_Object prop
;
915 register Lisp_Object tail
, prev
;
918 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
919 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
921 if (EQ (prop
, XCONS (tail
)->car
))
923 Fsetcar (XCONS (tail
)->cdr
, val
);
928 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
932 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
936 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
937 "Store SYMBOL's PROPNAME property with value VALUE.\n\
938 It can be retrieved with `(get SYMBOL PROPNAME)'.")
939 (symbol
, propname
, value
)
940 Lisp_Object symbol
, propname
, value
;
942 CHECK_SYMBOL (symbol
, 0);
943 XSYMBOL (symbol
)->plist
944 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
948 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
949 "T if two Lisp objects have similar structure and contents.\n\
950 They must have the same data type.\n\
951 Conses are compared by comparing the cars and the cdrs.\n\
952 Vectors and strings are compared element by element.\n\
953 Numbers are compared by value, but integers cannot equal floats.\n\
954 (Use `=' if you want integers and floats to be able to be equal.)\n\
955 Symbols must match exactly.")
957 register Lisp_Object o1
, o2
;
959 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
963 internal_equal (o1
, o2
, depth
)
964 register Lisp_Object o1
, o2
;
968 error ("Stack overflow in equal");
974 if (XTYPE (o1
) != XTYPE (o2
))
979 #ifdef LISP_FLOAT_TYPE
981 return (extract_float (o1
) == extract_float (o2
));
985 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
987 o1
= XCONS (o1
)->cdr
;
988 o2
= XCONS (o2
)->cdr
;
992 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
996 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
998 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1001 o1
= XOVERLAY (o1
)->plist
;
1002 o2
= XOVERLAY (o2
)->plist
;
1007 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1008 && (XMARKER (o1
)->buffer
== 0
1009 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1013 case Lisp_Vectorlike
:
1015 register int i
, size
;
1016 size
= XVECTOR (o1
)->size
;
1017 /* Pseudovectors have the type encoded in the size field, so this test
1018 actually checks that the objects have the same type as well as the
1020 if (XVECTOR (o2
)->size
!= size
)
1022 /* But only true vectors and compiled functions are actually sensible
1023 to compare, so eliminate the others now. */
1024 if (size
& PSEUDOVECTOR_FLAG
)
1026 if (!(size
& PVEC_COMPILED
))
1028 size
&= PSEUDOVECTOR_SIZE_MASK
;
1030 for (i
= 0; i
< size
; i
++)
1033 v1
= XVECTOR (o1
)->contents
[i
];
1034 v2
= XVECTOR (o2
)->contents
[i
];
1035 if (!internal_equal (v1
, v2
, depth
+ 1))
1043 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1045 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1046 XSTRING (o1
)->size
))
1048 #ifdef USE_TEXT_PROPERTIES
1049 /* If the strings have intervals, verify they match;
1050 if not, they are unequal. */
1051 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1052 && ! compare_string_intervals (o1
, o2
))
1060 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1061 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
1063 Lisp_Object array
, item
;
1065 register int size
, index
, charval
;
1067 if (VECTORP (array
))
1069 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1070 size
= XVECTOR (array
)->size
;
1071 for (index
= 0; index
< size
; index
++)
1074 else if (STRINGP (array
))
1076 register unsigned char *p
= XSTRING (array
)->data
;
1077 CHECK_NUMBER (item
, 1);
1078 charval
= XINT (item
);
1079 size
= XSTRING (array
)->size
;
1080 for (index
= 0; index
< size
; index
++)
1085 array
= wrong_type_argument (Qarrayp
, array
);
1097 Lisp_Object args
[2];
1100 return Fnconc (2, args
);
1102 return Fnconc (2, &s1
);
1103 #endif /* NO_ARG_ARRAY */
1106 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1107 "Concatenate any number of lists by altering them.\n\
1108 Only the last argument is not altered, and need not be a list.")
1113 register int argnum
;
1114 register Lisp_Object tail
, tem
, val
;
1118 for (argnum
= 0; argnum
< nargs
; argnum
++)
1121 if (NILP (tem
)) continue;
1126 if (argnum
+ 1 == nargs
) break;
1129 tem
= wrong_type_argument (Qlistp
, tem
);
1138 tem
= args
[argnum
+ 1];
1139 Fsetcdr (tail
, tem
);
1141 args
[argnum
+ 1] = tail
;
1147 /* This is the guts of all mapping functions.
1148 Apply fn to each element of seq, one by one,
1149 storing the results into elements of vals, a C vector of Lisp_Objects.
1150 leni is the length of vals, which should also be the length of seq. */
1153 mapcar1 (leni
, vals
, fn
, seq
)
1156 Lisp_Object fn
, seq
;
1158 register Lisp_Object tail
;
1161 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1163 /* Don't let vals contain any garbage when GC happens. */
1164 for (i
= 0; i
< leni
; i
++)
1167 GCPRO3 (dummy
, fn
, seq
);
1169 gcpro1
.nvars
= leni
;
1170 /* We need not explicitly protect `tail' because it is used only on lists, and
1171 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1175 for (i
= 0; i
< leni
; i
++)
1177 dummy
= XVECTOR (seq
)->contents
[i
];
1178 vals
[i
] = call1 (fn
, dummy
);
1181 else if (STRINGP (seq
))
1183 for (i
= 0; i
< leni
; i
++)
1185 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1186 vals
[i
] = call1 (fn
, dummy
);
1189 else /* Must be a list, since Flength did not get an error */
1192 for (i
= 0; i
< leni
; i
++)
1194 vals
[i
] = call1 (fn
, Fcar (tail
));
1202 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1203 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1204 In between each pair of results, stick in SEP.\n\
1205 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1207 Lisp_Object fn
, seq
, sep
;
1212 register Lisp_Object
*args
;
1214 struct gcpro gcpro1
;
1216 len
= Flength (seq
);
1218 nargs
= leni
+ leni
- 1;
1219 if (nargs
< 0) return build_string ("");
1221 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1224 mapcar1 (leni
, args
, fn
, seq
);
1227 for (i
= leni
- 1; i
>= 0; i
--)
1228 args
[i
+ i
] = args
[i
];
1230 for (i
= 1; i
< nargs
; i
+= 2)
1233 return Fconcat (nargs
, args
);
1236 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1237 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1238 The result is a list just as long as SEQUENCE.\n\
1239 SEQUENCE may be a list, a vector or a string.")
1241 Lisp_Object fn
, seq
;
1243 register Lisp_Object len
;
1245 register Lisp_Object
*args
;
1247 len
= Flength (seq
);
1248 leni
= XFASTINT (len
);
1249 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1251 mapcar1 (leni
, args
, fn
, seq
);
1253 return Flist (leni
, args
);
1256 /* Anything that calls this function must protect from GC! */
1258 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1259 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1260 Takes one argument, which is the string to display to ask the question.\n\
1261 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1262 No confirmation of the answer is requested; a single character is enough.\n\
1263 Also accepts Space to mean yes, or Delete to mean no.")
1267 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1268 register int answer
;
1269 Lisp_Object xprompt
;
1270 Lisp_Object args
[2];
1271 int ocech
= cursor_in_echo_area
;
1272 struct gcpro gcpro1
, gcpro2
;
1274 map
= Fsymbol_value (intern ("query-replace-map"));
1276 CHECK_STRING (prompt
, 0);
1278 GCPRO2 (prompt
, xprompt
);
1283 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1286 Lisp_Object pane
, menu
;
1287 redisplay_preserve_echo_area ();
1288 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1289 Fcons (Fcons (build_string ("No"), Qnil
),
1291 menu
= Fcons (prompt
, pane
);
1292 obj
= Fx_popup_dialog (Qt
, menu
);
1293 answer
= !NILP (obj
);
1297 cursor_in_echo_area
= 1;
1298 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1300 obj
= read_filtered_event (1, 0, 0);
1301 cursor_in_echo_area
= 0;
1302 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1305 key
= Fmake_vector (make_number (1), obj
);
1306 def
= Flookup_key (map
, key
);
1307 answer_string
= Fsingle_key_description (obj
);
1309 if (EQ (def
, intern ("skip")))
1314 else if (EQ (def
, intern ("act")))
1319 else if (EQ (def
, intern ("recenter")))
1325 else if (EQ (def
, intern ("quit")))
1327 /* We want to exit this command for exit-prefix,
1328 and this is the only way to do it. */
1329 else if (EQ (def
, intern ("exit-prefix")))
1334 /* If we don't clear this, then the next call to read_char will
1335 return quit_char again, and we'll enter an infinite loop. */
1340 if (EQ (xprompt
, prompt
))
1342 args
[0] = build_string ("Please answer y or n. ");
1344 xprompt
= Fconcat (2, args
);
1349 if (! noninteractive
)
1351 cursor_in_echo_area
= -1;
1352 message_nolog ("%s(y or n) %c",
1353 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1354 cursor_in_echo_area
= ocech
;
1357 return answer
? Qt
: Qnil
;
1360 /* This is how C code calls `yes-or-no-p' and allows the user
1363 Anything that calls this function must protect from GC! */
1366 do_yes_or_no_p (prompt
)
1369 return call1 (intern ("yes-or-no-p"), prompt
);
1372 /* Anything that calls this function must protect from GC! */
1374 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1375 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1376 Takes one argument, which is the string to display to ask the question.\n\
1377 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1378 The user must confirm the answer with RET,\n\
1379 and can edit it until it has been confirmed.")
1383 register Lisp_Object ans
;
1384 Lisp_Object args
[2];
1385 struct gcpro gcpro1
;
1388 CHECK_STRING (prompt
, 0);
1391 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1394 Lisp_Object pane
, menu
, obj
;
1395 redisplay_preserve_echo_area ();
1396 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1397 Fcons (Fcons (build_string ("No"), Qnil
),
1400 menu
= Fcons (prompt
, pane
);
1401 obj
= Fx_popup_dialog (Qt
, menu
);
1408 args
[1] = build_string ("(yes or no) ");
1409 prompt
= Fconcat (2, args
);
1415 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1416 Qyes_or_no_p_history
));
1417 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1422 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1430 message ("Please answer yes or no.");
1431 Fsleep_for (make_number (2), Qnil
);
1435 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1436 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1437 Each of the three load averages is multiplied by 100,\n\
1438 then converted to integer.\n\
1439 If the 5-minute or 15-minute load averages are not available, return a\n\
1440 shortened list, containing only those averages which are available.")
1444 int loads
= getloadavg (load_ave
, 3);
1448 error ("load-average not implemented for this operating system");
1452 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1457 Lisp_Object Vfeatures
;
1459 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1460 "Returns t if FEATURE is present in this Emacs.\n\
1461 Use this to conditionalize execution of lisp code based on the presence or\n\
1462 absence of emacs or environment extensions.\n\
1463 Use `provide' to declare that a feature is available.\n\
1464 This function looks at the value of the variable `features'.")
1466 Lisp_Object feature
;
1468 register Lisp_Object tem
;
1469 CHECK_SYMBOL (feature
, 0);
1470 tem
= Fmemq (feature
, Vfeatures
);
1471 return (NILP (tem
)) ? Qnil
: Qt
;
1474 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1475 "Announce that FEATURE is a feature of the current Emacs.")
1477 Lisp_Object feature
;
1479 register Lisp_Object tem
;
1480 CHECK_SYMBOL (feature
, 0);
1481 if (!NILP (Vautoload_queue
))
1482 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1483 tem
= Fmemq (feature
, Vfeatures
);
1485 Vfeatures
= Fcons (feature
, Vfeatures
);
1486 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1490 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1491 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1492 If FEATURE is not a member of the list `features', then the feature\n\
1493 is not loaded; so load the file FILENAME.\n\
1494 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1495 (feature
, file_name
)
1496 Lisp_Object feature
, file_name
;
1498 register Lisp_Object tem
;
1499 CHECK_SYMBOL (feature
, 0);
1500 tem
= Fmemq (feature
, Vfeatures
);
1501 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1504 int count
= specpdl_ptr
- specpdl
;
1506 /* Value saved here is to be restored into Vautoload_queue */
1507 record_unwind_protect (un_autoload
, Vautoload_queue
);
1508 Vautoload_queue
= Qt
;
1510 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1513 tem
= Fmemq (feature
, Vfeatures
);
1515 error ("Required feature %s was not provided",
1516 XSYMBOL (feature
)->name
->data
);
1518 /* Once loading finishes, don't undo it. */
1519 Vautoload_queue
= Qt
;
1520 feature
= unbind_to (count
, feature
);
1527 Qstring_lessp
= intern ("string-lessp");
1528 staticpro (&Qstring_lessp
);
1529 Qprovide
= intern ("provide");
1530 staticpro (&Qprovide
);
1531 Qrequire
= intern ("require");
1532 staticpro (&Qrequire
);
1533 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1534 staticpro (&Qyes_or_no_p_history
);
1536 DEFVAR_LISP ("features", &Vfeatures
,
1537 "A list of symbols which are the features of the executing emacs.\n\
1538 Used by `featurep' and `require', and altered by `provide'.");
1541 defsubr (&Sidentity
);
1544 defsubr (&Ssafe_length
);
1545 defsubr (&Sstring_equal
);
1546 defsubr (&Sstring_lessp
);
1549 defsubr (&Svconcat
);
1550 defsubr (&Scopy_sequence
);
1551 defsubr (&Scopy_alist
);
1552 defsubr (&Ssubstring
);
1564 defsubr (&Snreverse
);
1565 defsubr (&Sreverse
);
1567 defsubr (&Splist_get
);
1569 defsubr (&Splist_put
);
1572 defsubr (&Sfillarray
);
1575 defsubr (&Smapconcat
);
1576 defsubr (&Sy_or_n_p
);
1577 defsubr (&Syes_or_no_p
);
1578 defsubr (&Sload_average
);
1579 defsubr (&Sfeaturep
);
1580 defsubr (&Srequire
);
1581 defsubr (&Sprovide
);