1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987 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 Lisp_Object Qstring_lessp
;
35 static Lisp_Object
internal_equal ();
37 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
38 "Return the argument unchanged.")
45 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
46 "Return a pseudo-random number.\n\
47 On most systems all integers representable in Lisp are equally likely.\n\
48 This is 24 bits' worth.\n\
49 With argument N, return random number in interval [0,N).\n\
50 With argument t, set the random number seed from the current time and pid.")
55 extern long random ();
60 srandom (getpid () + time (0));
62 if (XTYPE (arg
) == Lisp_Int
&& XINT (arg
) != 0)
64 /* Try to take our random number from the higher bits of VAL,
65 not the lower, since (says Gentzel) the low bits of `random'
66 are less random than the higher ones. */
67 val
&= 0xfffffff; /* Ensure positive. */
69 if (XINT (arg
) < 10000)
73 return make_number (val
);
76 /* Random data-structure functions */
78 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
79 "Return the length of vector, list or string SEQUENCE.\n\
80 A byte-code function object is also allowed.")
82 register Lisp_Object obj
;
84 register Lisp_Object tail
, val
;
88 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
89 || XTYPE (obj
) == Lisp_Compiled
)
90 return Farray_length (obj
);
93 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
109 obj
= wrong_type_argument (Qsequencep
, obj
);
114 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
115 "T if two strings have identical contents.\n\
116 Case is significant.\n\
117 Symbols are also allowed; their print names are used instead.")
119 register Lisp_Object s1
, s2
;
121 if (XTYPE (s1
) == Lisp_Symbol
)
122 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
123 if (XTYPE (s2
) == Lisp_Symbol
)
124 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
125 CHECK_STRING (s1
, 0);
126 CHECK_STRING (s2
, 1);
128 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
129 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
134 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
135 "T if first arg string is less than second in lexicographic order.\n\
136 Case is significant.\n\
137 Symbols are also allowed; their print names are used instead.")
139 register Lisp_Object s1
, s2
;
142 register unsigned char *p1
, *p2
;
145 if (XTYPE (s1
) == Lisp_Symbol
)
146 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
147 if (XTYPE (s2
) == Lisp_Symbol
)
148 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
149 CHECK_STRING (s1
, 0);
150 CHECK_STRING (s2
, 1);
152 p1
= XSTRING (s1
)->data
;
153 p2
= XSTRING (s2
)->data
;
154 end
= XSTRING (s1
)->size
;
155 if (end
> XSTRING (s2
)->size
)
156 end
= XSTRING (s2
)->size
;
158 for (i
= 0; i
< end
; i
++)
161 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
163 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
166 static Lisp_Object
concat ();
177 return concat (2, args
, Lisp_String
, 0);
179 return concat (2, &s1
, Lisp_String
, 0);
180 #endif /* NO_ARG_ARRAY */
183 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
184 "Concatenate all the arguments and make the result a list.\n\
185 The result is a list whose elements are the elements of all the arguments.\n\
186 Each argument may be a list, vector or string.\n\
187 The last argument is not copied if it is a list.")
192 return concat (nargs
, args
, Lisp_Cons
, 1);
195 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
196 "Concatenate all the arguments and make the result a string.\n\
197 The result is a string whose elements are the elements of all the arguments.\n\
198 Each argument may be a string, a list of numbers, or a vector of numbers.")
203 return concat (nargs
, args
, Lisp_String
, 0);
206 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
207 "Concatenate all the arguments and make the result a vector.\n\
208 The result is a vector whose elements are the elements of all the arguments.\n\
209 Each argument may be a list, vector or string.")
214 return concat (nargs
, args
, Lisp_Vector
, 0);
217 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
218 "Return a copy of a list, vector or string.\n\
219 The elements of a list or vector are not copied; they are shared\n\
224 if (NILP (arg
)) return arg
;
225 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
226 arg
= wrong_type_argument (Qsequencep
, arg
);
227 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
231 concat (nargs
, args
, target_type
, last_special
)
234 enum Lisp_Type target_type
;
239 register Lisp_Object tail
;
240 register Lisp_Object
this;
244 Lisp_Object last_tail
;
247 /* In append, the last arg isn't treated like the others */
248 if (last_special
&& nargs
> 0)
251 last_tail
= args
[nargs
];
256 for (argnum
= 0; argnum
< nargs
; argnum
++)
259 if (!(CONSP (this) || NILP (this)
260 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
261 || XTYPE (this) == Lisp_Compiled
))
263 if (XTYPE (this) == Lisp_Int
)
264 args
[argnum
] = Fint_to_string (this);
266 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
270 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
273 len
= Flength (this);
274 leni
+= XFASTINT (len
);
277 XFASTINT (len
) = leni
;
279 if (target_type
== Lisp_Cons
)
280 val
= Fmake_list (len
, Qnil
);
281 else if (target_type
== Lisp_Vector
)
282 val
= Fmake_vector (len
, Qnil
);
284 val
= Fmake_string (len
, len
);
286 /* In append, if all but last arg are nil, return last arg */
287 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
291 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
297 for (argnum
= 0; argnum
< nargs
; argnum
++)
301 register int thisindex
= 0;
305 thislen
= Flength (this), thisleni
= XINT (thislen
);
309 register Lisp_Object elt
;
311 /* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
312 if (NILP (this)) break;
314 elt
= Fcar (this), this = Fcdr (this);
317 if (thisindex
>= thisleni
) break;
318 if (XTYPE (this) == Lisp_String
)
319 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
321 elt
= XVECTOR (this)->contents
[thisindex
++];
324 /* Store into result */
327 XCONS (tail
)->car
= elt
;
329 tail
= XCONS (tail
)->cdr
;
331 else if (XTYPE (val
) == Lisp_Vector
)
332 XVECTOR (val
)->contents
[toindex
++] = elt
;
335 while (XTYPE (elt
) != Lisp_Int
)
336 elt
= wrong_type_argument (Qintegerp
, elt
);
338 #ifdef MASSC_REGISTER_BUG
339 /* Even removing all "register"s doesn't disable this bug!
340 Nothing simpler than this seems to work. */
341 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
344 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
351 XCONS (prev
)->cdr
= last_tail
;
356 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
357 "Return a copy of ALIST.\n\
358 This is an alist which represents the same mapping from objects to objects,\n\
359 but does not share the alist structure with ALIST.\n\
360 The objects mapped (cars and cdrs of elements of the alist)\n\
361 are shared, however.\n\
362 Elements of ALIST that are not conses are also shared.")
366 register Lisp_Object tem
;
368 CHECK_LIST (alist
, 0);
371 alist
= concat (1, &alist
, Lisp_Cons
, 0);
372 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
374 register Lisp_Object car
;
375 car
= XCONS (tem
)->car
;
378 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
383 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
384 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
385 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
386 If FROM or TO is negative, it counts from the end.")
389 register Lisp_Object from
, to
;
391 CHECK_STRING (string
, 0);
392 CHECK_NUMBER (from
, 1);
394 to
= Flength (string
);
396 CHECK_NUMBER (to
, 2);
399 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
401 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
402 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
403 && XINT (to
) <= XSTRING (string
)->size
))
404 args_out_of_range_3 (string
, from
, to
);
406 return make_string (XSTRING (string
)->data
+ XINT (from
),
407 XINT (to
) - XINT (from
));
410 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
411 "Take cdr N times on LIST, returns the result.")
414 register Lisp_Object list
;
419 for (i
= 0; i
< num
&& !NILP (list
); i
++)
427 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
428 "Return the Nth element of LIST.\n\
429 N counts from zero. If LIST is not that long, nil is returned.")
433 return Fcar (Fnthcdr (n
, list
));
436 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
437 "Return element of SEQUENCE at index N.")
439 register Lisp_Object seq
, n
;
444 if (XTYPE (seq
) == Lisp_Cons
|| NILP (seq
))
445 return Fcar (Fnthcdr (n
, seq
));
446 else if (XTYPE (seq
) == Lisp_String
447 || XTYPE (seq
) == Lisp_Vector
)
448 return Faref (seq
, n
);
450 seq
= wrong_type_argument (Qsequencep
, seq
);
454 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
455 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
456 The value is actually the tail of LIST whose car is ELT.")
458 register Lisp_Object elt
;
461 register Lisp_Object tail
;
462 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
464 register Lisp_Object tem
;
466 if (! NILP (Fequal (elt
, tem
)))
473 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
474 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
475 The value is actually the tail of LIST whose car is ELT.")
477 register Lisp_Object elt
;
480 register Lisp_Object tail
;
481 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
483 register Lisp_Object tem
;
485 if (EQ (elt
, tem
)) return tail
;
491 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
492 "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
493 The value is actually the element of LIST whose car is ELT.\n\
494 Elements of LIST that are not conses are ignored.")
496 register Lisp_Object key
;
499 register Lisp_Object tail
;
500 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
502 register Lisp_Object elt
, tem
;
504 if (!CONSP (elt
)) continue;
506 if (EQ (key
, tem
)) return elt
;
512 /* Like Fassq but never report an error and do not allow quits.
513 Use only on lists known never to be circular. */
516 assq_no_quit (key
, list
)
517 register Lisp_Object key
;
520 register Lisp_Object tail
;
521 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
523 register Lisp_Object elt
, tem
;
525 if (!CONSP (elt
)) continue;
527 if (EQ (key
, tem
)) return elt
;
532 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
533 "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
534 The value is actually the element of LIST whose car is ELT.")
536 register Lisp_Object key
;
539 register Lisp_Object tail
;
540 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
542 register Lisp_Object elt
, tem
;
544 if (!CONSP (elt
)) continue;
545 tem
= Fequal (Fcar (elt
), key
);
546 if (!NILP (tem
)) return elt
;
552 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
553 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
554 The value is actually the element of LIST whose cdr is ELT.")
556 register Lisp_Object key
;
559 register Lisp_Object tail
;
560 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
562 register Lisp_Object elt
, tem
;
564 if (!CONSP (elt
)) continue;
566 if (EQ (key
, tem
)) return elt
;
572 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
573 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
574 The modified LIST is returned. Comparison is done with `eq'.\n\
575 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
576 therefore, write `(setq foo (delq element foo))'\n\
577 to be sure of changing the value of `foo'.")
579 register Lisp_Object elt
;
582 register Lisp_Object tail
, prev
;
583 register Lisp_Object tem
;
595 Fsetcdr (prev
, Fcdr (tail
));
605 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
606 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
607 The modified LIST is returned. Comparison is done with `equal'.\n\
608 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
609 therefore, write `(setq foo (delete element foo))'\n\
610 to be sure of changing the value of `foo'.")
612 register Lisp_Object elt
;
615 register Lisp_Object tail
, prev
;
616 register Lisp_Object tem
;
623 if (Fequal (elt
, tem
))
628 Fsetcdr (prev
, Fcdr (tail
));
638 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
639 "Reverse LIST by modifying cdr pointers.\n\
640 Returns the beginning of the reversed list.")
644 register Lisp_Object prev
, tail
, next
;
646 if (NILP (list
)) return list
;
653 Fsetcdr (tail
, prev
);
660 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
661 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
662 See also the function `nreverse', which is used more often.")
667 register Lisp_Object
*vec
;
668 register Lisp_Object tail
;
671 length
= Flength (list
);
672 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
673 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
674 vec
[i
] = Fcar (tail
);
676 return Flist (XINT (length
), vec
);
679 Lisp_Object
merge ();
681 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
682 "Sort LIST, stably, comparing elements using PREDICATE.\n\
683 Returns the sorted list. LIST is modified by side effects.\n\
684 PREDICATE is called with two elements of LIST, and should return T\n\
685 if the first element is \"less\" than the second.")
687 Lisp_Object list
, pred
;
689 Lisp_Object front
, back
;
690 register Lisp_Object len
, tem
;
691 struct gcpro gcpro1
, gcpro2
;
695 len
= Flength (list
);
700 XSETINT (len
, (length
/ 2) - 1);
701 tem
= Fnthcdr (len
, list
);
705 GCPRO2 (front
, back
);
706 front
= Fsort (front
, pred
);
707 back
= Fsort (back
, pred
);
709 return merge (front
, back
, pred
);
713 merge (org_l1
, org_l2
, pred
)
714 Lisp_Object org_l1
, org_l2
;
718 register Lisp_Object tail
;
720 register Lisp_Object l1
, l2
;
721 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
728 /* It is sufficient to protect org_l1 and org_l2.
729 When l1 and l2 are updated, we copy the new values
730 back into the org_ vars. */
731 GCPRO4 (org_l1
, org_l2
, pred
, value
);
751 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
772 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
773 "Return the value of SYMBOL's PROPNAME property.\n\
774 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
777 register Lisp_Object prop
;
779 register Lisp_Object tail
;
780 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
782 register Lisp_Object tem
;
785 return Fcar (Fcdr (tail
));
790 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
791 "Store SYMBOL's PROPNAME property with value VALUE.\n\
792 It can be retrieved with `(get SYMBOL PROPNAME)'.")
795 register Lisp_Object prop
;
798 register Lisp_Object tail
, prev
;
801 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
803 register Lisp_Object tem
;
806 return Fsetcar (Fcdr (tail
), val
);
809 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
811 Fsetplist (sym
, newcell
);
813 Fsetcdr (Fcdr (prev
), newcell
);
817 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
818 "T if two Lisp objects have similar structure and contents.\n\
819 They must have the same data type.\n\
820 Conses are compared by comparing the cars and the cdrs.\n\
821 Vectors and strings are compared element by element.\n\
822 Numbers are compared by value. Symbols must match exactly.")
824 register Lisp_Object o1
, o2
;
826 return internal_equal (o1
, o2
, 0);
830 internal_equal (o1
, o2
, depth
)
831 register Lisp_Object o1
, o2
;
835 error ("Stack overflow in equal");
838 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
839 if (XINT (o1
) == XINT (o2
)) return Qt
;
840 if (XTYPE (o1
) == Lisp_Cons
)
843 v1
= Fequal (Fcar (o1
), Fcar (o2
), depth
+ 1);
846 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
849 if (XTYPE (o1
) == Lisp_Marker
)
851 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
852 && XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
)
855 if (XTYPE (o1
) == Lisp_Vector
)
858 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
860 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
862 Lisp_Object v
, v1
, v2
;
863 v1
= XVECTOR (o1
)->contents
[index
];
864 v2
= XVECTOR (o2
)->contents
[index
];
865 v
= Fequal (v1
, v2
, depth
+ 1);
866 if (NILP (v
)) return v
;
870 if (XTYPE (o1
) == Lisp_String
)
872 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
874 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
881 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
882 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
884 Lisp_Object array
, item
;
886 register int size
, index
, charval
;
888 if (XTYPE (array
) == Lisp_Vector
)
890 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
891 size
= XVECTOR (array
)->size
;
892 for (index
= 0; index
< size
; index
++)
895 else if (XTYPE (array
) == Lisp_String
)
897 register unsigned char *p
= XSTRING (array
)->data
;
898 CHECK_NUMBER (item
, 1);
899 charval
= XINT (item
);
900 size
= XSTRING (array
)->size
;
901 for (index
= 0; index
< size
; index
++)
906 array
= wrong_type_argument (Qarrayp
, array
);
921 return Fnconc (2, args
);
923 return Fnconc (2, &s1
);
924 #endif /* NO_ARG_ARRAY */
927 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
928 "Concatenate any number of lists by altering them.\n\
929 Only the last argument is not altered, and need not be a list.")
935 register Lisp_Object tail
, tem
, val
;
939 for (argnum
= 0; argnum
< nargs
; argnum
++)
942 if (NILP (tem
)) continue;
947 if (argnum
+ 1 == nargs
) break;
950 tem
= wrong_type_argument (Qlistp
, tem
);
959 tem
= args
[argnum
+ 1];
962 args
[argnum
+ 1] = tail
;
968 /* This is the guts of all mapping functions.
969 Apply fn to each element of seq, one by one,
970 storing the results into elements of vals, a C vector of Lisp_Objects.
971 leni is the length of vals, which should also be the length of seq. */
974 mapcar1 (leni
, vals
, fn
, seq
)
979 register Lisp_Object tail
;
982 struct gcpro gcpro1
, gcpro2
, gcpro3
;
984 /* Don't let vals contain any garbage when GC happens. */
985 for (i
= 0; i
< leni
; i
++)
988 GCPRO3 (dummy
, fn
, seq
);
991 /* We need not explicitly protect `tail' because it is used only on lists, and
992 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
994 if (XTYPE (seq
) == Lisp_Vector
)
996 for (i
= 0; i
< leni
; i
++)
998 dummy
= XVECTOR (seq
)->contents
[i
];
999 vals
[i
] = call1 (fn
, dummy
);
1002 else if (XTYPE (seq
) == Lisp_String
)
1004 for (i
= 0; i
< leni
; i
++)
1006 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1007 vals
[i
] = call1 (fn
, dummy
);
1010 else /* Must be a list, since Flength did not get an error */
1013 for (i
= 0; i
< leni
; i
++)
1015 vals
[i
] = call1 (fn
, Fcar (tail
));
1023 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1024 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1025 In between each pair of results, stick in SEP.\n\
1026 Thus, \" \" as SEP results in spaces between the values return by FN.")
1028 Lisp_Object fn
, seq
, sep
;
1033 register Lisp_Object
*args
;
1035 struct gcpro gcpro1
;
1037 len
= Flength (seq
);
1039 nargs
= leni
+ leni
- 1;
1040 if (nargs
< 0) return build_string ("");
1042 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1045 mapcar1 (leni
, args
, fn
, seq
);
1048 for (i
= leni
- 1; i
>= 0; i
--)
1049 args
[i
+ i
] = args
[i
];
1051 for (i
= 1; i
< nargs
; i
+= 2)
1054 return Fconcat (nargs
, args
);
1057 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1058 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1059 The result is a list just as long as SEQUENCE.\n\
1060 SEQUENCE may be a list, a vector or a string.")
1062 Lisp_Object fn
, seq
;
1064 register Lisp_Object len
;
1066 register Lisp_Object
*args
;
1068 len
= Flength (seq
);
1069 leni
= XFASTINT (len
);
1070 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1072 mapcar1 (leni
, args
, fn
, seq
);
1074 return Flist (leni
, args
);
1077 /* Anything that calls this function must protect from GC! */
1079 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1080 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1081 Takes one argument, which is the string to display to ask the question.\n\
1082 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1083 No confirmation of the answer is requested; a single character is enough.\n\
1084 Also accepts Space to mean yes, or Delete to mean no.")
1088 register Lisp_Object obj
;
1090 Lisp_Object xprompt
;
1091 Lisp_Object args
[2];
1092 int ocech
= cursor_in_echo_area
;
1093 struct gcpro gcpro1
, gcpro2
;
1095 CHECK_STRING (prompt
, 0);
1097 GCPRO2 (prompt
, xprompt
);
1101 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1102 cursor_in_echo_area
= 1;
1104 obj
= read_char (0);
1105 if (XTYPE (obj
) == Lisp_Int
)
1110 cursor_in_echo_area
= -1;
1111 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, ans
);
1112 cursor_in_echo_area
= ocech
;
1113 /* Accept a C-g or C-] (abort-recursive-edit) as quit requests. */
1114 if (ans
== 7 || ans
== '\035')
1118 ans
= DOWNCASE (ans
);
1119 if (ans
== 'y' || ans
== ' ')
1120 { ans
= 'y'; break; }
1121 if (ans
== 'n' || ans
== 127)
1126 if (EQ (xprompt
, prompt
))
1128 args
[0] = build_string ("Please answer y or n. ");
1130 xprompt
= Fconcat (2, args
);
1134 return (ans
== 'y' ? Qt
: Qnil
);
1137 /* This is how C code calls `yes-or-no-p' and allows the user
1140 Anything that calls this function must protect from GC! */
1143 do_yes_or_no_p (prompt
)
1146 return call1 (intern ("yes-or-no-p"), prompt
);
1149 /* Anything that calls this function must protect from GC! */
1151 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1152 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1153 Takes one argument, which is the string to display to ask the question.\n\
1154 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1155 The user must confirm the answer with RET,\n\
1156 and can edit it until it as been confirmed.")
1160 register Lisp_Object ans
;
1161 Lisp_Object args
[2];
1162 struct gcpro gcpro1
;
1164 CHECK_STRING (prompt
, 0);
1167 args
[1] = build_string ("(yes or no) ");
1168 prompt
= Fconcat (2, args
);
1173 ans
= Fdowncase (read_minibuf (Vminibuffer_local_map
,
1174 Qnil
, prompt
, Qnil
, 0));
1175 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1180 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1188 message ("Please answer yes or no.");
1189 Fsleep_for (make_number (2));
1194 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1195 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1196 Each of the three load averages is multiplied by 100,\n\
1197 then converted to integer.\n\
1198 If the 5-minute or 15-minute load averages are not available, return a\n\
1199 shortened list, containing only those averages which are available.")
1203 int loads
= getloadavg (load_ave
, 3);
1207 error ("load-average not implemented for this operating system");
1211 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1216 Lisp_Object Vfeatures
;
1218 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1219 "Returns t if FEATURE is present in this Emacs.\n\
1220 Use this to conditionalize execution of lisp code based on the presence or\n\
1221 absence of emacs or environment extensions.\n\
1222 Use `provide' to declare that a feature is available.\n\
1223 This function looks at the value of the variable `features'.")
1225 Lisp_Object feature
;
1227 register Lisp_Object tem
;
1228 CHECK_SYMBOL (feature
, 0);
1229 tem
= Fmemq (feature
, Vfeatures
);
1230 return (NILP (tem
)) ? Qnil
: Qt
;
1233 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1234 "Announce that FEATURE is a feature of the current Emacs.")
1236 Lisp_Object feature
;
1238 register Lisp_Object tem
;
1239 CHECK_SYMBOL (feature
, 0);
1240 if (!NILP (Vautoload_queue
))
1241 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1242 tem
= Fmemq (feature
, Vfeatures
);
1244 Vfeatures
= Fcons (feature
, Vfeatures
);
1248 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1249 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1250 If FEATURE is not a member of the list `features', then the feature\n\
1251 is not loaded; so load the file FILENAME.\n\
1252 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1253 (feature
, file_name
)
1254 Lisp_Object feature
, file_name
;
1256 register Lisp_Object tem
;
1257 CHECK_SYMBOL (feature
, 0);
1258 tem
= Fmemq (feature
, Vfeatures
);
1261 int count
= specpdl_ptr
- specpdl
;
1263 /* Value saved here is to be restored into Vautoload_queue */
1264 record_unwind_protect (un_autoload
, Vautoload_queue
);
1265 Vautoload_queue
= Qt
;
1267 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1270 tem
= Fmemq (feature
, Vfeatures
);
1272 error ("Required feature %s was not provided",
1273 XSYMBOL (feature
)->name
->data
);
1275 /* Once loading finishes, don't undo it. */
1276 Vautoload_queue
= Qt
;
1277 feature
= unbind_to (count
, feature
);
1284 Qstring_lessp
= intern ("string-lessp");
1285 staticpro (&Qstring_lessp
);
1287 DEFVAR_LISP ("features", &Vfeatures
,
1288 "A list of symbols which are the features of the executing emacs.\n\
1289 Used by `featurep' and `require', and altered by `provide'.");
1292 defsubr (&Sidentity
);
1295 defsubr (&Sstring_equal
);
1296 defsubr (&Sstring_lessp
);
1299 defsubr (&Svconcat
);
1300 defsubr (&Scopy_sequence
);
1301 defsubr (&Scopy_alist
);
1302 defsubr (&Ssubstring
);
1313 defsubr (&Snreverse
);
1314 defsubr (&Sreverse
);
1319 defsubr (&Sfillarray
);
1322 defsubr (&Smapconcat
);
1323 defsubr (&Sy_or_n_p
);
1324 defsubr (&Syes_or_no_p
);
1325 defsubr (&Sload_average
);
1326 defsubr (&Sfeaturep
);
1327 defsubr (&Srequire
);
1328 defsubr (&Sprovide
);