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 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 extern Lisp_Object
Flookup_key ();
37 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
38 Lisp_Object Qyes_or_no_p_history
;
40 static Lisp_Object
internal_equal ();
42 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
43 "Return the argument unchanged.")
50 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
51 "Return a pseudo-random number.\n\
52 On most systems all integers representable in Lisp are equally likely.\n\
53 This is 24 bits' worth.\n\
54 With argument N, return random number in interval [0,N).\n\
55 With argument t, set the random number seed from the current time and pid.")
60 unsigned long denominator
;
61 extern long random ();
66 srandom (getpid () + time (0));
67 if (INTEGERP (limit
) && XINT (limit
) > 0)
69 if (XFASTINT (limit
) >= 0x40000000)
70 /* This case may occur on 64-bit machines. */
71 val
= random () % XFASTINT (limit
);
74 /* Try to take our random number from the higher bits of VAL,
75 not the lower, since (says Gentzel) the low bits of `random'
76 are less random than the higher ones. We do this by using the
77 quotient rather than the remainder. At the high end of the RNG
78 it's possible to get a quotient larger than limit; discarding
79 these values eliminates the bias that would otherwise appear
80 when using a large limit. */
81 denominator
= (unsigned long)0x40000000 / XFASTINT (limit
);
83 val
= (random () & 0x3fffffff) / denominator
;
84 while (val
>= XFASTINT (limit
));
89 return make_number (val
);
92 /* Random data-structure functions */
94 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
95 "Return the length of vector, list or string SEQUENCE.\n\
96 A byte-code function object is also allowed.")
98 register Lisp_Object obj
;
100 register Lisp_Object tail
, val
;
104 if (VECTORP (obj
) || STRINGP (obj
) || COMPILEDP (obj
))
105 return Farray_length (obj
);
106 else if (CONSP (obj
))
108 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
124 obj
= wrong_type_argument (Qsequencep
, obj
);
129 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
130 "T if two strings have identical contents.\n\
131 Case is significant.\n\
132 Symbols are also allowed; their print names are used instead.")
134 register Lisp_Object s1
, s2
;
137 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
139 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
140 CHECK_STRING (s1
, 0);
141 CHECK_STRING (s2
, 1);
143 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
144 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
149 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
150 "T if first arg string is less than second in lexicographic order.\n\
151 Case is significant.\n\
152 Symbols are also allowed; their print names are used instead.")
154 register Lisp_Object s1
, s2
;
157 register unsigned char *p1
, *p2
;
161 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
163 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
164 CHECK_STRING (s1
, 0);
165 CHECK_STRING (s2
, 1);
167 p1
= XSTRING (s1
)->data
;
168 p2
= XSTRING (s2
)->data
;
169 end
= XSTRING (s1
)->size
;
170 if (end
> XSTRING (s2
)->size
)
171 end
= XSTRING (s2
)->size
;
173 for (i
= 0; i
< end
; i
++)
176 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
178 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
181 static Lisp_Object
concat ();
192 return concat (2, args
, Lisp_String
, 0);
194 return concat (2, &s1
, Lisp_String
, 0);
195 #endif /* NO_ARG_ARRAY */
201 Lisp_Object s1
, s2
, s3
;
208 return concat (3, args
, Lisp_String
, 0);
210 return concat (3, &s1
, Lisp_String
, 0);
211 #endif /* NO_ARG_ARRAY */
214 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
215 "Concatenate all the arguments and make the result a list.\n\
216 The result is a list whose elements are the elements of all the arguments.\n\
217 Each argument may be a list, vector or string.\n\
218 The last argument is not copied, just used as the tail of the new list.")
223 return concat (nargs
, args
, Lisp_Cons
, 1);
226 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
227 "Concatenate all the arguments and make the result a string.\n\
228 The result is a string whose elements are the elements of all the arguments.\n\
229 Each argument may be a string, a list of characters (integers),\n\
230 or a vector of characters (integers).")
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_Vector
, 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 XFASTINT (len
) = leni
;
310 if (target_type
== Lisp_Cons
)
311 val
= Fmake_list (len
, Qnil
);
312 else if (target_type
== Lisp_Vector
)
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 XFASTINT (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 is 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 ("delq", Fdelq
, Sdelq
, 2, 2, 0,
615 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
616 The modified LIST is returned. Comparison is done with `eq'.\n\
617 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
618 therefore, write `(setq foo (delq element foo))'\n\
619 to be sure of changing the value of `foo'.")
621 register Lisp_Object elt
;
624 register Lisp_Object tail
, prev
;
625 register Lisp_Object tem
;
637 Fsetcdr (prev
, Fcdr (tail
));
647 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
648 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
649 The modified LIST is returned. Comparison is done with `equal'.\n\
650 If the first member of LIST is ELT, deleting it is not a side effect;\n\
651 it is simply using a different list.\n\
652 Therefore, write `(setq foo (delete element foo))'\n\
653 to be sure of changing the value of `foo'.")
655 register Lisp_Object elt
;
658 register Lisp_Object tail
, prev
;
659 register Lisp_Object tem
;
666 if (! NILP (Fequal (elt
, tem
)))
671 Fsetcdr (prev
, Fcdr (tail
));
681 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
682 "Reverse LIST by modifying cdr pointers.\n\
683 Returns the beginning of the reversed list.")
687 register Lisp_Object prev
, tail
, next
;
689 if (NILP (list
)) return list
;
696 Fsetcdr (tail
, prev
);
703 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
704 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
705 See also the function `nreverse', which is used more often.")
710 register Lisp_Object
*vec
;
711 register Lisp_Object tail
;
714 length
= Flength (list
);
715 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
716 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
717 vec
[i
] = Fcar (tail
);
719 return Flist (XINT (length
), vec
);
722 Lisp_Object
merge ();
724 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
725 "Sort LIST, stably, comparing elements using PREDICATE.\n\
726 Returns the sorted list. LIST is modified by side effects.\n\
727 PREDICATE is called with two elements of LIST, and should return T\n\
728 if the first element is \"less\" than the second.")
730 Lisp_Object list
, pred
;
732 Lisp_Object front
, back
;
733 register Lisp_Object len
, tem
;
734 struct gcpro gcpro1
, gcpro2
;
738 len
= Flength (list
);
743 XSETINT (len
, (length
/ 2) - 1);
744 tem
= Fnthcdr (len
, list
);
748 GCPRO2 (front
, back
);
749 front
= Fsort (front
, pred
);
750 back
= Fsort (back
, pred
);
752 return merge (front
, back
, pred
);
756 merge (org_l1
, org_l2
, pred
)
757 Lisp_Object org_l1
, org_l2
;
761 register Lisp_Object tail
;
763 register Lisp_Object l1
, l2
;
764 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
771 /* It is sufficient to protect org_l1 and org_l2.
772 When l1 and l2 are updated, we copy the new values
773 back into the org_ vars. */
774 GCPRO4 (org_l1
, org_l2
, pred
, value
);
794 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
815 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
816 "Return the value of SYMBOL's PROPNAME property.\n\
817 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
820 register Lisp_Object prop
;
822 register Lisp_Object tail
;
823 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
825 register Lisp_Object tem
;
828 return Fcar (Fcdr (tail
));
833 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
834 "Store SYMBOL's PROPNAME property with value VALUE.\n\
835 It can be retrieved with `(get SYMBOL PROPNAME)'.")
838 register Lisp_Object prop
;
841 register Lisp_Object tail
, prev
;
844 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
846 register Lisp_Object tem
;
849 return Fsetcar (Fcdr (tail
), val
);
852 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
854 Fsetplist (sym
, newcell
);
856 Fsetcdr (Fcdr (prev
), newcell
);
860 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
861 "T if two Lisp objects have similar structure and contents.\n\
862 They must have the same data type.\n\
863 Conses are compared by comparing the cars and the cdrs.\n\
864 Vectors and strings are compared element by element.\n\
865 Numbers are compared by value, but integers cannot equal floats.\n\
866 (Use `=' if you want integers and floats to be able to be equal.)\n\
867 Symbols must match exactly.")
869 register Lisp_Object o1
, o2
;
871 return internal_equal (o1
, o2
, 0);
875 internal_equal (o1
, o2
, depth
)
876 register Lisp_Object o1
, o2
;
880 error ("Stack overflow in equal");
883 if (EQ (o1
, o2
)) return Qt
;
884 #ifdef LISP_FLOAT_TYPE
885 if (FLOATP (o1
) && FLOATP (o2
))
886 return (extract_float (o1
) == extract_float (o2
)) ? Qt
: Qnil
;
888 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
889 if (CONSP (o1
) || OVERLAYP (o1
))
892 v1
= internal_equal (Fcar (o1
), Fcar (o2
), depth
+ 1);
895 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
900 return ((XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
901 && (XMARKER (o1
)->buffer
== 0
902 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
))
905 if (VECTORP (o1
) || COMPILEDP (o1
))
908 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
910 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
912 Lisp_Object v
, v1
, v2
;
913 v1
= XVECTOR (o1
)->contents
[index
];
914 v2
= XVECTOR (o2
)->contents
[index
];
915 v
= internal_equal (v1
, v2
, depth
+ 1);
916 if (NILP (v
)) return v
;
922 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
924 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
931 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
932 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
934 Lisp_Object array
, item
;
936 register int size
, index
, charval
;
940 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
941 size
= XVECTOR (array
)->size
;
942 for (index
= 0; index
< size
; index
++)
945 else if (STRINGP (array
))
947 register unsigned char *p
= XSTRING (array
)->data
;
948 CHECK_NUMBER (item
, 1);
949 charval
= XINT (item
);
950 size
= XSTRING (array
)->size
;
951 for (index
= 0; index
< size
; index
++)
956 array
= wrong_type_argument (Qarrayp
, array
);
971 return Fnconc (2, args
);
973 return Fnconc (2, &s1
);
974 #endif /* NO_ARG_ARRAY */
977 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
978 "Concatenate any number of lists by altering them.\n\
979 Only the last argument is not altered, and need not be a list.")
985 register Lisp_Object tail
, tem
, val
;
989 for (argnum
= 0; argnum
< nargs
; argnum
++)
992 if (NILP (tem
)) continue;
997 if (argnum
+ 1 == nargs
) break;
1000 tem
= wrong_type_argument (Qlistp
, tem
);
1009 tem
= args
[argnum
+ 1];
1010 Fsetcdr (tail
, tem
);
1012 args
[argnum
+ 1] = tail
;
1018 /* This is the guts of all mapping functions.
1019 Apply fn to each element of seq, one by one,
1020 storing the results into elements of vals, a C vector of Lisp_Objects.
1021 leni is the length of vals, which should also be the length of seq. */
1024 mapcar1 (leni
, vals
, fn
, seq
)
1027 Lisp_Object fn
, seq
;
1029 register Lisp_Object tail
;
1032 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1034 /* Don't let vals contain any garbage when GC happens. */
1035 for (i
= 0; i
< leni
; i
++)
1038 GCPRO3 (dummy
, fn
, seq
);
1040 gcpro1
.nvars
= leni
;
1041 /* We need not explicitly protect `tail' because it is used only on lists, and
1042 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1046 for (i
= 0; i
< leni
; i
++)
1048 dummy
= XVECTOR (seq
)->contents
[i
];
1049 vals
[i
] = call1 (fn
, dummy
);
1052 else if (STRINGP (seq
))
1054 for (i
= 0; i
< leni
; i
++)
1056 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1057 vals
[i
] = call1 (fn
, dummy
);
1060 else /* Must be a list, since Flength did not get an error */
1063 for (i
= 0; i
< leni
; i
++)
1065 vals
[i
] = call1 (fn
, Fcar (tail
));
1073 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1074 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1075 In between each pair of results, stick in SEP.\n\
1076 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1078 Lisp_Object fn
, seq
, sep
;
1083 register Lisp_Object
*args
;
1085 struct gcpro gcpro1
;
1087 len
= Flength (seq
);
1089 nargs
= leni
+ leni
- 1;
1090 if (nargs
< 0) return build_string ("");
1092 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1095 mapcar1 (leni
, args
, fn
, seq
);
1098 for (i
= leni
- 1; i
>= 0; i
--)
1099 args
[i
+ i
] = args
[i
];
1101 for (i
= 1; i
< nargs
; i
+= 2)
1104 return Fconcat (nargs
, args
);
1107 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1108 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1109 The result is a list just as long as SEQUENCE.\n\
1110 SEQUENCE may be a list, a vector or a string.")
1112 Lisp_Object fn
, seq
;
1114 register Lisp_Object len
;
1116 register Lisp_Object
*args
;
1118 len
= Flength (seq
);
1119 leni
= XFASTINT (len
);
1120 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1122 mapcar1 (leni
, args
, fn
, seq
);
1124 return Flist (leni
, args
);
1127 /* Anything that calls this function must protect from GC! */
1129 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1130 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1131 Takes one argument, which is the string to display to ask the question.\n\
1132 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1133 No confirmation of the answer is requested; a single character is enough.\n\
1134 Also accepts Space to mean yes, or Delete to mean no.")
1138 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1139 register int answer
;
1140 Lisp_Object xprompt
;
1141 Lisp_Object args
[2];
1142 int ocech
= cursor_in_echo_area
;
1143 struct gcpro gcpro1
, gcpro2
;
1145 map
= Fsymbol_value (intern ("query-replace-map"));
1147 CHECK_STRING (prompt
, 0);
1149 GCPRO2 (prompt
, xprompt
);
1154 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1157 Lisp_Object pane
, menu
;
1158 redisplay_preserve_echo_area ();
1159 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1160 Fcons (Fcons (build_string ("No"), Qnil
),
1162 menu
= Fcons (prompt
, pane
);
1163 obj
= Fx_popup_dialog (Qt
, menu
);
1164 answer
= !NILP (obj
);
1168 cursor_in_echo_area
= 1;
1169 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1171 obj
= read_filtered_event (1, 0, 0);
1172 cursor_in_echo_area
= 0;
1173 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1176 key
= Fmake_vector (make_number (1), obj
);
1177 def
= Flookup_key (map
, key
);
1178 answer_string
= Fsingle_key_description (obj
);
1180 if (EQ (def
, intern ("skip")))
1185 else if (EQ (def
, intern ("act")))
1190 else if (EQ (def
, intern ("recenter")))
1196 else if (EQ (def
, intern ("quit")))
1201 /* If we don't clear this, then the next call to read_char will
1202 return quit_char again, and we'll enter an infinite loop. */
1207 if (EQ (xprompt
, prompt
))
1209 args
[0] = build_string ("Please answer y or n. ");
1211 xprompt
= Fconcat (2, args
);
1216 if (! noninteractive
)
1218 cursor_in_echo_area
= -1;
1219 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1220 cursor_in_echo_area
= ocech
;
1223 return answer
? Qt
: Qnil
;
1226 /* This is how C code calls `yes-or-no-p' and allows the user
1229 Anything that calls this function must protect from GC! */
1232 do_yes_or_no_p (prompt
)
1235 return call1 (intern ("yes-or-no-p"), prompt
);
1238 /* Anything that calls this function must protect from GC! */
1240 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1241 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1242 Takes one argument, which is the string to display to ask the question.\n\
1243 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1244 The user must confirm the answer with RET,\n\
1245 and can edit it until it as been confirmed.")
1249 register Lisp_Object ans
;
1250 Lisp_Object args
[2];
1251 struct gcpro gcpro1
;
1254 CHECK_STRING (prompt
, 0);
1257 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1260 Lisp_Object pane
, menu
, obj
;
1261 redisplay_preserve_echo_area ();
1262 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1263 Fcons (Fcons (build_string ("No"), Qnil
),
1266 menu
= Fcons (prompt
, pane
);
1267 obj
= Fx_popup_dialog (Qt
, menu
);
1274 args
[1] = build_string ("(yes or no) ");
1275 prompt
= Fconcat (2, args
);
1281 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1282 Qyes_or_no_p_history
));
1283 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1288 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1296 message ("Please answer yes or no.");
1297 Fsleep_for (make_number (2), Qnil
);
1301 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1302 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1303 Each of the three load averages is multiplied by 100,\n\
1304 then converted to integer.\n\
1305 If the 5-minute or 15-minute load averages are not available, return a\n\
1306 shortened list, containing only those averages which are available.")
1310 int loads
= getloadavg (load_ave
, 3);
1314 error ("load-average not implemented for this operating system");
1318 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1323 Lisp_Object Vfeatures
;
1325 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1326 "Returns t if FEATURE is present in this Emacs.\n\
1327 Use this to conditionalize execution of lisp code based on the presence or\n\
1328 absence of emacs or environment extensions.\n\
1329 Use `provide' to declare that a feature is available.\n\
1330 This function looks at the value of the variable `features'.")
1332 Lisp_Object feature
;
1334 register Lisp_Object tem
;
1335 CHECK_SYMBOL (feature
, 0);
1336 tem
= Fmemq (feature
, Vfeatures
);
1337 return (NILP (tem
)) ? Qnil
: Qt
;
1340 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1341 "Announce that FEATURE is a feature of the current Emacs.")
1343 Lisp_Object feature
;
1345 register Lisp_Object tem
;
1346 CHECK_SYMBOL (feature
, 0);
1347 if (!NILP (Vautoload_queue
))
1348 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1349 tem
= Fmemq (feature
, Vfeatures
);
1351 Vfeatures
= Fcons (feature
, Vfeatures
);
1352 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1356 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1357 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1358 If FEATURE is not a member of the list `features', then the feature\n\
1359 is not loaded; so load the file FILENAME.\n\
1360 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1361 (feature
, file_name
)
1362 Lisp_Object feature
, file_name
;
1364 register Lisp_Object tem
;
1365 CHECK_SYMBOL (feature
, 0);
1366 tem
= Fmemq (feature
, Vfeatures
);
1367 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1370 int count
= specpdl_ptr
- specpdl
;
1372 /* Value saved here is to be restored into Vautoload_queue */
1373 record_unwind_protect (un_autoload
, Vautoload_queue
);
1374 Vautoload_queue
= Qt
;
1376 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1379 tem
= Fmemq (feature
, Vfeatures
);
1381 error ("Required feature %s was not provided",
1382 XSYMBOL (feature
)->name
->data
);
1384 /* Once loading finishes, don't undo it. */
1385 Vautoload_queue
= Qt
;
1386 feature
= unbind_to (count
, feature
);
1393 Qstring_lessp
= intern ("string-lessp");
1394 staticpro (&Qstring_lessp
);
1395 Qprovide
= intern ("provide");
1396 staticpro (&Qprovide
);
1397 Qrequire
= intern ("require");
1398 staticpro (&Qrequire
);
1399 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1400 staticpro (&Qyes_or_no_p_history
);
1402 DEFVAR_LISP ("features", &Vfeatures
,
1403 "A list of symbols which are the features of the executing emacs.\n\
1404 Used by `featurep' and `require', and altered by `provide'.");
1407 defsubr (&Sidentity
);
1410 defsubr (&Sstring_equal
);
1411 defsubr (&Sstring_lessp
);
1414 defsubr (&Svconcat
);
1415 defsubr (&Scopy_sequence
);
1416 defsubr (&Scopy_alist
);
1417 defsubr (&Ssubstring
);
1428 defsubr (&Snreverse
);
1429 defsubr (&Sreverse
);
1434 defsubr (&Sfillarray
);
1437 defsubr (&Smapconcat
);
1438 defsubr (&Sy_or_n_p
);
1439 defsubr (&Syes_or_no_p
);
1440 defsubr (&Sload_average
);
1441 defsubr (&Sfeaturep
);
1442 defsubr (&Srequire
);
1443 defsubr (&Sprovide
);