1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994 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"
35 extern Lisp_Object
Flookup_key ();
37 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
38 Lisp_Object Qyes_or_no_p_history
;
40 static int internal_equal ();
42 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
43 "Return the argument unchanged.")
50 extern long get_random ();
51 extern void seed_random ();
54 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
55 "Return a pseudo-random number.\n\
56 All integers representable in Lisp are equally likely.\n\
57 On most systems, this is 28 bits' worth.\n\
58 With positive integer argument N, return random number in interval [0,N).\n\
59 With argument t, set the random number seed from the current time and pid.")
64 unsigned long denominator
;
67 seed_random (getpid () + time (0));
68 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
70 /* Try to take our random number from the higher bits of VAL,
71 not the lower, since (says Gentzel) the low bits of `random'
72 are less random than the higher ones. We do this by using the
73 quotient rather than the remainder. At the high end of the RNG
74 it's possible to get a quotient larger than limit; discarding
75 these values eliminates the bias that would otherwise appear
76 when using a large limit. */
77 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
79 val
= get_random () / denominator
;
80 while (val
>= XFASTINT (limit
));
84 return make_number (val
);
87 /* Random data-structure functions */
89 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
90 "Return the length of vector, list or string SEQUENCE.\n\
91 A byte-code function object is also allowed.")
93 register Lisp_Object obj
;
95 register Lisp_Object tail
, val
;
100 XSETFASTINT (val
, XSTRING (obj
)->size
);
101 else if (VECTORP (obj
))
102 XSETFASTINT (val
, XVECTOR (obj
)->size
);
103 else if (COMPILEDP (obj
))
104 XSETFASTINT (val
, XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
);
105 else if (CONSP (obj
))
107 for (i
= 0, tail
= obj
; !NILP (tail
); i
++)
113 XSETFASTINT (val
, i
);
116 XSETFASTINT (val
, 0);
119 obj
= wrong_type_argument (Qsequencep
, obj
);
125 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
126 "T if two strings have identical contents.\n\
127 Case is significant, but text properties are ignored.\n\
128 Symbols are also allowed; their print names are used instead.")
130 register Lisp_Object s1
, s2
;
133 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
135 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
136 CHECK_STRING (s1
, 0);
137 CHECK_STRING (s2
, 1);
139 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
140 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
145 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
146 "T if first arg string is less than second in lexicographic order.\n\
147 Case is significant.\n\
148 Symbols are also allowed; their print names are used instead.")
150 register Lisp_Object s1
, s2
;
153 register unsigned char *p1
, *p2
;
157 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
159 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
160 CHECK_STRING (s1
, 0);
161 CHECK_STRING (s2
, 1);
163 p1
= XSTRING (s1
)->data
;
164 p2
= XSTRING (s2
)->data
;
165 end
= XSTRING (s1
)->size
;
166 if (end
> XSTRING (s2
)->size
)
167 end
= XSTRING (s2
)->size
;
169 for (i
= 0; i
< end
; i
++)
172 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
174 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
177 static Lisp_Object
concat ();
188 return concat (2, args
, Lisp_String
, 0);
190 return concat (2, &s1
, Lisp_String
, 0);
191 #endif /* NO_ARG_ARRAY */
197 Lisp_Object s1
, s2
, s3
;
204 return concat (3, args
, Lisp_String
, 0);
206 return concat (3, &s1
, Lisp_String
, 0);
207 #endif /* NO_ARG_ARRAY */
210 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
211 "Concatenate all the arguments and make the result a list.\n\
212 The result is a list whose elements are the elements of all the arguments.\n\
213 Each argument may be a list, vector or string.\n\
214 The last argument is not copied, just used as the tail of the new list.")
219 return concat (nargs
, args
, Lisp_Cons
, 1);
222 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
223 "Concatenate all the arguments and make the result a string.\n\
224 The result is a string whose elements are the elements of all the arguments.\n\
225 Each argument may be a string or a list or vector of characters (integers).\n\
227 Do not use individual integers as arguments!\n\
228 The behavior of `concat' in that case will be changed later!\n\
229 If your program passes an integer as an argument to `concat',\n\
230 you should change it right away not to do so.")
235 return concat (nargs
, args
, Lisp_String
, 0);
238 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
239 "Concatenate all the arguments and make the result a vector.\n\
240 The result is a vector whose elements are the elements of all the arguments.\n\
241 Each argument may be a list, vector or string.")
246 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
249 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
250 "Return a copy of a list, vector or string.\n\
251 The elements of a list or vector are not copied; they are shared\n\
256 if (NILP (arg
)) return arg
;
257 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
258 arg
= wrong_type_argument (Qsequencep
, arg
);
259 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
263 concat (nargs
, args
, target_type
, last_special
)
266 enum Lisp_Type target_type
;
271 register Lisp_Object tail
;
272 register Lisp_Object
this;
276 Lisp_Object last_tail
;
279 /* In append, the last arg isn't treated like the others */
280 if (last_special
&& nargs
> 0)
283 last_tail
= args
[nargs
];
288 for (argnum
= 0; argnum
< nargs
; argnum
++)
291 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
292 || COMPILEDP (this)))
295 args
[argnum
] = Fnumber_to_string (this);
297 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
301 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
304 len
= Flength (this);
305 leni
+= XFASTINT (len
);
308 XSETFASTINT (len
, leni
);
310 if (target_type
== Lisp_Cons
)
311 val
= Fmake_list (len
, Qnil
);
312 else if (target_type
== Lisp_Vectorlike
)
313 val
= Fmake_vector (len
, Qnil
);
315 val
= Fmake_string (len
, len
);
317 /* In append, if all but last arg are nil, return last arg */
318 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
322 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
328 for (argnum
= 0; argnum
< nargs
; argnum
++)
332 register int thisindex
= 0;
336 thislen
= Flength (this), thisleni
= XINT (thislen
);
338 if (STRINGP (this) && STRINGP (val
)
339 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
341 copy_text_properties (make_number (0), thislen
, this,
342 make_number (toindex
), val
, Qnil
);
347 register Lisp_Object elt
;
349 /* Fetch next element of `this' arg into `elt', or break if
350 `this' is exhausted. */
351 if (NILP (this)) break;
353 elt
= Fcar (this), this = Fcdr (this);
356 if (thisindex
>= thisleni
) break;
358 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
360 elt
= XVECTOR (this)->contents
[thisindex
++];
363 /* Store into result */
366 XCONS (tail
)->car
= elt
;
368 tail
= XCONS (tail
)->cdr
;
370 else if (VECTORP (val
))
371 XVECTOR (val
)->contents
[toindex
++] = elt
;
374 while (!INTEGERP (elt
))
375 elt
= wrong_type_argument (Qintegerp
, elt
);
377 #ifdef MASSC_REGISTER_BUG
378 /* Even removing all "register"s doesn't disable this bug!
379 Nothing simpler than this seems to work. */
380 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
383 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
390 XCONS (prev
)->cdr
= last_tail
;
395 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
396 "Return a copy of ALIST.\n\
397 This is an alist which represents the same mapping from objects to objects,\n\
398 but does not share the alist structure with ALIST.\n\
399 The objects mapped (cars and cdrs of elements of the alist)\n\
400 are shared, however.\n\
401 Elements of ALIST that are not conses are also shared.")
405 register Lisp_Object tem
;
407 CHECK_LIST (alist
, 0);
410 alist
= concat (1, &alist
, Lisp_Cons
, 0);
411 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
413 register Lisp_Object car
;
414 car
= XCONS (tem
)->car
;
417 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
422 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
423 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
424 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
425 If FROM or TO is negative, it counts from the end.")
428 register Lisp_Object from
, to
;
432 CHECK_STRING (string
, 0);
433 CHECK_NUMBER (from
, 1);
435 to
= Flength (string
);
437 CHECK_NUMBER (to
, 2);
440 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
442 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
443 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
444 && XINT (to
) <= XSTRING (string
)->size
))
445 args_out_of_range_3 (string
, from
, to
);
447 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
448 XINT (to
) - XINT (from
));
449 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
453 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
454 "Take cdr N times on LIST, returns the result.")
457 register Lisp_Object list
;
462 for (i
= 0; i
< num
&& !NILP (list
); i
++)
470 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
471 "Return the Nth element of LIST.\n\
472 N counts from zero. If LIST is not that long, nil is returned.")
476 return Fcar (Fnthcdr (n
, list
));
479 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
480 "Return element of SEQUENCE at index N.")
482 register Lisp_Object seq
, n
;
487 if (CONSP (seq
) || NILP (seq
))
488 return Fcar (Fnthcdr (n
, seq
));
489 else if (STRINGP (seq
) || VECTORP (seq
))
490 return Faref (seq
, n
);
492 seq
= wrong_type_argument (Qsequencep
, seq
);
496 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
497 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
498 The value is actually the tail of LIST whose car is ELT.")
500 register Lisp_Object elt
;
503 register Lisp_Object tail
;
504 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
506 register Lisp_Object tem
;
508 if (! NILP (Fequal (elt
, tem
)))
515 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
516 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
517 The value is actually the tail of LIST whose car is ELT.")
519 register Lisp_Object elt
;
522 register Lisp_Object tail
;
523 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
525 register Lisp_Object tem
;
527 if (EQ (elt
, tem
)) return tail
;
533 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
534 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
535 The value is actually the element of LIST whose car is KEY.\n\
536 Elements of LIST that are not conses are ignored.")
538 register Lisp_Object key
;
541 register Lisp_Object tail
;
542 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
544 register Lisp_Object elt
, tem
;
546 if (!CONSP (elt
)) continue;
548 if (EQ (key
, tem
)) return elt
;
554 /* Like Fassq but never report an error and do not allow quits.
555 Use only on lists known never to be circular. */
558 assq_no_quit (key
, list
)
559 register Lisp_Object key
;
562 register Lisp_Object tail
;
563 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
565 register Lisp_Object elt
, tem
;
567 if (!CONSP (elt
)) continue;
569 if (EQ (key
, tem
)) return elt
;
574 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
575 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
576 The value is actually the element of LIST whose car equals KEY.")
578 register Lisp_Object key
;
581 register Lisp_Object tail
;
582 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
584 register Lisp_Object elt
, tem
;
586 if (!CONSP (elt
)) continue;
587 tem
= Fequal (Fcar (elt
), key
);
588 if (!NILP (tem
)) return elt
;
594 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
595 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
596 The value is actually the element of LIST whose cdr is ELT.")
598 register Lisp_Object key
;
601 register Lisp_Object tail
;
602 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
604 register Lisp_Object elt
, tem
;
606 if (!CONSP (elt
)) continue;
608 if (EQ (key
, tem
)) return elt
;
614 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
615 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
616 The value is actually the element of LIST whose cdr equals KEY.")
618 register Lisp_Object key
;
621 register Lisp_Object tail
;
622 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
624 register Lisp_Object elt
, tem
;
626 if (!CONSP (elt
)) continue;
627 tem
= Fequal (Fcdr (elt
), key
);
628 if (!NILP (tem
)) return elt
;
634 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
635 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
636 The modified LIST is returned. Comparison is done with `eq'.\n\
637 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
638 therefore, write `(setq foo (delq element foo))'\n\
639 to be sure of changing the value of `foo'.")
641 register Lisp_Object elt
;
644 register Lisp_Object tail
, prev
;
645 register Lisp_Object tem
;
657 Fsetcdr (prev
, Fcdr (tail
));
667 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
668 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
669 The modified LIST is returned. Comparison is done with `equal'.\n\
670 If the first member of LIST is ELT, deleting it is not a side effect;\n\
671 it is simply using a different list.\n\
672 Therefore, write `(setq foo (delete element foo))'\n\
673 to be sure of changing the value of `foo'.")
675 register Lisp_Object elt
;
678 register Lisp_Object tail
, prev
;
679 register Lisp_Object tem
;
686 if (! NILP (Fequal (elt
, tem
)))
691 Fsetcdr (prev
, Fcdr (tail
));
701 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
702 "Reverse LIST by modifying cdr pointers.\n\
703 Returns the beginning of the reversed list.")
707 register Lisp_Object prev
, tail
, next
;
709 if (NILP (list
)) return list
;
716 Fsetcdr (tail
, prev
);
723 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
724 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
725 See also the function `nreverse', which is used more often.")
730 register Lisp_Object
*vec
;
731 register Lisp_Object tail
;
734 length
= Flength (list
);
735 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
736 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
737 vec
[i
] = Fcar (tail
);
739 return Flist (XINT (length
), vec
);
742 Lisp_Object
merge ();
744 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
745 "Sort LIST, stably, comparing elements using PREDICATE.\n\
746 Returns the sorted list. LIST is modified by side effects.\n\
747 PREDICATE is called with two elements of LIST, and should return T\n\
748 if the first element is \"less\" than the second.")
750 Lisp_Object list
, pred
;
752 Lisp_Object front
, back
;
753 register Lisp_Object len
, tem
;
754 struct gcpro gcpro1
, gcpro2
;
758 len
= Flength (list
);
763 XSETINT (len
, (length
/ 2) - 1);
764 tem
= Fnthcdr (len
, list
);
768 GCPRO2 (front
, back
);
769 front
= Fsort (front
, pred
);
770 back
= Fsort (back
, pred
);
772 return merge (front
, back
, pred
);
776 merge (org_l1
, org_l2
, pred
)
777 Lisp_Object org_l1
, org_l2
;
781 register Lisp_Object tail
;
783 register Lisp_Object l1
, l2
;
784 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
791 /* It is sufficient to protect org_l1 and org_l2.
792 When l1 and l2 are updated, we copy the new values
793 back into the org_ vars. */
794 GCPRO4 (org_l1
, org_l2
, pred
, value
);
814 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
836 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
837 "Extract a value from a property list.\n\
838 PLIST is a property list, which is a list of the form\n\
839 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
840 corresponding to the given PROP, or nil if PROP is not\n\
841 one of the properties on the list.")
844 register Lisp_Object prop
;
846 register Lisp_Object tail
;
847 for (tail
= val
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
849 register Lisp_Object tem
;
852 return Fcar (Fcdr (tail
));
857 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
858 "Return the value of SYMBOL's PROPNAME property.\n\
859 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
861 Lisp_Object symbol
, propname
;
863 CHECK_SYMBOL (symbol
, 0);
864 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
867 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
868 "Change value in PLIST of PROP to VAL.\n\
869 PLIST is a property list, which is a list of the form\n\
870 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
871 If PROP is already a property on the list, its value is set to VAL,\n\
872 otherwise the new PROP VAL pair is added. The new plist is returned;
873 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
874 The PLIST is modified by side effects.")
877 register Lisp_Object prop
;
880 register Lisp_Object tail
, prev
;
883 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
885 register Lisp_Object tem
;
889 Fsetcar (Fcdr (tail
), val
);
894 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
898 Fsetcdr (Fcdr (prev
), newcell
);
902 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
903 "Store SYMBOL's PROPNAME property with value VALUE.\n\
904 It can be retrieved with `(get SYMBOL PROPNAME)'.")
905 (symbol
, propname
, value
)
906 Lisp_Object symbol
, propname
, value
;
908 CHECK_SYMBOL (symbol
, 0);
909 XSYMBOL (symbol
)->plist
910 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
914 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
915 "T if two Lisp objects have similar structure and contents.\n\
916 They must have the same data type.\n\
917 Conses are compared by comparing the cars and the cdrs.\n\
918 Vectors and strings are compared element by element.\n\
919 Numbers are compared by value, but integers cannot equal floats.\n\
920 (Use `=' if you want integers and floats to be able to be equal.)\n\
921 Symbols must match exactly.")
923 register Lisp_Object o1
, o2
;
925 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
929 internal_equal (o1
, o2
, depth
)
930 register Lisp_Object o1
, o2
;
934 error ("Stack overflow in equal");
940 if (XTYPE (o1
) != XTYPE (o2
))
945 #ifdef LISP_FLOAT_TYPE
947 return (extract_float (o1
) == extract_float (o2
));
951 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
953 o1
= XCONS (o1
)->cdr
;
954 o2
= XCONS (o2
)->cdr
;
958 if (XMISC (o1
)->type
!= XMISC (o2
)->type
)
962 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
964 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
967 o1
= XOVERLAY (o1
)->plist
;
968 o2
= XOVERLAY (o2
)->plist
;
973 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
974 && (XMARKER (o1
)->buffer
== 0
975 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
979 case Lisp_Vectorlike
:
981 register int i
, size
;
982 size
= XVECTOR (o1
)->size
;
983 /* Pseudovectors have the type encoded in the size field, so this test
984 actually checks that the objects have the same type as well as the
986 if (XVECTOR (o2
)->size
!= size
)
988 /* But only true vectors and compiled functions are actually sensible
989 to compare, so eliminate the others now. */
990 if (size
& PSEUDOVECTOR_FLAG
)
992 if (!(size
& PVEC_COMPILED
))
994 size
&= PSEUDOVECTOR_SIZE_MASK
;
996 for (i
= 0; i
< size
; i
++)
999 v1
= XVECTOR (o1
)->contents
[i
];
1000 v2
= XVECTOR (o2
)->contents
[i
];
1001 if (!internal_equal (v1
, v2
, depth
+ 1))
1009 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1011 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1012 XSTRING (o1
)->size
))
1014 #ifdef USE_TEXT_PROPERTIES
1015 /* If the strings have intervals, verify they match;
1016 if not, they are unequal. */
1017 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1018 && ! compare_string_intervals (o1
, o2
))
1026 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1027 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
1029 Lisp_Object array
, item
;
1031 register int size
, index
, charval
;
1033 if (VECTORP (array
))
1035 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1036 size
= XVECTOR (array
)->size
;
1037 for (index
= 0; index
< size
; index
++)
1040 else if (STRINGP (array
))
1042 register unsigned char *p
= XSTRING (array
)->data
;
1043 CHECK_NUMBER (item
, 1);
1044 charval
= XINT (item
);
1045 size
= XSTRING (array
)->size
;
1046 for (index
= 0; index
< size
; index
++)
1051 array
= wrong_type_argument (Qarrayp
, array
);
1063 Lisp_Object args
[2];
1066 return Fnconc (2, args
);
1068 return Fnconc (2, &s1
);
1069 #endif /* NO_ARG_ARRAY */
1072 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1073 "Concatenate any number of lists by altering them.\n\
1074 Only the last argument is not altered, and need not be a list.")
1079 register int argnum
;
1080 register Lisp_Object tail
, tem
, val
;
1084 for (argnum
= 0; argnum
< nargs
; argnum
++)
1087 if (NILP (tem
)) continue;
1092 if (argnum
+ 1 == nargs
) break;
1095 tem
= wrong_type_argument (Qlistp
, tem
);
1104 tem
= args
[argnum
+ 1];
1105 Fsetcdr (tail
, tem
);
1107 args
[argnum
+ 1] = tail
;
1113 /* This is the guts of all mapping functions.
1114 Apply fn to each element of seq, one by one,
1115 storing the results into elements of vals, a C vector of Lisp_Objects.
1116 leni is the length of vals, which should also be the length of seq. */
1119 mapcar1 (leni
, vals
, fn
, seq
)
1122 Lisp_Object fn
, seq
;
1124 register Lisp_Object tail
;
1127 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1129 /* Don't let vals contain any garbage when GC happens. */
1130 for (i
= 0; i
< leni
; i
++)
1133 GCPRO3 (dummy
, fn
, seq
);
1135 gcpro1
.nvars
= leni
;
1136 /* We need not explicitly protect `tail' because it is used only on lists, and
1137 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1141 for (i
= 0; i
< leni
; i
++)
1143 dummy
= XVECTOR (seq
)->contents
[i
];
1144 vals
[i
] = call1 (fn
, dummy
);
1147 else if (STRINGP (seq
))
1149 for (i
= 0; i
< leni
; i
++)
1151 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1152 vals
[i
] = call1 (fn
, dummy
);
1155 else /* Must be a list, since Flength did not get an error */
1158 for (i
= 0; i
< leni
; i
++)
1160 vals
[i
] = call1 (fn
, Fcar (tail
));
1168 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1169 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1170 In between each pair of results, stick in SEP.\n\
1171 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1173 Lisp_Object fn
, seq
, sep
;
1178 register Lisp_Object
*args
;
1180 struct gcpro gcpro1
;
1182 len
= Flength (seq
);
1184 nargs
= leni
+ leni
- 1;
1185 if (nargs
< 0) return build_string ("");
1187 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1190 mapcar1 (leni
, args
, fn
, seq
);
1193 for (i
= leni
- 1; i
>= 0; i
--)
1194 args
[i
+ i
] = args
[i
];
1196 for (i
= 1; i
< nargs
; i
+= 2)
1199 return Fconcat (nargs
, args
);
1202 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1203 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1204 The result is a list just as long as SEQUENCE.\n\
1205 SEQUENCE may be a list, a vector or a string.")
1207 Lisp_Object fn
, seq
;
1209 register Lisp_Object len
;
1211 register Lisp_Object
*args
;
1213 len
= Flength (seq
);
1214 leni
= XFASTINT (len
);
1215 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1217 mapcar1 (leni
, args
, fn
, seq
);
1219 return Flist (leni
, args
);
1222 /* Anything that calls this function must protect from GC! */
1224 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1225 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1226 Takes one argument, which is the string to display to ask the question.\n\
1227 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1228 No confirmation of the answer is requested; a single character is enough.\n\
1229 Also accepts Space to mean yes, or Delete to mean no.")
1233 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1234 register int answer
;
1235 Lisp_Object xprompt
;
1236 Lisp_Object args
[2];
1237 int ocech
= cursor_in_echo_area
;
1238 struct gcpro gcpro1
, gcpro2
;
1240 map
= Fsymbol_value (intern ("query-replace-map"));
1242 CHECK_STRING (prompt
, 0);
1244 GCPRO2 (prompt
, xprompt
);
1249 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1252 Lisp_Object pane
, menu
;
1253 redisplay_preserve_echo_area ();
1254 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1255 Fcons (Fcons (build_string ("No"), Qnil
),
1257 menu
= Fcons (prompt
, pane
);
1258 obj
= Fx_popup_dialog (Qt
, menu
);
1259 answer
= !NILP (obj
);
1263 cursor_in_echo_area
= 1;
1264 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1266 obj
= read_filtered_event (1, 0, 0);
1267 cursor_in_echo_area
= 0;
1268 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1271 key
= Fmake_vector (make_number (1), obj
);
1272 def
= Flookup_key (map
, key
);
1273 answer_string
= Fsingle_key_description (obj
);
1275 if (EQ (def
, intern ("skip")))
1280 else if (EQ (def
, intern ("act")))
1285 else if (EQ (def
, intern ("recenter")))
1291 else if (EQ (def
, intern ("quit")))
1293 /* We want to exit this command for exit-prefix,
1294 and this is the only way to do it. */
1295 else if (EQ (def
, intern ("exit-prefix")))
1300 /* If we don't clear this, then the next call to read_char will
1301 return quit_char again, and we'll enter an infinite loop. */
1306 if (EQ (xprompt
, prompt
))
1308 args
[0] = build_string ("Please answer y or n. ");
1310 xprompt
= Fconcat (2, args
);
1315 if (! noninteractive
)
1317 cursor_in_echo_area
= -1;
1318 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1319 cursor_in_echo_area
= ocech
;
1322 return answer
? Qt
: Qnil
;
1325 /* This is how C code calls `yes-or-no-p' and allows the user
1328 Anything that calls this function must protect from GC! */
1331 do_yes_or_no_p (prompt
)
1334 return call1 (intern ("yes-or-no-p"), prompt
);
1337 /* Anything that calls this function must protect from GC! */
1339 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1340 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1341 Takes one argument, which is the string to display to ask the question.\n\
1342 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1343 The user must confirm the answer with RET,\n\
1344 and can edit it until it as been confirmed.")
1348 register Lisp_Object ans
;
1349 Lisp_Object args
[2];
1350 struct gcpro gcpro1
;
1353 CHECK_STRING (prompt
, 0);
1356 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1359 Lisp_Object pane
, menu
, obj
;
1360 redisplay_preserve_echo_area ();
1361 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1362 Fcons (Fcons (build_string ("No"), Qnil
),
1365 menu
= Fcons (prompt
, pane
);
1366 obj
= Fx_popup_dialog (Qt
, menu
);
1373 args
[1] = build_string ("(yes or no) ");
1374 prompt
= Fconcat (2, args
);
1380 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1381 Qyes_or_no_p_history
));
1382 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1387 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1395 message ("Please answer yes or no.");
1396 Fsleep_for (make_number (2), Qnil
);
1400 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1401 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1402 Each of the three load averages is multiplied by 100,\n\
1403 then converted to integer.\n\
1404 If the 5-minute or 15-minute load averages are not available, return a\n\
1405 shortened list, containing only those averages which are available.")
1409 int loads
= getloadavg (load_ave
, 3);
1413 error ("load-average not implemented for this operating system");
1417 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1422 Lisp_Object Vfeatures
;
1424 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1425 "Returns t if FEATURE is present in this Emacs.\n\
1426 Use this to conditionalize execution of lisp code based on the presence or\n\
1427 absence of emacs or environment extensions.\n\
1428 Use `provide' to declare that a feature is available.\n\
1429 This function looks at the value of the variable `features'.")
1431 Lisp_Object feature
;
1433 register Lisp_Object tem
;
1434 CHECK_SYMBOL (feature
, 0);
1435 tem
= Fmemq (feature
, Vfeatures
);
1436 return (NILP (tem
)) ? Qnil
: Qt
;
1439 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1440 "Announce that FEATURE is a feature of the current Emacs.")
1442 Lisp_Object feature
;
1444 register Lisp_Object tem
;
1445 CHECK_SYMBOL (feature
, 0);
1446 if (!NILP (Vautoload_queue
))
1447 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1448 tem
= Fmemq (feature
, Vfeatures
);
1450 Vfeatures
= Fcons (feature
, Vfeatures
);
1451 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1455 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1456 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1457 If FEATURE is not a member of the list `features', then the feature\n\
1458 is not loaded; so load the file FILENAME.\n\
1459 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1460 (feature
, file_name
)
1461 Lisp_Object feature
, file_name
;
1463 register Lisp_Object tem
;
1464 CHECK_SYMBOL (feature
, 0);
1465 tem
= Fmemq (feature
, Vfeatures
);
1466 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1469 int count
= specpdl_ptr
- specpdl
;
1471 /* Value saved here is to be restored into Vautoload_queue */
1472 record_unwind_protect (un_autoload
, Vautoload_queue
);
1473 Vautoload_queue
= Qt
;
1475 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1478 tem
= Fmemq (feature
, Vfeatures
);
1480 error ("Required feature %s was not provided",
1481 XSYMBOL (feature
)->name
->data
);
1483 /* Once loading finishes, don't undo it. */
1484 Vautoload_queue
= Qt
;
1485 feature
= unbind_to (count
, feature
);
1492 Qstring_lessp
= intern ("string-lessp");
1493 staticpro (&Qstring_lessp
);
1494 Qprovide
= intern ("provide");
1495 staticpro (&Qprovide
);
1496 Qrequire
= intern ("require");
1497 staticpro (&Qrequire
);
1498 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1499 staticpro (&Qyes_or_no_p_history
);
1501 DEFVAR_LISP ("features", &Vfeatures
,
1502 "A list of symbols which are the features of the executing emacs.\n\
1503 Used by `featurep' and `require', and altered by `provide'.");
1506 defsubr (&Sidentity
);
1509 defsubr (&Sstring_equal
);
1510 defsubr (&Sstring_lessp
);
1513 defsubr (&Svconcat
);
1514 defsubr (&Scopy_sequence
);
1515 defsubr (&Scopy_alist
);
1516 defsubr (&Ssubstring
);
1528 defsubr (&Snreverse
);
1529 defsubr (&Sreverse
);
1531 defsubr (&Splist_get
);
1533 defsubr (&Splist_put
);
1536 defsubr (&Sfillarray
);
1539 defsubr (&Smapconcat
);
1540 defsubr (&Sy_or_n_p
);
1541 defsubr (&Syes_or_no_p
);
1542 defsubr (&Sload_average
);
1543 defsubr (&Sfeaturep
);
1544 defsubr (&Srequire
);
1545 defsubr (&Sprovide
);