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 int 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
;
105 XSETFASTINT (val
, XSTRING (obj
)->size
);
106 else if (VECTORP (obj
) || COMPILEDP (obj
))
107 XSETFASTINT (val
, XVECTOR (obj
)->size
);
108 else if (CONSP (obj
))
110 for (i
= 0, tail
= obj
; !NILP (tail
); i
++)
116 XSETFASTINT (val
, i
);
119 XSETFASTINT (val
, 0);
122 obj
= wrong_type_argument (Qsequencep
, obj
);
128 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
129 "T if two strings have identical contents.\n\
130 Case is significant, but text properties are ignored.\n\
131 Symbols are also allowed; their print names are used instead.")
133 register Lisp_Object s1
, s2
;
136 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
138 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
139 CHECK_STRING (s1
, 0);
140 CHECK_STRING (s2
, 1);
142 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
143 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
148 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
149 "T if first arg string is less than second in lexicographic order.\n\
150 Case is significant.\n\
151 Symbols are also allowed; their print names are used instead.")
153 register Lisp_Object s1
, s2
;
156 register unsigned char *p1
, *p2
;
160 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
162 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
163 CHECK_STRING (s1
, 0);
164 CHECK_STRING (s2
, 1);
166 p1
= XSTRING (s1
)->data
;
167 p2
= XSTRING (s2
)->data
;
168 end
= XSTRING (s1
)->size
;
169 if (end
> XSTRING (s2
)->size
)
170 end
= XSTRING (s2
)->size
;
172 for (i
= 0; i
< end
; i
++)
175 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
177 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
180 static Lisp_Object
concat ();
191 return concat (2, args
, Lisp_String
, 0);
193 return concat (2, &s1
, Lisp_String
, 0);
194 #endif /* NO_ARG_ARRAY */
200 Lisp_Object s1
, s2
, s3
;
207 return concat (3, args
, Lisp_String
, 0);
209 return concat (3, &s1
, Lisp_String
, 0);
210 #endif /* NO_ARG_ARRAY */
213 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
214 "Concatenate all the arguments and make the result a list.\n\
215 The result is a list whose elements are the elements of all the arguments.\n\
216 Each argument may be a list, vector or string.\n\
217 The last argument is not copied, just used as the tail of the new list.")
222 return concat (nargs
, args
, Lisp_Cons
, 1);
225 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
226 "Concatenate all the arguments and make the result a string.\n\
227 The result is a string whose elements are the elements of all the arguments.\n\
228 Each argument may be a string, a list of characters (integers),\n\
229 or a vector of characters (integers).")
234 return concat (nargs
, args
, Lisp_String
, 0);
237 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
238 "Concatenate all the arguments and make the result a vector.\n\
239 The result is a vector whose elements are the elements of all the arguments.\n\
240 Each argument may be a list, vector or string.")
245 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
248 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
249 "Return a copy of a list, vector or string.\n\
250 The elements of a list or vector are not copied; they are shared\n\
255 if (NILP (arg
)) return arg
;
256 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
257 arg
= wrong_type_argument (Qsequencep
, arg
);
258 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
262 concat (nargs
, args
, target_type
, last_special
)
265 enum Lisp_Type target_type
;
270 register Lisp_Object tail
;
271 register Lisp_Object
this;
275 Lisp_Object last_tail
;
278 /* In append, the last arg isn't treated like the others */
279 if (last_special
&& nargs
> 0)
282 last_tail
= args
[nargs
];
287 for (argnum
= 0; argnum
< nargs
; argnum
++)
290 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
291 || COMPILEDP (this)))
294 args
[argnum
] = Fnumber_to_string (this);
296 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
300 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
303 len
= Flength (this);
304 leni
+= XFASTINT (len
);
307 XSETFASTINT (len
, leni
);
309 if (target_type
== Lisp_Cons
)
310 val
= Fmake_list (len
, Qnil
);
311 else if (target_type
== Lisp_Vectorlike
)
312 val
= Fmake_vector (len
, Qnil
);
314 val
= Fmake_string (len
, len
);
316 /* In append, if all but last arg are nil, return last arg */
317 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
321 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
327 for (argnum
= 0; argnum
< nargs
; argnum
++)
331 register int thisindex
= 0;
335 thislen
= Flength (this), thisleni
= XINT (thislen
);
337 if (STRINGP (this) && STRINGP (val
)
338 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
340 copy_text_properties (make_number (0), thislen
, this,
341 make_number (toindex
), val
, Qnil
);
346 register Lisp_Object elt
;
348 /* Fetch next element of `this' arg into `elt', or break if
349 `this' is exhausted. */
350 if (NILP (this)) break;
352 elt
= Fcar (this), this = Fcdr (this);
355 if (thisindex
>= thisleni
) break;
357 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
359 elt
= XVECTOR (this)->contents
[thisindex
++];
362 /* Store into result */
365 XCONS (tail
)->car
= elt
;
367 tail
= XCONS (tail
)->cdr
;
369 else if (VECTORP (val
))
370 XVECTOR (val
)->contents
[toindex
++] = elt
;
373 while (!INTEGERP (elt
))
374 elt
= wrong_type_argument (Qintegerp
, elt
);
376 #ifdef MASSC_REGISTER_BUG
377 /* Even removing all "register"s doesn't disable this bug!
378 Nothing simpler than this seems to work. */
379 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
382 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
389 XCONS (prev
)->cdr
= last_tail
;
394 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
395 "Return a copy of ALIST.\n\
396 This is an alist which represents the same mapping from objects to objects,\n\
397 but does not share the alist structure with ALIST.\n\
398 The objects mapped (cars and cdrs of elements of the alist)\n\
399 are shared, however.\n\
400 Elements of ALIST that are not conses are also shared.")
404 register Lisp_Object tem
;
406 CHECK_LIST (alist
, 0);
409 alist
= concat (1, &alist
, Lisp_Cons
, 0);
410 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
412 register Lisp_Object car
;
413 car
= XCONS (tem
)->car
;
416 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
421 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
422 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
423 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
424 If FROM or TO is negative, it counts from the end.")
427 register Lisp_Object from
, to
;
431 CHECK_STRING (string
, 0);
432 CHECK_NUMBER (from
, 1);
434 to
= Flength (string
);
436 CHECK_NUMBER (to
, 2);
439 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
441 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
442 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
443 && XINT (to
) <= XSTRING (string
)->size
))
444 args_out_of_range_3 (string
, from
, to
);
446 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
447 XINT (to
) - XINT (from
));
448 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
452 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
453 "Take cdr N times on LIST, returns the result.")
456 register Lisp_Object list
;
461 for (i
= 0; i
< num
&& !NILP (list
); i
++)
469 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
470 "Return the Nth element of LIST.\n\
471 N counts from zero. If LIST is not that long, nil is returned.")
475 return Fcar (Fnthcdr (n
, list
));
478 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
479 "Return element of SEQUENCE at index N.")
481 register Lisp_Object seq
, n
;
486 if (CONSP (seq
) || NILP (seq
))
487 return Fcar (Fnthcdr (n
, seq
));
488 else if (STRINGP (seq
) || VECTORP (seq
))
489 return Faref (seq
, n
);
491 seq
= wrong_type_argument (Qsequencep
, seq
);
495 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
496 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
497 The value is actually the tail of LIST whose car is ELT.")
499 register Lisp_Object elt
;
502 register Lisp_Object tail
;
503 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
505 register Lisp_Object tem
;
507 if (! NILP (Fequal (elt
, tem
)))
514 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
515 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
516 The value is actually the tail of LIST whose car is ELT.")
518 register Lisp_Object elt
;
521 register Lisp_Object tail
;
522 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
524 register Lisp_Object tem
;
526 if (EQ (elt
, tem
)) return tail
;
532 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
533 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
534 The value is actually the element of LIST whose car is KEY.\n\
535 Elements of LIST that are not conses are ignored.")
537 register Lisp_Object key
;
540 register Lisp_Object tail
;
541 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
543 register Lisp_Object elt
, tem
;
545 if (!CONSP (elt
)) continue;
547 if (EQ (key
, tem
)) return elt
;
553 /* Like Fassq but never report an error and do not allow quits.
554 Use only on lists known never to be circular. */
557 assq_no_quit (key
, list
)
558 register Lisp_Object key
;
561 register Lisp_Object tail
;
562 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
564 register Lisp_Object elt
, tem
;
566 if (!CONSP (elt
)) continue;
568 if (EQ (key
, tem
)) return elt
;
573 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
574 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
575 The value is actually the element of LIST whose car is KEY.")
577 register Lisp_Object key
;
580 register Lisp_Object tail
;
581 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
583 register Lisp_Object elt
, tem
;
585 if (!CONSP (elt
)) continue;
586 tem
= Fequal (Fcar (elt
), key
);
587 if (!NILP (tem
)) return elt
;
593 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
594 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
595 The value is actually the element of LIST whose cdr is ELT.")
597 register Lisp_Object key
;
600 register Lisp_Object tail
;
601 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
603 register Lisp_Object elt
, tem
;
605 if (!CONSP (elt
)) continue;
607 if (EQ (key
, tem
)) return elt
;
613 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
614 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
615 The modified LIST is returned. Comparison is done with `eq'.\n\
616 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
617 therefore, write `(setq foo (delq element foo))'\n\
618 to be sure of changing the value of `foo'.")
620 register Lisp_Object elt
;
623 register Lisp_Object tail
, prev
;
624 register Lisp_Object tem
;
636 Fsetcdr (prev
, Fcdr (tail
));
646 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
647 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
648 The modified LIST is returned. Comparison is done with `equal'.\n\
649 If the first member of LIST is ELT, deleting it is not a side effect;\n\
650 it is simply using a different list.\n\
651 Therefore, write `(setq foo (delete element foo))'\n\
652 to be sure of changing the value of `foo'.")
654 register Lisp_Object elt
;
657 register Lisp_Object tail
, prev
;
658 register Lisp_Object tem
;
665 if (! NILP (Fequal (elt
, tem
)))
670 Fsetcdr (prev
, Fcdr (tail
));
680 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
681 "Reverse LIST by modifying cdr pointers.\n\
682 Returns the beginning of the reversed list.")
686 register Lisp_Object prev
, tail
, next
;
688 if (NILP (list
)) return list
;
695 Fsetcdr (tail
, prev
);
702 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
703 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
704 See also the function `nreverse', which is used more often.")
709 register Lisp_Object
*vec
;
710 register Lisp_Object tail
;
713 length
= Flength (list
);
714 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
715 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
716 vec
[i
] = Fcar (tail
);
718 return Flist (XINT (length
), vec
);
721 Lisp_Object
merge ();
723 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
724 "Sort LIST, stably, comparing elements using PREDICATE.\n\
725 Returns the sorted list. LIST is modified by side effects.\n\
726 PREDICATE is called with two elements of LIST, and should return T\n\
727 if the first element is \"less\" than the second.")
729 Lisp_Object list
, pred
;
731 Lisp_Object front
, back
;
732 register Lisp_Object len
, tem
;
733 struct gcpro gcpro1
, gcpro2
;
737 len
= Flength (list
);
742 XSETINT (len
, (length
/ 2) - 1);
743 tem
= Fnthcdr (len
, list
);
747 GCPRO2 (front
, back
);
748 front
= Fsort (front
, pred
);
749 back
= Fsort (back
, pred
);
751 return merge (front
, back
, pred
);
755 merge (org_l1
, org_l2
, pred
)
756 Lisp_Object org_l1
, org_l2
;
760 register Lisp_Object tail
;
762 register Lisp_Object l1
, l2
;
763 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
770 /* It is sufficient to protect org_l1 and org_l2.
771 When l1 and l2 are updated, we copy the new values
772 back into the org_ vars. */
773 GCPRO4 (org_l1
, org_l2
, pred
, value
);
793 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
814 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
815 "Return the value of SYMBOL's PROPNAME property.\n\
816 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
819 register Lisp_Object prop
;
821 register Lisp_Object tail
;
822 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
824 register Lisp_Object tem
;
827 return Fcar (Fcdr (tail
));
832 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
833 "Store SYMBOL's PROPNAME property with value VALUE.\n\
834 It can be retrieved with `(get SYMBOL PROPNAME)'.")
837 register Lisp_Object prop
;
840 register Lisp_Object tail
, prev
;
843 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
845 register Lisp_Object tem
;
848 return Fsetcar (Fcdr (tail
), val
);
851 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
853 Fsetplist (sym
, newcell
);
855 Fsetcdr (Fcdr (prev
), newcell
);
859 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
860 "T if two Lisp objects have similar structure and contents.\n\
861 They must have the same data type.\n\
862 Conses are compared by comparing the cars and the cdrs.\n\
863 Vectors and strings are compared element by element.\n\
864 Numbers are compared by value, but integers cannot equal floats.\n\
865 (Use `=' if you want integers and floats to be able to be equal.)\n\
866 Symbols must match exactly.")
868 register Lisp_Object o1
, o2
;
870 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
874 internal_equal (o1
, o2
, depth
)
875 register Lisp_Object o1
, o2
;
879 error ("Stack overflow in equal");
882 if (EQ (o1
, o2
)) return 1;
883 #ifdef LISP_FLOAT_TYPE
884 if (FLOATP (o1
) && FLOATP (o2
))
885 return (extract_float (o1
) == extract_float (o2
));
887 if (XTYPE (o1
) != XTYPE (o2
)) return 0;
888 if (MISCP (o1
) && XMISC (o1
)->type
!= XMISC (o2
)->type
) return 0;
891 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
893 o1
= XCONS (o1
)->cdr
;
894 o2
= XCONS (o2
)->cdr
;
899 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
), depth
+ 1)
900 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
), depth
+ 1))
902 o1
= XOVERLAY (o1
)->plist
;
903 o2
= XOVERLAY (o2
)->plist
;
908 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
909 && (XMARKER (o1
)->buffer
== 0
910 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
912 if (VECTORP (o1
) || COMPILEDP (o1
))
915 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
917 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
920 v1
= XVECTOR (o1
)->contents
[index
];
921 v2
= XVECTOR (o2
)->contents
[index
];
922 if (!internal_equal (v1
, v2
, depth
+ 1))
929 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
931 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
933 #ifdef USE_TEXT_PROPERTIES
934 /* If the strings have intervals, verify they match;
935 if not, they are unequal. */
936 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
937 && ! compare_string_intervals (o1
, o2
))
945 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
946 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
948 Lisp_Object array
, item
;
950 register int size
, index
, charval
;
954 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
955 size
= XVECTOR (array
)->size
;
956 for (index
= 0; index
< size
; index
++)
959 else if (STRINGP (array
))
961 register unsigned char *p
= XSTRING (array
)->data
;
962 CHECK_NUMBER (item
, 1);
963 charval
= XINT (item
);
964 size
= XSTRING (array
)->size
;
965 for (index
= 0; index
< size
; index
++)
970 array
= wrong_type_argument (Qarrayp
, array
);
985 return Fnconc (2, args
);
987 return Fnconc (2, &s1
);
988 #endif /* NO_ARG_ARRAY */
991 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
992 "Concatenate any number of lists by altering them.\n\
993 Only the last argument is not altered, and need not be a list.")
999 register Lisp_Object tail
, tem
, val
;
1003 for (argnum
= 0; argnum
< nargs
; argnum
++)
1006 if (NILP (tem
)) continue;
1011 if (argnum
+ 1 == nargs
) break;
1014 tem
= wrong_type_argument (Qlistp
, tem
);
1023 tem
= args
[argnum
+ 1];
1024 Fsetcdr (tail
, tem
);
1026 args
[argnum
+ 1] = tail
;
1032 /* This is the guts of all mapping functions.
1033 Apply fn to each element of seq, one by one,
1034 storing the results into elements of vals, a C vector of Lisp_Objects.
1035 leni is the length of vals, which should also be the length of seq. */
1038 mapcar1 (leni
, vals
, fn
, seq
)
1041 Lisp_Object fn
, seq
;
1043 register Lisp_Object tail
;
1046 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1048 /* Don't let vals contain any garbage when GC happens. */
1049 for (i
= 0; i
< leni
; i
++)
1052 GCPRO3 (dummy
, fn
, seq
);
1054 gcpro1
.nvars
= leni
;
1055 /* We need not explicitly protect `tail' because it is used only on lists, and
1056 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1060 for (i
= 0; i
< leni
; i
++)
1062 dummy
= XVECTOR (seq
)->contents
[i
];
1063 vals
[i
] = call1 (fn
, dummy
);
1066 else if (STRINGP (seq
))
1068 for (i
= 0; i
< leni
; i
++)
1070 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1071 vals
[i
] = call1 (fn
, dummy
);
1074 else /* Must be a list, since Flength did not get an error */
1077 for (i
= 0; i
< leni
; i
++)
1079 vals
[i
] = call1 (fn
, Fcar (tail
));
1087 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1088 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1089 In between each pair of results, stick in SEP.\n\
1090 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1092 Lisp_Object fn
, seq
, sep
;
1097 register Lisp_Object
*args
;
1099 struct gcpro gcpro1
;
1101 len
= Flength (seq
);
1103 nargs
= leni
+ leni
- 1;
1104 if (nargs
< 0) return build_string ("");
1106 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1109 mapcar1 (leni
, args
, fn
, seq
);
1112 for (i
= leni
- 1; i
>= 0; i
--)
1113 args
[i
+ i
] = args
[i
];
1115 for (i
= 1; i
< nargs
; i
+= 2)
1118 return Fconcat (nargs
, args
);
1121 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1122 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1123 The result is a list just as long as SEQUENCE.\n\
1124 SEQUENCE may be a list, a vector or a string.")
1126 Lisp_Object fn
, seq
;
1128 register Lisp_Object len
;
1130 register Lisp_Object
*args
;
1132 len
= Flength (seq
);
1133 leni
= XFASTINT (len
);
1134 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1136 mapcar1 (leni
, args
, fn
, seq
);
1138 return Flist (leni
, args
);
1141 /* Anything that calls this function must protect from GC! */
1143 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1144 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1145 Takes one argument, which is the string to display to ask the question.\n\
1146 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1147 No confirmation of the answer is requested; a single character is enough.\n\
1148 Also accepts Space to mean yes, or Delete to mean no.")
1152 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1153 register int answer
;
1154 Lisp_Object xprompt
;
1155 Lisp_Object args
[2];
1156 int ocech
= cursor_in_echo_area
;
1157 struct gcpro gcpro1
, gcpro2
;
1159 map
= Fsymbol_value (intern ("query-replace-map"));
1161 CHECK_STRING (prompt
, 0);
1163 GCPRO2 (prompt
, xprompt
);
1168 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1171 Lisp_Object pane
, menu
;
1172 redisplay_preserve_echo_area ();
1173 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1174 Fcons (Fcons (build_string ("No"), Qnil
),
1176 menu
= Fcons (prompt
, pane
);
1177 obj
= Fx_popup_dialog (Qt
, menu
);
1178 answer
= !NILP (obj
);
1182 cursor_in_echo_area
= 1;
1183 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1185 obj
= read_filtered_event (1, 0, 0);
1186 cursor_in_echo_area
= 0;
1187 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1190 key
= Fmake_vector (make_number (1), obj
);
1191 def
= Flookup_key (map
, key
);
1192 answer_string
= Fsingle_key_description (obj
);
1194 if (EQ (def
, intern ("skip")))
1199 else if (EQ (def
, intern ("act")))
1204 else if (EQ (def
, intern ("recenter")))
1210 else if (EQ (def
, intern ("quit")))
1212 /* We want to exit this command for exit-prefix,
1213 and this is the only way to do it. */
1214 else if (EQ (def
, intern ("exit-prefix")))
1219 /* If we don't clear this, then the next call to read_char will
1220 return quit_char again, and we'll enter an infinite loop. */
1225 if (EQ (xprompt
, prompt
))
1227 args
[0] = build_string ("Please answer y or n. ");
1229 xprompt
= Fconcat (2, args
);
1234 if (! noninteractive
)
1236 cursor_in_echo_area
= -1;
1237 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1238 cursor_in_echo_area
= ocech
;
1241 return answer
? Qt
: Qnil
;
1244 /* This is how C code calls `yes-or-no-p' and allows the user
1247 Anything that calls this function must protect from GC! */
1250 do_yes_or_no_p (prompt
)
1253 return call1 (intern ("yes-or-no-p"), prompt
);
1256 /* Anything that calls this function must protect from GC! */
1258 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1259 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1260 Takes one argument, which is the string to display to ask the question.\n\
1261 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1262 The user must confirm the answer with RET,\n\
1263 and can edit it until it as been confirmed.")
1267 register Lisp_Object ans
;
1268 Lisp_Object args
[2];
1269 struct gcpro gcpro1
;
1272 CHECK_STRING (prompt
, 0);
1275 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1278 Lisp_Object pane
, menu
, obj
;
1279 redisplay_preserve_echo_area ();
1280 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1281 Fcons (Fcons (build_string ("No"), Qnil
),
1284 menu
= Fcons (prompt
, pane
);
1285 obj
= Fx_popup_dialog (Qt
, menu
);
1292 args
[1] = build_string ("(yes or no) ");
1293 prompt
= Fconcat (2, args
);
1299 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1300 Qyes_or_no_p_history
));
1301 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1306 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1314 message ("Please answer yes or no.");
1315 Fsleep_for (make_number (2), Qnil
);
1319 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1320 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1321 Each of the three load averages is multiplied by 100,\n\
1322 then converted to integer.\n\
1323 If the 5-minute or 15-minute load averages are not available, return a\n\
1324 shortened list, containing only those averages which are available.")
1328 int loads
= getloadavg (load_ave
, 3);
1332 error ("load-average not implemented for this operating system");
1336 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1341 Lisp_Object Vfeatures
;
1343 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1344 "Returns t if FEATURE is present in this Emacs.\n\
1345 Use this to conditionalize execution of lisp code based on the presence or\n\
1346 absence of emacs or environment extensions.\n\
1347 Use `provide' to declare that a feature is available.\n\
1348 This function looks at the value of the variable `features'.")
1350 Lisp_Object feature
;
1352 register Lisp_Object tem
;
1353 CHECK_SYMBOL (feature
, 0);
1354 tem
= Fmemq (feature
, Vfeatures
);
1355 return (NILP (tem
)) ? Qnil
: Qt
;
1358 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1359 "Announce that FEATURE is a feature of the current Emacs.")
1361 Lisp_Object feature
;
1363 register Lisp_Object tem
;
1364 CHECK_SYMBOL (feature
, 0);
1365 if (!NILP (Vautoload_queue
))
1366 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1367 tem
= Fmemq (feature
, Vfeatures
);
1369 Vfeatures
= Fcons (feature
, Vfeatures
);
1370 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1374 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1375 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1376 If FEATURE is not a member of the list `features', then the feature\n\
1377 is not loaded; so load the file FILENAME.\n\
1378 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1379 (feature
, file_name
)
1380 Lisp_Object feature
, file_name
;
1382 register Lisp_Object tem
;
1383 CHECK_SYMBOL (feature
, 0);
1384 tem
= Fmemq (feature
, Vfeatures
);
1385 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1388 int count
= specpdl_ptr
- specpdl
;
1390 /* Value saved here is to be restored into Vautoload_queue */
1391 record_unwind_protect (un_autoload
, Vautoload_queue
);
1392 Vautoload_queue
= Qt
;
1394 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1397 tem
= Fmemq (feature
, Vfeatures
);
1399 error ("Required feature %s was not provided",
1400 XSYMBOL (feature
)->name
->data
);
1402 /* Once loading finishes, don't undo it. */
1403 Vautoload_queue
= Qt
;
1404 feature
= unbind_to (count
, feature
);
1411 Qstring_lessp
= intern ("string-lessp");
1412 staticpro (&Qstring_lessp
);
1413 Qprovide
= intern ("provide");
1414 staticpro (&Qprovide
);
1415 Qrequire
= intern ("require");
1416 staticpro (&Qrequire
);
1417 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1418 staticpro (&Qyes_or_no_p_history
);
1420 DEFVAR_LISP ("features", &Vfeatures
,
1421 "A list of symbols which are the features of the executing emacs.\n\
1422 Used by `featurep' and `require', and altered by `provide'.");
1425 defsubr (&Sidentity
);
1428 defsubr (&Sstring_equal
);
1429 defsubr (&Sstring_lessp
);
1432 defsubr (&Svconcat
);
1433 defsubr (&Scopy_sequence
);
1434 defsubr (&Scopy_alist
);
1435 defsubr (&Ssubstring
);
1446 defsubr (&Snreverse
);
1447 defsubr (&Sreverse
);
1452 defsubr (&Sfillarray
);
1455 defsubr (&Smapconcat
);
1456 defsubr (&Sy_or_n_p
);
1457 defsubr (&Syes_or_no_p
);
1458 defsubr (&Sload_average
);
1459 defsubr (&Sfeaturep
);
1460 defsubr (&Srequire
);
1461 defsubr (&Sprovide
);