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 extern long random ();
63 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. */
70 val
&= 0xfffffff; /* Ensure positive. */
72 if (XINT (limit
) < 10000)
76 return make_number (val
);
79 /* Random data-structure functions */
81 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
82 "Return the length of vector, list or string SEQUENCE.\n\
83 A byte-code function object is also allowed.")
85 register Lisp_Object obj
;
87 register Lisp_Object tail
, val
;
91 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
92 || XTYPE (obj
) == Lisp_Compiled
)
93 return Farray_length (obj
);
96 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
112 obj
= wrong_type_argument (Qsequencep
, obj
);
117 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
118 "T if two strings have identical contents.\n\
119 Case is significant.\n\
120 Symbols are also allowed; their print names are used instead.")
122 register Lisp_Object s1
, s2
;
124 if (XTYPE (s1
) == Lisp_Symbol
)
125 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
126 if (XTYPE (s2
) == Lisp_Symbol
)
127 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
128 CHECK_STRING (s1
, 0);
129 CHECK_STRING (s2
, 1);
131 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
132 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
137 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
138 "T if first arg string is less than second in lexicographic order.\n\
139 Case is significant.\n\
140 Symbols are also allowed; their print names are used instead.")
142 register Lisp_Object s1
, s2
;
145 register unsigned char *p1
, *p2
;
148 if (XTYPE (s1
) == Lisp_Symbol
)
149 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
150 if (XTYPE (s2
) == Lisp_Symbol
)
151 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
152 CHECK_STRING (s1
, 0);
153 CHECK_STRING (s2
, 1);
155 p1
= XSTRING (s1
)->data
;
156 p2
= XSTRING (s2
)->data
;
157 end
= XSTRING (s1
)->size
;
158 if (end
> XSTRING (s2
)->size
)
159 end
= XSTRING (s2
)->size
;
161 for (i
= 0; i
< end
; i
++)
164 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
166 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
169 static Lisp_Object
concat ();
180 return concat (2, args
, Lisp_String
, 0);
182 return concat (2, &s1
, Lisp_String
, 0);
183 #endif /* NO_ARG_ARRAY */
186 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
187 "Concatenate all the arguments and make the result a list.\n\
188 The result is a list whose elements are the elements of all the arguments.\n\
189 Each argument may be a list, vector or string.\n\
190 The last argument is not copied, just used as the tail of the new list.")
195 return concat (nargs
, args
, Lisp_Cons
, 1);
198 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
199 "Concatenate all the arguments and make the result a string.\n\
200 The result is a string whose elements are the elements of all the arguments.\n\
201 Each argument may be a string, a list of characters (integers),\n\
202 or a vector of characters (integers).")
207 return concat (nargs
, args
, Lisp_String
, 0);
210 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
211 "Concatenate all the arguments and make the result a vector.\n\
212 The result is a vector whose elements are the elements of all the arguments.\n\
213 Each argument may be a list, vector or string.")
218 return concat (nargs
, args
, Lisp_Vector
, 0);
221 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
222 "Return a copy of a list, vector or string.\n\
223 The elements of a list or vector are not copied; they are shared\n\
228 if (NILP (arg
)) return arg
;
229 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
230 arg
= wrong_type_argument (Qsequencep
, arg
);
231 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
235 concat (nargs
, args
, target_type
, last_special
)
238 enum Lisp_Type target_type
;
243 register Lisp_Object tail
;
244 register Lisp_Object
this;
248 Lisp_Object last_tail
;
251 /* In append, the last arg isn't treated like the others */
252 if (last_special
&& nargs
> 0)
255 last_tail
= args
[nargs
];
260 for (argnum
= 0; argnum
< nargs
; argnum
++)
263 if (!(CONSP (this) || NILP (this)
264 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
265 || XTYPE (this) == Lisp_Compiled
))
267 if (XTYPE (this) == Lisp_Int
)
268 args
[argnum
] = Fnumber_to_string (this);
270 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
274 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
277 len
= Flength (this);
278 leni
+= XFASTINT (len
);
281 XFASTINT (len
) = leni
;
283 if (target_type
== Lisp_Cons
)
284 val
= Fmake_list (len
, Qnil
);
285 else if (target_type
== Lisp_Vector
)
286 val
= Fmake_vector (len
, Qnil
);
288 val
= Fmake_string (len
, len
);
290 /* In append, if all but last arg are nil, return last arg */
291 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
295 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
301 for (argnum
= 0; argnum
< nargs
; argnum
++)
305 register int thisindex
= 0;
309 thislen
= Flength (this), thisleni
= XINT (thislen
);
311 if (XTYPE (this) == Lisp_String
&& XTYPE (val
) == Lisp_String
312 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
314 copy_text_properties (make_number (0), thislen
, this,
315 make_number (toindex
), val
, Qnil
);
320 register Lisp_Object elt
;
322 /* Fetch next element of `this' arg into `elt', or break if
323 `this' is exhausted. */
324 if (NILP (this)) break;
326 elt
= Fcar (this), this = Fcdr (this);
329 if (thisindex
>= thisleni
) break;
330 if (XTYPE (this) == Lisp_String
)
331 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
333 elt
= XVECTOR (this)->contents
[thisindex
++];
336 /* Store into result */
339 XCONS (tail
)->car
= elt
;
341 tail
= XCONS (tail
)->cdr
;
343 else if (XTYPE (val
) == Lisp_Vector
)
344 XVECTOR (val
)->contents
[toindex
++] = elt
;
347 while (XTYPE (elt
) != Lisp_Int
)
348 elt
= wrong_type_argument (Qintegerp
, elt
);
350 #ifdef MASSC_REGISTER_BUG
351 /* Even removing all "register"s doesn't disable this bug!
352 Nothing simpler than this seems to work. */
353 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
356 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
363 XCONS (prev
)->cdr
= last_tail
;
368 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
369 "Return a copy of ALIST.\n\
370 This is an alist which represents the same mapping from objects to objects,\n\
371 but does not share the alist structure with ALIST.\n\
372 The objects mapped (cars and cdrs of elements of the alist)\n\
373 are shared, however.\n\
374 Elements of ALIST that are not conses are also shared.")
378 register Lisp_Object tem
;
380 CHECK_LIST (alist
, 0);
383 alist
= concat (1, &alist
, Lisp_Cons
, 0);
384 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
386 register Lisp_Object car
;
387 car
= XCONS (tem
)->car
;
390 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
395 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
396 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
397 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
398 If FROM or TO is negative, it counts from the end.")
401 register Lisp_Object from
, to
;
405 CHECK_STRING (string
, 0);
406 CHECK_NUMBER (from
, 1);
408 to
= Flength (string
);
410 CHECK_NUMBER (to
, 2);
413 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
415 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
416 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
417 && XINT (to
) <= XSTRING (string
)->size
))
418 args_out_of_range_3 (string
, from
, to
);
420 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
421 XINT (to
) - XINT (from
));
422 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
426 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
427 "Take cdr N times on LIST, returns the result.")
430 register Lisp_Object list
;
435 for (i
= 0; i
< num
&& !NILP (list
); i
++)
443 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
444 "Return the Nth element of LIST.\n\
445 N counts from zero. If LIST is not that long, nil is returned.")
449 return Fcar (Fnthcdr (n
, list
));
452 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
453 "Return element of SEQUENCE at index N.")
455 register Lisp_Object seq
, n
;
460 if (XTYPE (seq
) == Lisp_Cons
|| NILP (seq
))
461 return Fcar (Fnthcdr (n
, seq
));
462 else if (XTYPE (seq
) == Lisp_String
463 || XTYPE (seq
) == Lisp_Vector
)
464 return Faref (seq
, n
);
466 seq
= wrong_type_argument (Qsequencep
, seq
);
470 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
471 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
472 The value is actually the tail of LIST whose car is ELT.")
474 register Lisp_Object elt
;
477 register Lisp_Object tail
;
478 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
480 register Lisp_Object tem
;
482 if (! NILP (Fequal (elt
, tem
)))
489 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
490 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
491 The value is actually the tail of LIST whose car is ELT.")
493 register Lisp_Object elt
;
496 register Lisp_Object tail
;
497 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
499 register Lisp_Object tem
;
501 if (EQ (elt
, tem
)) return tail
;
507 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
508 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
509 The value is actually the element of LIST whose car is KEY.\n\
510 Elements of LIST that are not conses are ignored.")
512 register Lisp_Object key
;
515 register Lisp_Object tail
;
516 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
518 register Lisp_Object elt
, tem
;
520 if (!CONSP (elt
)) continue;
522 if (EQ (key
, tem
)) return elt
;
528 /* Like Fassq but never report an error and do not allow quits.
529 Use only on lists known never to be circular. */
532 assq_no_quit (key
, list
)
533 register Lisp_Object key
;
536 register Lisp_Object tail
;
537 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
539 register Lisp_Object elt
, tem
;
541 if (!CONSP (elt
)) continue;
543 if (EQ (key
, tem
)) return elt
;
548 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
549 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
550 The value is actually the element of LIST whose car is KEY.")
552 register Lisp_Object key
;
555 register Lisp_Object tail
;
556 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
558 register Lisp_Object elt
, tem
;
560 if (!CONSP (elt
)) continue;
561 tem
= Fequal (Fcar (elt
), key
);
562 if (!NILP (tem
)) return elt
;
568 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
569 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
570 The value is actually the element of LIST whose cdr is ELT.")
572 register Lisp_Object key
;
575 register Lisp_Object tail
;
576 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
578 register Lisp_Object elt
, tem
;
580 if (!CONSP (elt
)) continue;
582 if (EQ (key
, tem
)) return elt
;
588 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
589 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
590 The modified LIST is returned. Comparison is done with `eq'.\n\
591 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
592 therefore, write `(setq foo (delq element foo))'\n\
593 to be sure of changing the value of `foo'.")
595 register Lisp_Object elt
;
598 register Lisp_Object tail
, prev
;
599 register Lisp_Object tem
;
611 Fsetcdr (prev
, Fcdr (tail
));
621 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
622 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
623 The modified LIST is returned. Comparison is done with `equal'.\n\
624 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
625 therefore, write `(setq foo (delete element foo))'\n\
626 to be sure of changing the value of `foo'.")
628 register Lisp_Object elt
;
631 register Lisp_Object tail
, prev
;
632 register Lisp_Object tem
;
639 if (! NILP (Fequal (elt
, tem
)))
644 Fsetcdr (prev
, Fcdr (tail
));
654 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
655 "Reverse LIST by modifying cdr pointers.\n\
656 Returns the beginning of the reversed list.")
660 register Lisp_Object prev
, tail
, next
;
662 if (NILP (list
)) return list
;
669 Fsetcdr (tail
, prev
);
676 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
677 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
678 See also the function `nreverse', which is used more often.")
683 register Lisp_Object
*vec
;
684 register Lisp_Object tail
;
687 length
= Flength (list
);
688 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
689 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
690 vec
[i
] = Fcar (tail
);
692 return Flist (XINT (length
), vec
);
695 Lisp_Object
merge ();
697 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
698 "Sort LIST, stably, comparing elements using PREDICATE.\n\
699 Returns the sorted list. LIST is modified by side effects.\n\
700 PREDICATE is called with two elements of LIST, and should return T\n\
701 if the first element is \"less\" than the second.")
703 Lisp_Object list
, pred
;
705 Lisp_Object front
, back
;
706 register Lisp_Object len
, tem
;
707 struct gcpro gcpro1
, gcpro2
;
711 len
= Flength (list
);
716 XSETINT (len
, (length
/ 2) - 1);
717 tem
= Fnthcdr (len
, list
);
721 GCPRO2 (front
, back
);
722 front
= Fsort (front
, pred
);
723 back
= Fsort (back
, pred
);
725 return merge (front
, back
, pred
);
729 merge (org_l1
, org_l2
, pred
)
730 Lisp_Object org_l1
, org_l2
;
734 register Lisp_Object tail
;
736 register Lisp_Object l1
, l2
;
737 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
744 /* It is sufficient to protect org_l1 and org_l2.
745 When l1 and l2 are updated, we copy the new values
746 back into the org_ vars. */
747 GCPRO4 (org_l1
, org_l2
, pred
, value
);
767 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
788 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
789 "Return the value of SYMBOL's PROPNAME property.\n\
790 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
793 register Lisp_Object prop
;
795 register Lisp_Object tail
;
796 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
798 register Lisp_Object tem
;
801 return Fcar (Fcdr (tail
));
806 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
807 "Store SYMBOL's PROPNAME property with value VALUE.\n\
808 It can be retrieved with `(get SYMBOL PROPNAME)'.")
811 register Lisp_Object prop
;
814 register Lisp_Object tail
, prev
;
817 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
819 register Lisp_Object tem
;
822 return Fsetcar (Fcdr (tail
), val
);
825 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
827 Fsetplist (sym
, newcell
);
829 Fsetcdr (Fcdr (prev
), newcell
);
833 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
834 "T if two Lisp objects have similar structure and contents.\n\
835 They must have the same data type.\n\
836 Conses are compared by comparing the cars and the cdrs.\n\
837 Vectors and strings are compared element by element.\n\
838 Numbers are compared by value, but integers cannot equal floats.\n\
839 (Use `=' if you want integers and floats to be able to be equal.)\n\
840 Symbols must match exactly.")
842 register Lisp_Object o1
, o2
;
844 return internal_equal (o1
, o2
, 0);
848 internal_equal (o1
, o2
, depth
)
849 register Lisp_Object o1
, o2
;
853 error ("Stack overflow in equal");
856 if (EQ (o1
, o2
)) return Qt
;
857 #ifdef LISP_FLOAT_TYPE
858 if (FLOATP (o1
) && FLOATP (o2
))
859 return (extract_float (o1
) == extract_float (o2
)) ? Qt
: Qnil
;
861 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
862 if (XTYPE (o1
) == Lisp_Cons
863 || XTYPE (o1
) == Lisp_Overlay
)
866 v1
= internal_equal (Fcar (o1
), Fcar (o2
), depth
+ 1);
869 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
872 if (XTYPE (o1
) == Lisp_Marker
)
874 return ((XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
875 && (XMARKER (o1
)->buffer
== 0
876 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
))
879 if (XTYPE (o1
) == Lisp_Vector
880 || XTYPE (o1
) == Lisp_Compiled
)
883 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
885 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
887 Lisp_Object v
, v1
, v2
;
888 v1
= XVECTOR (o1
)->contents
[index
];
889 v2
= XVECTOR (o2
)->contents
[index
];
890 v
= internal_equal (v1
, v2
, depth
+ 1);
891 if (NILP (v
)) return v
;
895 if (XTYPE (o1
) == Lisp_String
)
897 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
899 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
906 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
907 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
909 Lisp_Object array
, item
;
911 register int size
, index
, charval
;
913 if (XTYPE (array
) == Lisp_Vector
)
915 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
916 size
= XVECTOR (array
)->size
;
917 for (index
= 0; index
< size
; index
++)
920 else if (XTYPE (array
) == Lisp_String
)
922 register unsigned char *p
= XSTRING (array
)->data
;
923 CHECK_NUMBER (item
, 1);
924 charval
= XINT (item
);
925 size
= XSTRING (array
)->size
;
926 for (index
= 0; index
< size
; index
++)
931 array
= wrong_type_argument (Qarrayp
, array
);
946 return Fnconc (2, args
);
948 return Fnconc (2, &s1
);
949 #endif /* NO_ARG_ARRAY */
952 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
953 "Concatenate any number of lists by altering them.\n\
954 Only the last argument is not altered, and need not be a list.")
960 register Lisp_Object tail
, tem
, val
;
964 for (argnum
= 0; argnum
< nargs
; argnum
++)
967 if (NILP (tem
)) continue;
972 if (argnum
+ 1 == nargs
) break;
975 tem
= wrong_type_argument (Qlistp
, tem
);
984 tem
= args
[argnum
+ 1];
987 args
[argnum
+ 1] = tail
;
993 /* This is the guts of all mapping functions.
994 Apply fn to each element of seq, one by one,
995 storing the results into elements of vals, a C vector of Lisp_Objects.
996 leni is the length of vals, which should also be the length of seq. */
999 mapcar1 (leni
, vals
, fn
, seq
)
1002 Lisp_Object fn
, seq
;
1004 register Lisp_Object tail
;
1007 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1009 /* Don't let vals contain any garbage when GC happens. */
1010 for (i
= 0; i
< leni
; i
++)
1013 GCPRO3 (dummy
, fn
, seq
);
1015 gcpro1
.nvars
= leni
;
1016 /* We need not explicitly protect `tail' because it is used only on lists, and
1017 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1019 if (XTYPE (seq
) == Lisp_Vector
)
1021 for (i
= 0; i
< leni
; i
++)
1023 dummy
= XVECTOR (seq
)->contents
[i
];
1024 vals
[i
] = call1 (fn
, dummy
);
1027 else if (XTYPE (seq
) == Lisp_String
)
1029 for (i
= 0; i
< leni
; i
++)
1031 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1032 vals
[i
] = call1 (fn
, dummy
);
1035 else /* Must be a list, since Flength did not get an error */
1038 for (i
= 0; i
< leni
; i
++)
1040 vals
[i
] = call1 (fn
, Fcar (tail
));
1048 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1049 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1050 In between each pair of results, stick in SEP.\n\
1051 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1053 Lisp_Object fn
, seq
, sep
;
1058 register Lisp_Object
*args
;
1060 struct gcpro gcpro1
;
1062 len
= Flength (seq
);
1064 nargs
= leni
+ leni
- 1;
1065 if (nargs
< 0) return build_string ("");
1067 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1070 mapcar1 (leni
, args
, fn
, seq
);
1073 for (i
= leni
- 1; i
>= 0; i
--)
1074 args
[i
+ i
] = args
[i
];
1076 for (i
= 1; i
< nargs
; i
+= 2)
1079 return Fconcat (nargs
, args
);
1082 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1083 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1084 The result is a list just as long as SEQUENCE.\n\
1085 SEQUENCE may be a list, a vector or a string.")
1087 Lisp_Object fn
, seq
;
1089 register Lisp_Object len
;
1091 register Lisp_Object
*args
;
1093 len
= Flength (seq
);
1094 leni
= XFASTINT (len
);
1095 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1097 mapcar1 (leni
, args
, fn
, seq
);
1099 return Flist (leni
, args
);
1102 /* Anything that calls this function must protect from GC! */
1104 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1105 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1106 Takes one argument, which is the string to display to ask the question.\n\
1107 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1108 No confirmation of the answer is requested; a single character is enough.\n\
1109 Also accepts Space to mean yes, or Delete to mean no.")
1113 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1114 register int answer
;
1115 Lisp_Object xprompt
;
1116 Lisp_Object args
[2];
1117 int ocech
= cursor_in_echo_area
;
1118 struct gcpro gcpro1
, gcpro2
;
1120 map
= Fsymbol_value (intern ("query-replace-map"));
1122 CHECK_STRING (prompt
, 0);
1124 GCPRO2 (prompt
, xprompt
);
1128 cursor_in_echo_area
= 1;
1129 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1131 obj
= read_filtered_event (1, 0, 0);
1132 cursor_in_echo_area
= 0;
1133 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1136 key
= Fmake_vector (make_number (1), obj
);
1137 def
= Flookup_key (map
, key
);
1138 answer_string
= Fsingle_key_description (obj
);
1140 if (EQ (def
, intern ("skip")))
1145 else if (EQ (def
, intern ("act")))
1150 else if (EQ (def
, intern ("recenter")))
1156 else if (EQ (def
, intern ("quit")))
1161 /* If we don't clear this, then the next call to read_char will
1162 return quit_char again, and we'll enter an infinite loop. */
1167 if (EQ (xprompt
, prompt
))
1169 args
[0] = build_string ("Please answer y or n. ");
1171 xprompt
= Fconcat (2, args
);
1176 if (! noninteractive
)
1178 cursor_in_echo_area
= -1;
1179 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1180 cursor_in_echo_area
= ocech
;
1183 return answer
? Qt
: Qnil
;
1186 /* This is how C code calls `yes-or-no-p' and allows the user
1189 Anything that calls this function must protect from GC! */
1192 do_yes_or_no_p (prompt
)
1195 return call1 (intern ("yes-or-no-p"), prompt
);
1198 /* Anything that calls this function must protect from GC! */
1200 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1201 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1202 Takes one argument, which is the string to display to ask the question.\n\
1203 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1204 The user must confirm the answer with RET,\n\
1205 and can edit it until it as been confirmed.")
1209 register Lisp_Object ans
;
1210 Lisp_Object args
[2];
1211 struct gcpro gcpro1
;
1213 CHECK_STRING (prompt
, 0);
1216 args
[1] = build_string ("(yes or no) ");
1217 prompt
= Fconcat (2, args
);
1222 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1223 Qyes_or_no_p_history
));
1224 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1229 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1237 message ("Please answer yes or no.");
1238 Fsleep_for (make_number (2), Qnil
);
1242 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1243 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1244 Each of the three load averages is multiplied by 100,\n\
1245 then converted to integer.\n\
1246 If the 5-minute or 15-minute load averages are not available, return a\n\
1247 shortened list, containing only those averages which are available.")
1251 int loads
= getloadavg (load_ave
, 3);
1255 error ("load-average not implemented for this operating system");
1259 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1264 Lisp_Object Vfeatures
;
1266 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1267 "Returns t if FEATURE is present in this Emacs.\n\
1268 Use this to conditionalize execution of lisp code based on the presence or\n\
1269 absence of emacs or environment extensions.\n\
1270 Use `provide' to declare that a feature is available.\n\
1271 This function looks at the value of the variable `features'.")
1273 Lisp_Object feature
;
1275 register Lisp_Object tem
;
1276 CHECK_SYMBOL (feature
, 0);
1277 tem
= Fmemq (feature
, Vfeatures
);
1278 return (NILP (tem
)) ? Qnil
: Qt
;
1281 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1282 "Announce that FEATURE is a feature of the current Emacs.")
1284 Lisp_Object feature
;
1286 register Lisp_Object tem
;
1287 CHECK_SYMBOL (feature
, 0);
1288 if (!NILP (Vautoload_queue
))
1289 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1290 tem
= Fmemq (feature
, Vfeatures
);
1292 Vfeatures
= Fcons (feature
, Vfeatures
);
1293 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1297 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1298 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1299 If FEATURE is not a member of the list `features', then the feature\n\
1300 is not loaded; so load the file FILENAME.\n\
1301 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1302 (feature
, file_name
)
1303 Lisp_Object feature
, file_name
;
1305 register Lisp_Object tem
;
1306 CHECK_SYMBOL (feature
, 0);
1307 tem
= Fmemq (feature
, Vfeatures
);
1308 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1311 int count
= specpdl_ptr
- specpdl
;
1313 /* Value saved here is to be restored into Vautoload_queue */
1314 record_unwind_protect (un_autoload
, Vautoload_queue
);
1315 Vautoload_queue
= Qt
;
1317 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1320 tem
= Fmemq (feature
, Vfeatures
);
1322 error ("Required feature %s was not provided",
1323 XSYMBOL (feature
)->name
->data
);
1325 /* Once loading finishes, don't undo it. */
1326 Vautoload_queue
= Qt
;
1327 feature
= unbind_to (count
, feature
);
1334 Qstring_lessp
= intern ("string-lessp");
1335 staticpro (&Qstring_lessp
);
1336 Qprovide
= intern ("provide");
1337 staticpro (&Qprovide
);
1338 Qrequire
= intern ("require");
1339 staticpro (&Qrequire
);
1340 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1341 staticpro (&Qyes_or_no_p_history
);
1343 DEFVAR_LISP ("features", &Vfeatures
,
1344 "A list of symbols which are the features of the executing emacs.\n\
1345 Used by `featurep' and `require', and altered by `provide'.");
1348 defsubr (&Sidentity
);
1351 defsubr (&Sstring_equal
);
1352 defsubr (&Sstring_lessp
);
1355 defsubr (&Svconcat
);
1356 defsubr (&Scopy_sequence
);
1357 defsubr (&Scopy_alist
);
1358 defsubr (&Ssubstring
);
1369 defsubr (&Snreverse
);
1370 defsubr (&Sreverse
);
1375 defsubr (&Sfillarray
);
1378 defsubr (&Smapconcat
);
1379 defsubr (&Sy_or_n_p
);
1380 defsubr (&Syes_or_no_p
);
1381 defsubr (&Sload_average
);
1382 defsubr (&Sfeaturep
);
1383 defsubr (&Srequire
);
1384 defsubr (&Sprovide
);