1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993 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 1, 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 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
36 Lisp_Object Qyes_or_no_p_history
;
38 static Lisp_Object
internal_equal ();
40 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
41 "Return the argument unchanged.")
48 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
49 "Return a pseudo-random number.\n\
50 On most systems all integers representable in Lisp are equally likely.\n\
51 This is 24 bits' worth.\n\
52 With argument N, return random number in interval [0,N).\n\
53 With argument t, set the random number seed from the current time and pid.")
58 unsigned long denominator
;
59 extern long random ();
64 srandom (getpid () + time (0));
65 if (XTYPE (limit
) == Lisp_Int
&& XINT (limit
) > 0)
67 /* Try to take our random number from the higher bits of VAL,
68 not the lower, since (says Gentzel) the low bits of `random'
69 are less random than the higher ones. We do this by using the
70 quotient rather than the remainder. At the high end of the RNG
71 it's possible to get a quotient larger than limit; discarding
72 these values eliminates the bias that would otherwise appear
73 when using a large limit. */
74 denominator
= (unsigned long)0x80000000 / XFASTINT (limit
);
76 val
= (random () & 0x7fffffff) / denominator
;
81 return make_number (val
);
84 /* Random data-structure functions */
86 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
87 "Return the length of vector, list or string SEQUENCE.\n\
88 A byte-code function object is also allowed.")
90 register Lisp_Object obj
;
92 register Lisp_Object tail
, val
;
96 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
97 || XTYPE (obj
) == Lisp_Compiled
)
98 return Farray_length (obj
);
101 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
117 obj
= wrong_type_argument (Qsequencep
, obj
);
122 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
123 "T if two strings have identical contents.\n\
124 Case is significant.\n\
125 Symbols are also allowed; their print names are used instead.")
127 register Lisp_Object s1
, s2
;
129 if (XTYPE (s1
) == Lisp_Symbol
)
130 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
131 if (XTYPE (s2
) == Lisp_Symbol
)
132 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
133 CHECK_STRING (s1
, 0);
134 CHECK_STRING (s2
, 1);
136 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
137 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
142 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
143 "T if first arg string is less than second in lexicographic order.\n\
144 Case is significant.\n\
145 Symbols are also allowed; their print names are used instead.")
147 register Lisp_Object s1
, s2
;
150 register unsigned char *p1
, *p2
;
153 if (XTYPE (s1
) == Lisp_Symbol
)
154 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
155 if (XTYPE (s2
) == Lisp_Symbol
)
156 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
157 CHECK_STRING (s1
, 0);
158 CHECK_STRING (s2
, 1);
160 p1
= XSTRING (s1
)->data
;
161 p2
= XSTRING (s2
)->data
;
162 end
= XSTRING (s1
)->size
;
163 if (end
> XSTRING (s2
)->size
)
164 end
= XSTRING (s2
)->size
;
166 for (i
= 0; i
< end
; i
++)
169 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
171 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
174 static Lisp_Object
concat ();
185 return concat (2, args
, Lisp_String
, 0);
187 return concat (2, &s1
, Lisp_String
, 0);
188 #endif /* NO_ARG_ARRAY */
191 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
192 "Concatenate all the arguments and make the result a list.\n\
193 The result is a list whose elements are the elements of all the arguments.\n\
194 Each argument may be a list, vector or string.\n\
195 The last argument is not copied, just used as the tail of the new list.")
200 return concat (nargs
, args
, Lisp_Cons
, 1);
203 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
204 "Concatenate all the arguments and make the result a string.\n\
205 The result is a string whose elements are the elements of all the arguments.\n\
206 Each argument may be a string, a list of characters (integers),\n\
207 or a vector of characters (integers).")
212 return concat (nargs
, args
, Lisp_String
, 0);
215 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
216 "Concatenate all the arguments and make the result a vector.\n\
217 The result is a vector whose elements are the elements of all the arguments.\n\
218 Each argument may be a list, vector or string.")
223 return concat (nargs
, args
, Lisp_Vector
, 0);
226 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
227 "Return a copy of a list, vector or string.\n\
228 The elements of a list or vector are not copied; they are shared\n\
233 if (NILP (arg
)) return arg
;
234 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
235 arg
= wrong_type_argument (Qsequencep
, arg
);
236 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
240 concat (nargs
, args
, target_type
, last_special
)
243 enum Lisp_Type target_type
;
248 register Lisp_Object tail
;
249 register Lisp_Object
this;
253 Lisp_Object last_tail
;
256 /* In append, the last arg isn't treated like the others */
257 if (last_special
&& nargs
> 0)
260 last_tail
= args
[nargs
];
265 for (argnum
= 0; argnum
< nargs
; argnum
++)
268 if (!(CONSP (this) || NILP (this)
269 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
270 || XTYPE (this) == Lisp_Compiled
))
272 if (XTYPE (this) == Lisp_Int
)
273 args
[argnum
] = Fnumber_to_string (this);
275 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
279 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
282 len
= Flength (this);
283 leni
+= XFASTINT (len
);
286 XFASTINT (len
) = leni
;
288 if (target_type
== Lisp_Cons
)
289 val
= Fmake_list (len
, Qnil
);
290 else if (target_type
== Lisp_Vector
)
291 val
= Fmake_vector (len
, Qnil
);
293 val
= Fmake_string (len
, len
);
295 /* In append, if all but last arg are nil, return last arg */
296 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
300 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
306 for (argnum
= 0; argnum
< nargs
; argnum
++)
310 register int thisindex
= 0;
314 thislen
= Flength (this), thisleni
= XINT (thislen
);
316 if (XTYPE (this) == Lisp_String
&& XTYPE (val
) == Lisp_String
317 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
319 copy_text_properties (make_number (0), thislen
, this,
320 make_number (toindex
), val
, Qnil
);
325 register Lisp_Object elt
;
327 /* Fetch next element of `this' arg into `elt', or break if
328 `this' is exhausted. */
329 if (NILP (this)) break;
331 elt
= Fcar (this), this = Fcdr (this);
334 if (thisindex
>= thisleni
) break;
335 if (XTYPE (this) == Lisp_String
)
336 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
338 elt
= XVECTOR (this)->contents
[thisindex
++];
341 /* Store into result */
344 XCONS (tail
)->car
= elt
;
346 tail
= XCONS (tail
)->cdr
;
348 else if (XTYPE (val
) == Lisp_Vector
)
349 XVECTOR (val
)->contents
[toindex
++] = elt
;
352 while (XTYPE (elt
) != Lisp_Int
)
353 elt
= wrong_type_argument (Qintegerp
, elt
);
355 #ifdef MASSC_REGISTER_BUG
356 /* Even removing all "register"s doesn't disable this bug!
357 Nothing simpler than this seems to work. */
358 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
361 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
368 XCONS (prev
)->cdr
= last_tail
;
373 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
374 "Return a copy of ALIST.\n\
375 This is an alist which represents the same mapping from objects to objects,\n\
376 but does not share the alist structure with ALIST.\n\
377 The objects mapped (cars and cdrs of elements of the alist)\n\
378 are shared, however.\n\
379 Elements of ALIST that are not conses are also shared.")
383 register Lisp_Object tem
;
385 CHECK_LIST (alist
, 0);
388 alist
= concat (1, &alist
, Lisp_Cons
, 0);
389 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
391 register Lisp_Object car
;
392 car
= XCONS (tem
)->car
;
395 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
400 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
401 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
402 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
403 If FROM or TO is negative, it counts from the end.")
406 register Lisp_Object from
, to
;
410 CHECK_STRING (string
, 0);
411 CHECK_NUMBER (from
, 1);
413 to
= Flength (string
);
415 CHECK_NUMBER (to
, 2);
418 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
420 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
421 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
422 && XINT (to
) <= XSTRING (string
)->size
))
423 args_out_of_range_3 (string
, from
, to
);
425 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
426 XINT (to
) - XINT (from
));
427 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
431 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
432 "Take cdr N times on LIST, returns the result.")
435 register Lisp_Object list
;
440 for (i
= 0; i
< num
&& !NILP (list
); i
++)
448 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
449 "Return the Nth element of LIST.\n\
450 N counts from zero. If LIST is not that long, nil is returned.")
454 return Fcar (Fnthcdr (n
, list
));
457 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
458 "Return element of SEQUENCE at index N.")
460 register Lisp_Object seq
, n
;
465 if (XTYPE (seq
) == Lisp_Cons
|| NILP (seq
))
466 return Fcar (Fnthcdr (n
, seq
));
467 else if (XTYPE (seq
) == Lisp_String
468 || XTYPE (seq
) == Lisp_Vector
)
469 return Faref (seq
, n
);
471 seq
= wrong_type_argument (Qsequencep
, seq
);
475 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
476 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
477 The value is actually the tail of LIST whose car is ELT.")
479 register Lisp_Object elt
;
482 register Lisp_Object tail
;
483 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
485 register Lisp_Object tem
;
487 if (! NILP (Fequal (elt
, tem
)))
494 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
495 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
496 The value is actually the tail of LIST whose car is ELT.")
498 register Lisp_Object elt
;
501 register Lisp_Object tail
;
502 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
504 register Lisp_Object tem
;
506 if (EQ (elt
, tem
)) return tail
;
512 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
513 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
514 The value is actually the element of LIST whose car is KEY.\n\
515 Elements of LIST that are not conses are ignored.")
517 register Lisp_Object key
;
520 register Lisp_Object tail
;
521 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
523 register Lisp_Object elt
, tem
;
525 if (!CONSP (elt
)) continue;
527 if (EQ (key
, tem
)) return elt
;
533 /* Like Fassq but never report an error and do not allow quits.
534 Use only on lists known never to be circular. */
537 assq_no_quit (key
, list
)
538 register Lisp_Object key
;
541 register Lisp_Object tail
;
542 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
544 register Lisp_Object elt
, tem
;
546 if (!CONSP (elt
)) continue;
548 if (EQ (key
, tem
)) return elt
;
553 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
554 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
555 The value is actually the element of LIST whose car is KEY.")
557 register Lisp_Object key
;
560 register Lisp_Object tail
;
561 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
563 register Lisp_Object elt
, tem
;
565 if (!CONSP (elt
)) continue;
566 tem
= Fequal (Fcar (elt
), key
);
567 if (!NILP (tem
)) return elt
;
573 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
574 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
575 The value is actually the element of LIST whose cdr is ELT.")
577 register Lisp_Object key
;
580 register Lisp_Object tail
;
581 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
583 register Lisp_Object elt
, tem
;
585 if (!CONSP (elt
)) continue;
587 if (EQ (key
, tem
)) return elt
;
593 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
594 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
595 The modified LIST is returned. Comparison is done with `eq'.\n\
596 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
597 therefore, write `(setq foo (delq element foo))'\n\
598 to be sure of changing the value of `foo'.")
600 register Lisp_Object elt
;
603 register Lisp_Object tail
, prev
;
604 register Lisp_Object tem
;
616 Fsetcdr (prev
, Fcdr (tail
));
626 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
627 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
628 The modified LIST is returned. Comparison is done with `equal'.\n\
629 If the first member of LIST is ELT, deleting it is not a side effect;\n\
630 it is simply using a different list.\n\
631 Therefore, write `(setq foo (delete element foo))'\n\
632 to be sure of changing the value of `foo'.")
634 register Lisp_Object elt
;
637 register Lisp_Object tail
, prev
;
638 register Lisp_Object tem
;
645 if (! NILP (Fequal (elt
, tem
)))
650 Fsetcdr (prev
, Fcdr (tail
));
660 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
661 "Reverse LIST by modifying cdr pointers.\n\
662 Returns the beginning of the reversed list.")
666 register Lisp_Object prev
, tail
, next
;
668 if (NILP (list
)) return list
;
675 Fsetcdr (tail
, prev
);
682 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
683 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
684 See also the function `nreverse', which is used more often.")
689 register Lisp_Object
*vec
;
690 register Lisp_Object tail
;
693 length
= Flength (list
);
694 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
695 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
696 vec
[i
] = Fcar (tail
);
698 return Flist (XINT (length
), vec
);
701 Lisp_Object
merge ();
703 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
704 "Sort LIST, stably, comparing elements using PREDICATE.\n\
705 Returns the sorted list. LIST is modified by side effects.\n\
706 PREDICATE is called with two elements of LIST, and should return T\n\
707 if the first element is \"less\" than the second.")
709 Lisp_Object list
, pred
;
711 Lisp_Object front
, back
;
712 register Lisp_Object len
, tem
;
713 struct gcpro gcpro1
, gcpro2
;
717 len
= Flength (list
);
722 XSETINT (len
, (length
/ 2) - 1);
723 tem
= Fnthcdr (len
, list
);
727 GCPRO2 (front
, back
);
728 front
= Fsort (front
, pred
);
729 back
= Fsort (back
, pred
);
731 return merge (front
, back
, pred
);
735 merge (org_l1
, org_l2
, pred
)
736 Lisp_Object org_l1
, org_l2
;
740 register Lisp_Object tail
;
742 register Lisp_Object l1
, l2
;
743 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
750 /* It is sufficient to protect org_l1 and org_l2.
751 When l1 and l2 are updated, we copy the new values
752 back into the org_ vars. */
753 GCPRO4 (org_l1
, org_l2
, pred
, value
);
773 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
794 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
795 "Return the value of SYMBOL's PROPNAME property.\n\
796 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
799 register Lisp_Object prop
;
801 register Lisp_Object tail
;
802 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
804 register Lisp_Object tem
;
807 return Fcar (Fcdr (tail
));
812 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
813 "Store SYMBOL's PROPNAME property with value VALUE.\n\
814 It can be retrieved with `(get SYMBOL PROPNAME)'.")
817 register Lisp_Object prop
;
820 register Lisp_Object tail
, prev
;
823 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
825 register Lisp_Object tem
;
828 return Fsetcar (Fcdr (tail
), val
);
831 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
833 Fsetplist (sym
, newcell
);
835 Fsetcdr (Fcdr (prev
), newcell
);
839 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
840 "T if two Lisp objects have similar structure and contents.\n\
841 They must have the same data type.\n\
842 Conses are compared by comparing the cars and the cdrs.\n\
843 Vectors and strings are compared element by element.\n\
844 Numbers are compared by value, but integers cannot equal floats.\n\
845 (Use `=' if you want integers and floats to be able to be equal.)\n\
846 Symbols must match exactly.")
848 register Lisp_Object o1
, o2
;
850 return internal_equal (o1
, o2
, 0);
854 internal_equal (o1
, o2
, depth
)
855 register Lisp_Object o1
, o2
;
859 error ("Stack overflow in equal");
862 if (EQ (o1
, o2
)) return Qt
;
863 #ifdef LISP_FLOAT_TYPE
864 if (FLOATP (o1
) && FLOATP (o2
))
865 return (extract_float (o1
) == extract_float (o2
)) ? Qt
: Qnil
;
867 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
868 if (XTYPE (o1
) == Lisp_Cons
869 || XTYPE (o1
) == Lisp_Overlay
)
872 v1
= internal_equal (Fcar (o1
), Fcar (o2
), depth
+ 1);
875 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
878 if (XTYPE (o1
) == Lisp_Marker
)
880 return ((XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
881 && (XMARKER (o1
)->buffer
== 0
882 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
))
885 if (XTYPE (o1
) == Lisp_Vector
886 || XTYPE (o1
) == Lisp_Compiled
)
889 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
891 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
893 Lisp_Object v
, v1
, v2
;
894 v1
= XVECTOR (o1
)->contents
[index
];
895 v2
= XVECTOR (o2
)->contents
[index
];
896 v
= internal_equal (v1
, v2
, depth
+ 1);
897 if (NILP (v
)) return v
;
901 if (XTYPE (o1
) == Lisp_String
)
903 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
905 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
912 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
913 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
915 Lisp_Object array
, item
;
917 register int size
, index
, charval
;
919 if (XTYPE (array
) == Lisp_Vector
)
921 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
922 size
= XVECTOR (array
)->size
;
923 for (index
= 0; index
< size
; index
++)
926 else if (XTYPE (array
) == Lisp_String
)
928 register unsigned char *p
= XSTRING (array
)->data
;
929 CHECK_NUMBER (item
, 1);
930 charval
= XINT (item
);
931 size
= XSTRING (array
)->size
;
932 for (index
= 0; index
< size
; index
++)
937 array
= wrong_type_argument (Qarrayp
, array
);
952 return Fnconc (2, args
);
954 return Fnconc (2, &s1
);
955 #endif /* NO_ARG_ARRAY */
958 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
959 "Concatenate any number of lists by altering them.\n\
960 Only the last argument is not altered, and need not be a list.")
966 register Lisp_Object tail
, tem
, val
;
970 for (argnum
= 0; argnum
< nargs
; argnum
++)
973 if (NILP (tem
)) continue;
978 if (argnum
+ 1 == nargs
) break;
981 tem
= wrong_type_argument (Qlistp
, tem
);
990 tem
= args
[argnum
+ 1];
993 args
[argnum
+ 1] = tail
;
999 /* This is the guts of all mapping functions.
1000 Apply fn to each element of seq, one by one,
1001 storing the results into elements of vals, a C vector of Lisp_Objects.
1002 leni is the length of vals, which should also be the length of seq. */
1005 mapcar1 (leni
, vals
, fn
, seq
)
1008 Lisp_Object fn
, seq
;
1010 register Lisp_Object tail
;
1013 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1015 /* Don't let vals contain any garbage when GC happens. */
1016 for (i
= 0; i
< leni
; i
++)
1019 GCPRO3 (dummy
, fn
, seq
);
1021 gcpro1
.nvars
= leni
;
1022 /* We need not explicitly protect `tail' because it is used only on lists, and
1023 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1025 if (XTYPE (seq
) == Lisp_Vector
)
1027 for (i
= 0; i
< leni
; i
++)
1029 dummy
= XVECTOR (seq
)->contents
[i
];
1030 vals
[i
] = call1 (fn
, dummy
);
1033 else if (XTYPE (seq
) == Lisp_String
)
1035 for (i
= 0; i
< leni
; i
++)
1037 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1038 vals
[i
] = call1 (fn
, dummy
);
1041 else /* Must be a list, since Flength did not get an error */
1044 for (i
= 0; i
< leni
; i
++)
1046 vals
[i
] = call1 (fn
, Fcar (tail
));
1054 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1055 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1056 In between each pair of results, stick in SEP.\n\
1057 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1059 Lisp_Object fn
, seq
, sep
;
1064 register Lisp_Object
*args
;
1066 struct gcpro gcpro1
;
1068 len
= Flength (seq
);
1070 nargs
= leni
+ leni
- 1;
1071 if (nargs
< 0) return build_string ("");
1073 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1076 mapcar1 (leni
, args
, fn
, seq
);
1079 for (i
= leni
- 1; i
>= 0; i
--)
1080 args
[i
+ i
] = args
[i
];
1082 for (i
= 1; i
< nargs
; i
+= 2)
1085 return Fconcat (nargs
, args
);
1088 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1089 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1090 The result is a list just as long as SEQUENCE.\n\
1091 SEQUENCE may be a list, a vector or a string.")
1093 Lisp_Object fn
, seq
;
1095 register Lisp_Object len
;
1097 register Lisp_Object
*args
;
1099 len
= Flength (seq
);
1100 leni
= XFASTINT (len
);
1101 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1103 mapcar1 (leni
, args
, fn
, seq
);
1105 return Flist (leni
, args
);
1108 /* Anything that calls this function must protect from GC! */
1110 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1111 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1112 Takes one argument, which is the string to display to ask the question.\n\
1113 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1114 No confirmation of the answer is requested; a single character is enough.\n\
1115 Also accepts Space to mean yes, or Delete to mean no.")
1119 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1120 register int answer
;
1121 Lisp_Object xprompt
;
1122 Lisp_Object args
[2];
1123 int ocech
= cursor_in_echo_area
;
1124 struct gcpro gcpro1
, gcpro2
;
1126 map
= Fsymbol_value (intern ("query-replace-map"));
1128 CHECK_STRING (prompt
, 0);
1130 GCPRO2 (prompt
, xprompt
);
1135 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1137 Lisp_Object pane
, menu
;
1138 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1139 Fcons (Fcons (build_string ("No"), Qnil
),
1141 menu
= Fcons (prompt
, pane
);
1142 obj
= Fx_popup_dialog (Qt
, menu
);
1143 answer
= !NILP (obj
);
1147 cursor_in_echo_area
= 1;
1148 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1150 obj
= read_filtered_event (1, 0, 0);
1151 cursor_in_echo_area
= 0;
1152 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1155 key
= Fmake_vector (make_number (1), obj
);
1156 def
= Flookup_key (map
, key
);
1157 answer_string
= Fsingle_key_description (obj
);
1159 if (EQ (def
, intern ("skip")))
1164 else if (EQ (def
, intern ("act")))
1169 else if (EQ (def
, intern ("recenter")))
1175 else if (EQ (def
, intern ("quit")))
1180 /* If we don't clear this, then the next call to read_char will
1181 return quit_char again, and we'll enter an infinite loop. */
1186 if (EQ (xprompt
, prompt
))
1188 args
[0] = build_string ("Please answer y or n. ");
1190 xprompt
= Fconcat (2, args
);
1195 if (! noninteractive
)
1197 cursor_in_echo_area
= -1;
1198 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1199 cursor_in_echo_area
= ocech
;
1202 return answer
? Qt
: Qnil
;
1205 /* This is how C code calls `yes-or-no-p' and allows the user
1208 Anything that calls this function must protect from GC! */
1211 do_yes_or_no_p (prompt
)
1214 return call1 (intern ("yes-or-no-p"), prompt
);
1217 /* Anything that calls this function must protect from GC! */
1219 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1220 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1221 Takes one argument, which is the string to display to ask the question.\n\
1222 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1223 The user must confirm the answer with RET,\n\
1224 and can edit it until it as been confirmed.")
1228 register Lisp_Object ans
;
1229 Lisp_Object args
[2];
1230 struct gcpro gcpro1
;
1233 CHECK_STRING (prompt
, 0);
1236 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1238 Lisp_Object pane
, menu
, obj
;
1239 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1240 Fcons (Fcons (build_string ("No"), Qnil
),
1243 menu
= Fcons (prompt
, pane
);
1244 obj
= Fx_popup_dialog (Qt
, menu
);
1251 args
[1] = build_string ("(yes or no) ");
1252 prompt
= Fconcat (2, args
);
1258 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1259 Qyes_or_no_p_history
));
1260 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1265 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1273 message ("Please answer yes or no.");
1274 Fsleep_for (make_number (2), Qnil
);
1278 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1279 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1280 Each of the three load averages is multiplied by 100,\n\
1281 then converted to integer.\n\
1282 If the 5-minute or 15-minute load averages are not available, return a\n\
1283 shortened list, containing only those averages which are available.")
1287 int loads
= getloadavg (load_ave
, 3);
1291 error ("load-average not implemented for this operating system");
1295 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1300 Lisp_Object Vfeatures
;
1302 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1303 "Returns t if FEATURE is present in this Emacs.\n\
1304 Use this to conditionalize execution of lisp code based on the presence or\n\
1305 absence of emacs or environment extensions.\n\
1306 Use `provide' to declare that a feature is available.\n\
1307 This function looks at the value of the variable `features'.")
1309 Lisp_Object feature
;
1311 register Lisp_Object tem
;
1312 CHECK_SYMBOL (feature
, 0);
1313 tem
= Fmemq (feature
, Vfeatures
);
1314 return (NILP (tem
)) ? Qnil
: Qt
;
1317 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1318 "Announce that FEATURE is a feature of the current Emacs.")
1320 Lisp_Object feature
;
1322 register Lisp_Object tem
;
1323 CHECK_SYMBOL (feature
, 0);
1324 if (!NILP (Vautoload_queue
))
1325 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1326 tem
= Fmemq (feature
, Vfeatures
);
1328 Vfeatures
= Fcons (feature
, Vfeatures
);
1329 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1333 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1334 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1335 If FEATURE is not a member of the list `features', then the feature\n\
1336 is not loaded; so load the file FILENAME.\n\
1337 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1338 (feature
, file_name
)
1339 Lisp_Object feature
, file_name
;
1341 register Lisp_Object tem
;
1342 CHECK_SYMBOL (feature
, 0);
1343 tem
= Fmemq (feature
, Vfeatures
);
1344 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1347 int count
= specpdl_ptr
- specpdl
;
1349 /* Value saved here is to be restored into Vautoload_queue */
1350 record_unwind_protect (un_autoload
, Vautoload_queue
);
1351 Vautoload_queue
= Qt
;
1353 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1356 tem
= Fmemq (feature
, Vfeatures
);
1358 error ("Required feature %s was not provided",
1359 XSYMBOL (feature
)->name
->data
);
1361 /* Once loading finishes, don't undo it. */
1362 Vautoload_queue
= Qt
;
1363 feature
= unbind_to (count
, feature
);
1370 Qstring_lessp
= intern ("string-lessp");
1371 staticpro (&Qstring_lessp
);
1372 Qprovide
= intern ("provide");
1373 staticpro (&Qprovide
);
1374 Qrequire
= intern ("require");
1375 staticpro (&Qrequire
);
1376 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1377 staticpro (&Qyes_or_no_p_history
);
1379 DEFVAR_LISP ("features", &Vfeatures
,
1380 "A list of symbols which are the features of the executing emacs.\n\
1381 Used by `featurep' and `require', and altered by `provide'.");
1384 defsubr (&Sidentity
);
1387 defsubr (&Sstring_equal
);
1388 defsubr (&Sstring_lessp
);
1391 defsubr (&Svconcat
);
1392 defsubr (&Scopy_sequence
);
1393 defsubr (&Scopy_alist
);
1394 defsubr (&Ssubstring
);
1405 defsubr (&Snreverse
);
1406 defsubr (&Sreverse
);
1411 defsubr (&Sfillarray
);
1414 defsubr (&Smapconcat
);
1415 defsubr (&Sy_or_n_p
);
1416 defsubr (&Syes_or_no_p
);
1417 defsubr (&Sload_average
);
1418 defsubr (&Sfeaturep
);
1419 defsubr (&Srequire
);
1420 defsubr (&Sprovide
);