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
;
37 static Lisp_Object
internal_equal ();
39 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
40 "Return the argument unchanged.")
47 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
48 "Return a pseudo-random number.\n\
49 On most systems all integers representable in Lisp are equally likely.\n\
50 This is 24 bits' worth.\n\
51 With argument N, return random number in interval [0,N).\n\
52 With argument t, set the random number seed from the current time and pid.")
57 extern long random ();
62 srandom (getpid () + time (0));
64 if (XTYPE (limit
) == Lisp_Int
&& XINT (limit
) != 0)
66 /* Try to take our random number from the higher bits of VAL,
67 not the lower, since (says Gentzel) the low bits of `random'
68 are less random than the higher ones. */
69 val
&= 0xfffffff; /* Ensure positive. */
71 if (XINT (limit
) < 10000)
75 return make_number (val
);
78 /* Random data-structure functions */
80 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
81 "Return the length of vector, list or string SEQUENCE.\n\
82 A byte-code function object is also allowed.")
84 register Lisp_Object obj
;
86 register Lisp_Object tail
, val
;
90 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
91 || XTYPE (obj
) == Lisp_Compiled
)
92 return Farray_length (obj
);
95 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
111 obj
= wrong_type_argument (Qsequencep
, obj
);
116 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
117 "T if two strings have identical contents.\n\
118 Case is significant.\n\
119 Symbols are also allowed; their print names are used instead.")
121 register Lisp_Object s1
, s2
;
123 if (XTYPE (s1
) == Lisp_Symbol
)
124 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
125 if (XTYPE (s2
) == Lisp_Symbol
)
126 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
127 CHECK_STRING (s1
, 0);
128 CHECK_STRING (s2
, 1);
130 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
131 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
136 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
137 "T if first arg string is less than second in lexicographic order.\n\
138 Case is significant.\n\
139 Symbols are also allowed; their print names are used instead.")
141 register Lisp_Object s1
, s2
;
144 register unsigned char *p1
, *p2
;
147 if (XTYPE (s1
) == Lisp_Symbol
)
148 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
149 if (XTYPE (s2
) == Lisp_Symbol
)
150 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
151 CHECK_STRING (s1
, 0);
152 CHECK_STRING (s2
, 1);
154 p1
= XSTRING (s1
)->data
;
155 p2
= XSTRING (s2
)->data
;
156 end
= XSTRING (s1
)->size
;
157 if (end
> XSTRING (s2
)->size
)
158 end
= XSTRING (s2
)->size
;
160 for (i
= 0; i
< end
; i
++)
163 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
165 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
168 static Lisp_Object
concat ();
179 return concat (2, args
, Lisp_String
, 0);
181 return concat (2, &s1
, Lisp_String
, 0);
182 #endif /* NO_ARG_ARRAY */
185 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
186 "Concatenate all the arguments and make the result a list.\n\
187 The result is a list whose elements are the elements of all the arguments.\n\
188 Each argument may be a list, vector or string.\n\
189 The last argument is not copied, just used as the tail of the new list.")
194 return concat (nargs
, args
, Lisp_Cons
, 1);
197 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
198 "Concatenate all the arguments and make the result a string.\n\
199 The result is a string whose elements are the elements of all the arguments.\n\
200 Each argument may be a string, a list of numbers, or a vector of numbers.")
205 return concat (nargs
, args
, Lisp_String
, 0);
208 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
209 "Concatenate all the arguments and make the result a vector.\n\
210 The result is a vector whose elements are the elements of all the arguments.\n\
211 Each argument may be a list, vector or string.")
216 return concat (nargs
, args
, Lisp_Vector
, 0);
219 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
220 "Return a copy of a list, vector or string.\n\
221 The elements of a list or vector are not copied; they are shared\n\
226 if (NILP (arg
)) return arg
;
227 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
228 arg
= wrong_type_argument (Qsequencep
, arg
);
229 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
233 concat (nargs
, args
, target_type
, last_special
)
236 enum Lisp_Type target_type
;
241 register Lisp_Object tail
;
242 register Lisp_Object
this;
246 Lisp_Object last_tail
;
249 /* In append, the last arg isn't treated like the others */
250 if (last_special
&& nargs
> 0)
253 last_tail
= args
[nargs
];
258 for (argnum
= 0; argnum
< nargs
; argnum
++)
261 if (!(CONSP (this) || NILP (this)
262 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
263 || XTYPE (this) == Lisp_Compiled
))
265 if (XTYPE (this) == Lisp_Int
)
266 args
[argnum
] = Fnumber_to_string (this);
268 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
272 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
275 len
= Flength (this);
276 leni
+= XFASTINT (len
);
279 XFASTINT (len
) = leni
;
281 if (target_type
== Lisp_Cons
)
282 val
= Fmake_list (len
, Qnil
);
283 else if (target_type
== Lisp_Vector
)
284 val
= Fmake_vector (len
, Qnil
);
286 val
= Fmake_string (len
, len
);
288 /* In append, if all but last arg are nil, return last arg */
289 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
293 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
299 for (argnum
= 0; argnum
< nargs
; argnum
++)
303 register int thisindex
= 0;
307 thislen
= Flength (this), thisleni
= XINT (thislen
);
309 if (XTYPE (this) == Lisp_String
&& XTYPE (val
) == Lisp_String
310 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
312 copy_text_properties (make_number (0), thislen
, this,
313 make_number (toindex
), val
, Qnil
);
318 register Lisp_Object elt
;
320 /* Fetch next element of `this' arg into `elt', or break if
321 `this' is exhausted. */
322 if (NILP (this)) break;
324 elt
= Fcar (this), this = Fcdr (this);
327 if (thisindex
>= thisleni
) break;
328 if (XTYPE (this) == Lisp_String
)
329 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
331 elt
= XVECTOR (this)->contents
[thisindex
++];
334 /* Store into result */
337 XCONS (tail
)->car
= elt
;
339 tail
= XCONS (tail
)->cdr
;
341 else if (XTYPE (val
) == Lisp_Vector
)
342 XVECTOR (val
)->contents
[toindex
++] = elt
;
345 while (XTYPE (elt
) != Lisp_Int
)
346 elt
= wrong_type_argument (Qintegerp
, elt
);
348 #ifdef MASSC_REGISTER_BUG
349 /* Even removing all "register"s doesn't disable this bug!
350 Nothing simpler than this seems to work. */
351 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
354 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
361 XCONS (prev
)->cdr
= last_tail
;
366 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
367 "Return a copy of ALIST.\n\
368 This is an alist which represents the same mapping from objects to objects,\n\
369 but does not share the alist structure with ALIST.\n\
370 The objects mapped (cars and cdrs of elements of the alist)\n\
371 are shared, however.\n\
372 Elements of ALIST that are not conses are also shared.")
376 register Lisp_Object tem
;
378 CHECK_LIST (alist
, 0);
381 alist
= concat (1, &alist
, Lisp_Cons
, 0);
382 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
384 register Lisp_Object car
;
385 car
= XCONS (tem
)->car
;
388 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
393 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
394 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
395 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
396 If FROM or TO is negative, it counts from the end.")
399 register Lisp_Object from
, to
;
403 CHECK_STRING (string
, 0);
404 CHECK_NUMBER (from
, 1);
406 to
= Flength (string
);
408 CHECK_NUMBER (to
, 2);
411 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
413 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
414 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
415 && XINT (to
) <= XSTRING (string
)->size
))
416 args_out_of_range_3 (string
, from
, to
);
418 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
419 XINT (to
) - XINT (from
));
420 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
424 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
425 "Take cdr N times on LIST, returns the result.")
428 register Lisp_Object list
;
433 for (i
= 0; i
< num
&& !NILP (list
); i
++)
441 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
442 "Return the Nth element of LIST.\n\
443 N counts from zero. If LIST is not that long, nil is returned.")
447 return Fcar (Fnthcdr (n
, list
));
450 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
451 "Return element of SEQUENCE at index N.")
453 register Lisp_Object seq
, n
;
458 if (XTYPE (seq
) == Lisp_Cons
|| NILP (seq
))
459 return Fcar (Fnthcdr (n
, seq
));
460 else if (XTYPE (seq
) == Lisp_String
461 || XTYPE (seq
) == Lisp_Vector
)
462 return Faref (seq
, n
);
464 seq
= wrong_type_argument (Qsequencep
, seq
);
468 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
469 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
470 The value is actually the tail of LIST whose car is ELT.")
472 register Lisp_Object elt
;
475 register Lisp_Object tail
;
476 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
478 register Lisp_Object tem
;
480 if (! NILP (Fequal (elt
, tem
)))
487 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
488 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
489 The value is actually the tail of LIST whose car is ELT.")
491 register Lisp_Object elt
;
494 register Lisp_Object tail
;
495 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
497 register Lisp_Object tem
;
499 if (EQ (elt
, tem
)) return tail
;
505 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
506 "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
507 The value is actually the element of LIST whose car is ELT.\n\
508 Elements of LIST that are not conses are ignored.")
510 register Lisp_Object key
;
513 register Lisp_Object tail
;
514 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
516 register Lisp_Object elt
, tem
;
518 if (!CONSP (elt
)) continue;
520 if (EQ (key
, tem
)) return elt
;
526 /* Like Fassq but never report an error and do not allow quits.
527 Use only on lists known never to be circular. */
530 assq_no_quit (key
, list
)
531 register Lisp_Object key
;
534 register Lisp_Object tail
;
535 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
537 register Lisp_Object elt
, tem
;
539 if (!CONSP (elt
)) continue;
541 if (EQ (key
, tem
)) return elt
;
546 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
547 "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
548 The value is actually the element of LIST whose car is ELT.")
550 register Lisp_Object key
;
553 register Lisp_Object tail
;
554 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
556 register Lisp_Object elt
, tem
;
558 if (!CONSP (elt
)) continue;
559 tem
= Fequal (Fcar (elt
), key
);
560 if (!NILP (tem
)) return elt
;
566 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
567 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
568 The value is actually the element of LIST whose cdr is ELT.")
570 register Lisp_Object key
;
573 register Lisp_Object tail
;
574 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
576 register Lisp_Object elt
, tem
;
578 if (!CONSP (elt
)) continue;
580 if (EQ (key
, tem
)) return elt
;
586 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
587 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
588 The modified LIST is returned. Comparison is done with `eq'.\n\
589 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
590 therefore, write `(setq foo (delq element foo))'\n\
591 to be sure of changing the value of `foo'.")
593 register Lisp_Object elt
;
596 register Lisp_Object tail
, prev
;
597 register Lisp_Object tem
;
609 Fsetcdr (prev
, Fcdr (tail
));
619 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
620 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
621 The modified LIST is returned. Comparison is done with `equal'.\n\
622 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
623 therefore, write `(setq foo (delete element foo))'\n\
624 to be sure of changing the value of `foo'.")
626 register Lisp_Object elt
;
629 register Lisp_Object tail
, prev
;
630 register Lisp_Object tem
;
637 if (! NILP (Fequal (elt
, tem
)))
642 Fsetcdr (prev
, Fcdr (tail
));
652 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
653 "Reverse LIST by modifying cdr pointers.\n\
654 Returns the beginning of the reversed list.")
658 register Lisp_Object prev
, tail
, next
;
660 if (NILP (list
)) return list
;
667 Fsetcdr (tail
, prev
);
674 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
675 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
676 See also the function `nreverse', which is used more often.")
681 register Lisp_Object
*vec
;
682 register Lisp_Object tail
;
685 length
= Flength (list
);
686 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
687 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
688 vec
[i
] = Fcar (tail
);
690 return Flist (XINT (length
), vec
);
693 Lisp_Object
merge ();
695 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
696 "Sort LIST, stably, comparing elements using PREDICATE.\n\
697 Returns the sorted list. LIST is modified by side effects.\n\
698 PREDICATE is called with two elements of LIST, and should return T\n\
699 if the first element is \"less\" than the second.")
701 Lisp_Object list
, pred
;
703 Lisp_Object front
, back
;
704 register Lisp_Object len
, tem
;
705 struct gcpro gcpro1
, gcpro2
;
709 len
= Flength (list
);
714 XSETINT (len
, (length
/ 2) - 1);
715 tem
= Fnthcdr (len
, list
);
719 GCPRO2 (front
, back
);
720 front
= Fsort (front
, pred
);
721 back
= Fsort (back
, pred
);
723 return merge (front
, back
, pred
);
727 merge (org_l1
, org_l2
, pred
)
728 Lisp_Object org_l1
, org_l2
;
732 register Lisp_Object tail
;
734 register Lisp_Object l1
, l2
;
735 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
742 /* It is sufficient to protect org_l1 and org_l2.
743 When l1 and l2 are updated, we copy the new values
744 back into the org_ vars. */
745 GCPRO4 (org_l1
, org_l2
, pred
, value
);
765 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
786 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
787 "Return the value of SYMBOL's PROPNAME property.\n\
788 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
791 register Lisp_Object prop
;
793 register Lisp_Object tail
;
794 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
796 register Lisp_Object tem
;
799 return Fcar (Fcdr (tail
));
804 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
805 "Store SYMBOL's PROPNAME property with value VALUE.\n\
806 It can be retrieved with `(get SYMBOL PROPNAME)'.")
809 register Lisp_Object prop
;
812 register Lisp_Object tail
, prev
;
815 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
817 register Lisp_Object tem
;
820 return Fsetcar (Fcdr (tail
), val
);
823 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
825 Fsetplist (sym
, newcell
);
827 Fsetcdr (Fcdr (prev
), newcell
);
831 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
832 "T if two Lisp objects have similar structure and contents.\n\
833 They must have the same data type.\n\
834 Conses are compared by comparing the cars and the cdrs.\n\
835 Vectors and strings are compared element by element.\n\
836 Numbers are compared by value, but integers cannot equal floats.\n\
837 (Use `=' if you want integers and floats to be able to be equal.)\n\
838 Symbols must match exactly.")
840 register Lisp_Object o1
, o2
;
842 return internal_equal (o1
, o2
, 0);
846 internal_equal (o1
, o2
, depth
)
847 register Lisp_Object o1
, o2
;
851 error ("Stack overflow in equal");
854 if (EQ (o1
, o2
)) return Qt
;
855 #ifdef LISP_FLOAT_TYPE
856 if (FLOATP (o1
) && FLOATP (o2
))
857 return (extract_float (o1
) == extract_float (o2
)) ? Qt
: Qnil
;
859 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
860 if (XTYPE (o1
) == Lisp_Cons
861 || XTYPE (o1
) == Lisp_Overlay
)
864 v1
= internal_equal (Fcar (o1
), Fcar (o2
), depth
+ 1);
867 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
870 if (XTYPE (o1
) == Lisp_Marker
)
872 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
873 && XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
)
876 if (XTYPE (o1
) == Lisp_Vector
877 || XTYPE (o1
) == Lisp_Compiled
)
880 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
882 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
884 Lisp_Object v
, v1
, v2
;
885 v1
= XVECTOR (o1
)->contents
[index
];
886 v2
= XVECTOR (o2
)->contents
[index
];
887 v
= internal_equal (v1
, v2
, depth
+ 1);
888 if (NILP (v
)) return v
;
892 if (XTYPE (o1
) == Lisp_String
)
894 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
896 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
903 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
904 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
906 Lisp_Object array
, item
;
908 register int size
, index
, charval
;
910 if (XTYPE (array
) == Lisp_Vector
)
912 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
913 size
= XVECTOR (array
)->size
;
914 for (index
= 0; index
< size
; index
++)
917 else if (XTYPE (array
) == Lisp_String
)
919 register unsigned char *p
= XSTRING (array
)->data
;
920 CHECK_NUMBER (item
, 1);
921 charval
= XINT (item
);
922 size
= XSTRING (array
)->size
;
923 for (index
= 0; index
< size
; index
++)
928 array
= wrong_type_argument (Qarrayp
, array
);
943 return Fnconc (2, args
);
945 return Fnconc (2, &s1
);
946 #endif /* NO_ARG_ARRAY */
949 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
950 "Concatenate any number of lists by altering them.\n\
951 Only the last argument is not altered, and need not be a list.")
957 register Lisp_Object tail
, tem
, val
;
961 for (argnum
= 0; argnum
< nargs
; argnum
++)
964 if (NILP (tem
)) continue;
969 if (argnum
+ 1 == nargs
) break;
972 tem
= wrong_type_argument (Qlistp
, tem
);
981 tem
= args
[argnum
+ 1];
984 args
[argnum
+ 1] = tail
;
990 /* This is the guts of all mapping functions.
991 Apply fn to each element of seq, one by one,
992 storing the results into elements of vals, a C vector of Lisp_Objects.
993 leni is the length of vals, which should also be the length of seq. */
996 mapcar1 (leni
, vals
, fn
, seq
)
1001 register Lisp_Object tail
;
1004 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1006 /* Don't let vals contain any garbage when GC happens. */
1007 for (i
= 0; i
< leni
; i
++)
1010 GCPRO3 (dummy
, fn
, seq
);
1012 gcpro1
.nvars
= leni
;
1013 /* We need not explicitly protect `tail' because it is used only on lists, and
1014 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1016 if (XTYPE (seq
) == Lisp_Vector
)
1018 for (i
= 0; i
< leni
; i
++)
1020 dummy
= XVECTOR (seq
)->contents
[i
];
1021 vals
[i
] = call1 (fn
, dummy
);
1024 else if (XTYPE (seq
) == Lisp_String
)
1026 for (i
= 0; i
< leni
; i
++)
1028 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1029 vals
[i
] = call1 (fn
, dummy
);
1032 else /* Must be a list, since Flength did not get an error */
1035 for (i
= 0; i
< leni
; i
++)
1037 vals
[i
] = call1 (fn
, Fcar (tail
));
1045 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1046 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1047 In between each pair of results, stick in SEP.\n\
1048 Thus, \" \" as SEP results in spaces between the values return by FN.")
1050 Lisp_Object fn
, seq
, sep
;
1055 register Lisp_Object
*args
;
1057 struct gcpro gcpro1
;
1059 len
= Flength (seq
);
1061 nargs
= leni
+ leni
- 1;
1062 if (nargs
< 0) return build_string ("");
1064 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1067 mapcar1 (leni
, args
, fn
, seq
);
1070 for (i
= leni
- 1; i
>= 0; i
--)
1071 args
[i
+ i
] = args
[i
];
1073 for (i
= 1; i
< nargs
; i
+= 2)
1076 return Fconcat (nargs
, args
);
1079 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1080 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1081 The result is a list just as long as SEQUENCE.\n\
1082 SEQUENCE may be a list, a vector or a string.")
1084 Lisp_Object fn
, seq
;
1086 register Lisp_Object len
;
1088 register Lisp_Object
*args
;
1090 len
= Flength (seq
);
1091 leni
= XFASTINT (len
);
1092 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1094 mapcar1 (leni
, args
, fn
, seq
);
1096 return Flist (leni
, args
);
1099 /* Anything that calls this function must protect from GC! */
1101 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1102 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1103 Takes one argument, which is the string to display to ask the question.\n\
1104 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1105 No confirmation of the answer is requested; a single character is enough.\n\
1106 Also accepts Space to mean yes, or Delete to mean no.")
1110 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1111 register int answer
;
1112 Lisp_Object xprompt
;
1113 Lisp_Object args
[2];
1114 int ocech
= cursor_in_echo_area
;
1115 struct gcpro gcpro1
, gcpro2
;
1117 map
= Fsymbol_value (intern ("query-replace-map"));
1119 CHECK_STRING (prompt
, 0);
1121 GCPRO2 (prompt
, xprompt
);
1125 cursor_in_echo_area
= 1;
1126 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1128 obj
= read_filtered_event (1, 0, 0);
1129 cursor_in_echo_area
= 0;
1130 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1133 key
= Fmake_vector (make_number (1), obj
);
1134 def
= Flookup_key (map
, key
);
1135 answer_string
= Fsingle_key_description (obj
);
1137 if (EQ (def
, intern ("skip")))
1142 else if (EQ (def
, intern ("act")))
1147 else if (EQ (def
, intern ("recenter")))
1153 else if (EQ (def
, intern ("quit")))
1158 /* If we don't clear this, then the next call to read_char will
1159 return quit_char again, and we'll enter an infinite loop. */
1164 if (EQ (xprompt
, prompt
))
1166 args
[0] = build_string ("Please answer y or n. ");
1168 xprompt
= Fconcat (2, args
);
1173 if (! noninteractive
)
1175 cursor_in_echo_area
= -1;
1176 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1177 cursor_in_echo_area
= ocech
;
1180 return answer
? Qt
: Qnil
;
1183 /* This is how C code calls `yes-or-no-p' and allows the user
1186 Anything that calls this function must protect from GC! */
1189 do_yes_or_no_p (prompt
)
1192 return call1 (intern ("yes-or-no-p"), prompt
);
1195 /* Anything that calls this function must protect from GC! */
1197 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1198 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1199 Takes one argument, which is the string to display to ask the question.\n\
1200 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1201 The user must confirm the answer with RET,\n\
1202 and can edit it until it as been confirmed.")
1206 register Lisp_Object ans
;
1207 Lisp_Object args
[2];
1208 struct gcpro gcpro1
;
1210 CHECK_STRING (prompt
, 0);
1213 args
[1] = build_string ("(yes or no) ");
1214 prompt
= Fconcat (2, args
);
1219 ans
= Fdowncase (Fread_string (prompt
, Qnil
));
1220 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1225 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1233 message ("Please answer yes or no.");
1234 Fsleep_for (make_number (2), Qnil
);
1238 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1239 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1240 Each of the three load averages is multiplied by 100,\n\
1241 then converted to integer.\n\
1242 If the 5-minute or 15-minute load averages are not available, return a\n\
1243 shortened list, containing only those averages which are available.")
1247 int loads
= getloadavg (load_ave
, 3);
1251 error ("load-average not implemented for this operating system");
1255 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1260 Lisp_Object Vfeatures
;
1262 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1263 "Returns t if FEATURE is present in this Emacs.\n\
1264 Use this to conditionalize execution of lisp code based on the presence or\n\
1265 absence of emacs or environment extensions.\n\
1266 Use `provide' to declare that a feature is available.\n\
1267 This function looks at the value of the variable `features'.")
1269 Lisp_Object feature
;
1271 register Lisp_Object tem
;
1272 CHECK_SYMBOL (feature
, 0);
1273 tem
= Fmemq (feature
, Vfeatures
);
1274 return (NILP (tem
)) ? Qnil
: Qt
;
1277 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1278 "Announce that FEATURE is a feature of the current Emacs.")
1280 Lisp_Object feature
;
1282 register Lisp_Object tem
;
1283 CHECK_SYMBOL (feature
, 0);
1284 if (!NILP (Vautoload_queue
))
1285 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1286 tem
= Fmemq (feature
, Vfeatures
);
1288 Vfeatures
= Fcons (feature
, Vfeatures
);
1289 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1293 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1294 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1295 If FEATURE is not a member of the list `features', then the feature\n\
1296 is not loaded; so load the file FILENAME.\n\
1297 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1298 (feature
, file_name
)
1299 Lisp_Object feature
, file_name
;
1301 register Lisp_Object tem
;
1302 CHECK_SYMBOL (feature
, 0);
1303 tem
= Fmemq (feature
, Vfeatures
);
1304 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1307 int count
= specpdl_ptr
- specpdl
;
1309 /* Value saved here is to be restored into Vautoload_queue */
1310 record_unwind_protect (un_autoload
, Vautoload_queue
);
1311 Vautoload_queue
= Qt
;
1313 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1316 tem
= Fmemq (feature
, Vfeatures
);
1318 error ("Required feature %s was not provided",
1319 XSYMBOL (feature
)->name
->data
);
1321 /* Once loading finishes, don't undo it. */
1322 Vautoload_queue
= Qt
;
1323 feature
= unbind_to (count
, feature
);
1330 Qstring_lessp
= intern ("string-lessp");
1331 staticpro (&Qstring_lessp
);
1332 Qprovide
= intern ("provide");
1333 staticpro (&Qprovide
);
1334 Qrequire
= intern ("require");
1335 staticpro (&Qrequire
);
1337 DEFVAR_LISP ("features", &Vfeatures
,
1338 "A list of symbols which are the features of the executing emacs.\n\
1339 Used by `featurep' and `require', and altered by `provide'.");
1342 defsubr (&Sidentity
);
1345 defsubr (&Sstring_equal
);
1346 defsubr (&Sstring_lessp
);
1349 defsubr (&Svconcat
);
1350 defsubr (&Scopy_sequence
);
1351 defsubr (&Scopy_alist
);
1352 defsubr (&Ssubstring
);
1363 defsubr (&Snreverse
);
1364 defsubr (&Sreverse
);
1369 defsubr (&Sfillarray
);
1372 defsubr (&Smapconcat
);
1373 defsubr (&Sy_or_n_p
);
1374 defsubr (&Syes_or_no_p
);
1375 defsubr (&Sload_average
);
1376 defsubr (&Sfeaturep
);
1377 defsubr (&Srequire
);
1378 defsubr (&Sprovide
);