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 2, 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 All integers representable in Lisp are equally likely.\n\
53 On most systems, this is 28 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 (NATNUMP (limit
) && XFASTINT (limit
) != 0)
69 /* Try to take our random number from the higher bits of VAL,
70 not the lower, since (says Gentzel) the low bits of `random'
71 are less random than the higher ones. We do this by using the
72 quotient rather than the remainder. At the high end of the RNG
73 it's possible to get a quotient larger than limit; discarding
74 these values eliminates the bias that would otherwise appear
75 when using a large limit. */
76 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
78 val
= (random () & (((unsigned long)1 << VALBITS
) - 1)) / denominator
;
79 while (val
>= XFASTINT (limit
));
83 return make_number (val
);
86 /* Random data-structure functions */
88 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
89 "Return the length of vector, list or string SEQUENCE.\n\
90 A byte-code function object is also allowed.")
92 register Lisp_Object obj
;
94 register Lisp_Object tail
, val
;
99 XSETFASTINT (val
, XSTRING (obj
)->size
);
100 else if (VECTORP (obj
))
101 XSETFASTINT (val
, XVECTOR (obj
)->size
);
102 else if (COMPILEDP (obj
))
103 XSETFASTINT (val
, XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
);
104 else if (CONSP (obj
))
106 for (i
= 0, tail
= obj
; !NILP (tail
); i
++)
112 XSETFASTINT (val
, i
);
115 XSETFASTINT (val
, 0);
118 obj
= wrong_type_argument (Qsequencep
, obj
);
124 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
125 "T if two strings have identical contents.\n\
126 Case is significant, but text properties are ignored.\n\
127 Symbols are also allowed; their print names are used instead.")
129 register Lisp_Object s1
, s2
;
132 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
134 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
135 CHECK_STRING (s1
, 0);
136 CHECK_STRING (s2
, 1);
138 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
139 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
144 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
145 "T if first arg string is less than second in lexicographic order.\n\
146 Case is significant.\n\
147 Symbols are also allowed; their print names are used instead.")
149 register Lisp_Object s1
, s2
;
152 register unsigned char *p1
, *p2
;
156 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
158 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
159 CHECK_STRING (s1
, 0);
160 CHECK_STRING (s2
, 1);
162 p1
= XSTRING (s1
)->data
;
163 p2
= XSTRING (s2
)->data
;
164 end
= XSTRING (s1
)->size
;
165 if (end
> XSTRING (s2
)->size
)
166 end
= XSTRING (s2
)->size
;
168 for (i
= 0; i
< end
; i
++)
171 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
173 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
176 static Lisp_Object
concat ();
187 return concat (2, args
, Lisp_String
, 0);
189 return concat (2, &s1
, Lisp_String
, 0);
190 #endif /* NO_ARG_ARRAY */
196 Lisp_Object s1
, s2
, s3
;
203 return concat (3, args
, Lisp_String
, 0);
205 return concat (3, &s1
, Lisp_String
, 0);
206 #endif /* NO_ARG_ARRAY */
209 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
210 "Concatenate all the arguments and make the result a list.\n\
211 The result is a list whose elements are the elements of all the arguments.\n\
212 Each argument may be a list, vector or string.\n\
213 The last argument is not copied, just used as the tail of the new list.")
218 return concat (nargs
, args
, Lisp_Cons
, 1);
221 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
222 "Concatenate all the arguments and make the result a string.\n\
223 The result is a string whose elements are the elements of all the arguments.\n\
224 Each argument may be a string, a list of characters (integers),\n\
225 or a vector of characters (integers).")
230 return concat (nargs
, args
, Lisp_String
, 0);
233 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
234 "Concatenate all the arguments and make the result a vector.\n\
235 The result is a vector whose elements are the elements of all the arguments.\n\
236 Each argument may be a list, vector or string.")
241 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
244 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
245 "Return a copy of a list, vector or string.\n\
246 The elements of a list or vector are not copied; they are shared\n\
251 if (NILP (arg
)) return arg
;
252 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
253 arg
= wrong_type_argument (Qsequencep
, arg
);
254 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
258 concat (nargs
, args
, target_type
, last_special
)
261 enum Lisp_Type target_type
;
266 register Lisp_Object tail
;
267 register Lisp_Object
this;
271 Lisp_Object last_tail
;
274 /* In append, the last arg isn't treated like the others */
275 if (last_special
&& nargs
> 0)
278 last_tail
= args
[nargs
];
283 for (argnum
= 0; argnum
< nargs
; argnum
++)
286 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
287 || COMPILEDP (this)))
290 args
[argnum
] = Fnumber_to_string (this);
292 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
296 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
299 len
= Flength (this);
300 leni
+= XFASTINT (len
);
303 XSETFASTINT (len
, leni
);
305 if (target_type
== Lisp_Cons
)
306 val
= Fmake_list (len
, Qnil
);
307 else if (target_type
== Lisp_Vectorlike
)
308 val
= Fmake_vector (len
, Qnil
);
310 val
= Fmake_string (len
, len
);
312 /* In append, if all but last arg are nil, return last arg */
313 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
317 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
323 for (argnum
= 0; argnum
< nargs
; argnum
++)
327 register int thisindex
= 0;
331 thislen
= Flength (this), thisleni
= XINT (thislen
);
333 if (STRINGP (this) && STRINGP (val
)
334 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
336 copy_text_properties (make_number (0), thislen
, this,
337 make_number (toindex
), val
, Qnil
);
342 register Lisp_Object elt
;
344 /* Fetch next element of `this' arg into `elt', or break if
345 `this' is exhausted. */
346 if (NILP (this)) break;
348 elt
= Fcar (this), this = Fcdr (this);
351 if (thisindex
>= thisleni
) break;
353 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
355 elt
= XVECTOR (this)->contents
[thisindex
++];
358 /* Store into result */
361 XCONS (tail
)->car
= elt
;
363 tail
= XCONS (tail
)->cdr
;
365 else if (VECTORP (val
))
366 XVECTOR (val
)->contents
[toindex
++] = elt
;
369 while (!INTEGERP (elt
))
370 elt
= wrong_type_argument (Qintegerp
, elt
);
372 #ifdef MASSC_REGISTER_BUG
373 /* Even removing all "register"s doesn't disable this bug!
374 Nothing simpler than this seems to work. */
375 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
378 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
385 XCONS (prev
)->cdr
= last_tail
;
390 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
391 "Return a copy of ALIST.\n\
392 This is an alist which represents the same mapping from objects to objects,\n\
393 but does not share the alist structure with ALIST.\n\
394 The objects mapped (cars and cdrs of elements of the alist)\n\
395 are shared, however.\n\
396 Elements of ALIST that are not conses are also shared.")
400 register Lisp_Object tem
;
402 CHECK_LIST (alist
, 0);
405 alist
= concat (1, &alist
, Lisp_Cons
, 0);
406 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
408 register Lisp_Object car
;
409 car
= XCONS (tem
)->car
;
412 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
417 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
418 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
419 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
420 If FROM or TO is negative, it counts from the end.")
423 register Lisp_Object from
, to
;
427 CHECK_STRING (string
, 0);
428 CHECK_NUMBER (from
, 1);
430 to
= Flength (string
);
432 CHECK_NUMBER (to
, 2);
435 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
437 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
438 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
439 && XINT (to
) <= XSTRING (string
)->size
))
440 args_out_of_range_3 (string
, from
, to
);
442 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
443 XINT (to
) - XINT (from
));
444 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
448 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
449 "Take cdr N times on LIST, returns the result.")
452 register Lisp_Object list
;
457 for (i
= 0; i
< num
&& !NILP (list
); i
++)
465 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
466 "Return the Nth element of LIST.\n\
467 N counts from zero. If LIST is not that long, nil is returned.")
471 return Fcar (Fnthcdr (n
, list
));
474 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
475 "Return element of SEQUENCE at index N.")
477 register Lisp_Object seq
, n
;
482 if (CONSP (seq
) || NILP (seq
))
483 return Fcar (Fnthcdr (n
, seq
));
484 else if (STRINGP (seq
) || VECTORP (seq
))
485 return Faref (seq
, n
);
487 seq
= wrong_type_argument (Qsequencep
, seq
);
491 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
492 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
493 The value is actually the tail of LIST whose car is ELT.")
495 register Lisp_Object elt
;
498 register Lisp_Object tail
;
499 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
501 register Lisp_Object tem
;
503 if (! NILP (Fequal (elt
, tem
)))
510 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
511 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
512 The value is actually the tail of LIST whose car is ELT.")
514 register Lisp_Object elt
;
517 register Lisp_Object tail
;
518 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
520 register Lisp_Object tem
;
522 if (EQ (elt
, tem
)) return tail
;
528 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
529 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
530 The value is actually the element of LIST whose car is KEY.\n\
531 Elements of LIST that are not conses are ignored.")
533 register Lisp_Object key
;
536 register Lisp_Object tail
;
537 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
539 register Lisp_Object elt
, tem
;
541 if (!CONSP (elt
)) continue;
543 if (EQ (key
, tem
)) return elt
;
549 /* Like Fassq but never report an error and do not allow quits.
550 Use only on lists known never to be circular. */
553 assq_no_quit (key
, list
)
554 register Lisp_Object key
;
557 register Lisp_Object tail
;
558 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
560 register Lisp_Object elt
, tem
;
562 if (!CONSP (elt
)) continue;
564 if (EQ (key
, tem
)) return elt
;
569 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
570 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
571 The value is actually the element of LIST whose car is KEY.")
573 register Lisp_Object key
;
576 register Lisp_Object tail
;
577 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
579 register Lisp_Object elt
, tem
;
581 if (!CONSP (elt
)) continue;
582 tem
= Fequal (Fcar (elt
), key
);
583 if (!NILP (tem
)) return elt
;
589 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
590 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
591 The value is actually the element of LIST whose cdr is ELT.")
593 register Lisp_Object key
;
596 register Lisp_Object tail
;
597 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
599 register Lisp_Object elt
, tem
;
601 if (!CONSP (elt
)) continue;
603 if (EQ (key
, tem
)) return elt
;
609 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
610 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
611 The modified LIST is returned. Comparison is done with `eq'.\n\
612 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
613 therefore, write `(setq foo (delq element foo))'\n\
614 to be sure of changing the value of `foo'.")
616 register Lisp_Object elt
;
619 register Lisp_Object tail
, prev
;
620 register Lisp_Object tem
;
632 Fsetcdr (prev
, Fcdr (tail
));
642 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
643 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
644 The modified LIST is returned. Comparison is done with `equal'.\n\
645 If the first member of LIST is ELT, deleting it is not a side effect;\n\
646 it is simply using a different list.\n\
647 Therefore, write `(setq foo (delete element foo))'\n\
648 to be sure of changing the value of `foo'.")
650 register Lisp_Object elt
;
653 register Lisp_Object tail
, prev
;
654 register Lisp_Object tem
;
661 if (! NILP (Fequal (elt
, tem
)))
666 Fsetcdr (prev
, Fcdr (tail
));
676 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
677 "Reverse LIST by modifying cdr pointers.\n\
678 Returns the beginning of the reversed list.")
682 register Lisp_Object prev
, tail
, next
;
684 if (NILP (list
)) return list
;
691 Fsetcdr (tail
, prev
);
698 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
699 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
700 See also the function `nreverse', which is used more often.")
705 register Lisp_Object
*vec
;
706 register Lisp_Object tail
;
709 length
= Flength (list
);
710 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
711 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
712 vec
[i
] = Fcar (tail
);
714 return Flist (XINT (length
), vec
);
717 Lisp_Object
merge ();
719 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
720 "Sort LIST, stably, comparing elements using PREDICATE.\n\
721 Returns the sorted list. LIST is modified by side effects.\n\
722 PREDICATE is called with two elements of LIST, and should return T\n\
723 if the first element is \"less\" than the second.")
725 Lisp_Object list
, pred
;
727 Lisp_Object front
, back
;
728 register Lisp_Object len
, tem
;
729 struct gcpro gcpro1
, gcpro2
;
733 len
= Flength (list
);
738 XSETINT (len
, (length
/ 2) - 1);
739 tem
= Fnthcdr (len
, list
);
743 GCPRO2 (front
, back
);
744 front
= Fsort (front
, pred
);
745 back
= Fsort (back
, pred
);
747 return merge (front
, back
, pred
);
751 merge (org_l1
, org_l2
, pred
)
752 Lisp_Object org_l1
, org_l2
;
756 register Lisp_Object tail
;
758 register Lisp_Object l1
, l2
;
759 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
766 /* It is sufficient to protect org_l1 and org_l2.
767 When l1 and l2 are updated, we copy the new values
768 back into the org_ vars. */
769 GCPRO4 (org_l1
, org_l2
, pred
, value
);
789 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
810 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
811 "Return the value of SYMBOL's PROPNAME property.\n\
812 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
815 register Lisp_Object prop
;
817 register Lisp_Object tail
;
818 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
820 register Lisp_Object tem
;
823 return Fcar (Fcdr (tail
));
828 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
829 "Store SYMBOL's PROPNAME property with value VALUE.\n\
830 It can be retrieved with `(get SYMBOL PROPNAME)'.")
833 register Lisp_Object prop
;
836 register Lisp_Object tail
, prev
;
839 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
841 register Lisp_Object tem
;
844 return Fsetcar (Fcdr (tail
), val
);
847 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
849 Fsetplist (sym
, newcell
);
851 Fsetcdr (Fcdr (prev
), newcell
);
855 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
856 "T if two Lisp objects have similar structure and contents.\n\
857 They must have the same data type.\n\
858 Conses are compared by comparing the cars and the cdrs.\n\
859 Vectors and strings are compared element by element.\n\
860 Numbers are compared by value, but integers cannot equal floats.\n\
861 (Use `=' if you want integers and floats to be able to be equal.)\n\
862 Symbols must match exactly.")
864 register Lisp_Object o1
, o2
;
866 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
870 internal_equal (o1
, o2
, depth
)
871 register Lisp_Object o1
, o2
;
875 error ("Stack overflow in equal");
881 if (XTYPE (o1
) != XTYPE (o2
))
886 #ifdef LISP_FLOAT_TYPE
888 return (extract_float (o1
) == extract_float (o2
));
892 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
894 o1
= XCONS (o1
)->cdr
;
895 o2
= XCONS (o2
)->cdr
;
899 if (XMISC (o1
)->type
!= XMISC (o2
)->type
)
903 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
905 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
908 o1
= XOVERLAY (o1
)->plist
;
909 o2
= XOVERLAY (o2
)->plist
;
914 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
915 && (XMARKER (o1
)->buffer
== 0
916 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
920 case Lisp_Vectorlike
:
922 register int i
, size
;
923 size
= XVECTOR (o1
)->size
;
924 /* Pseudovectors have the type encoded in the size field, so this test
925 actually checks that the objects have the same type as well as the
927 if (XVECTOR (o2
)->size
!= size
)
929 /* But only true vectors and compiled functions are actually sensible
930 to compare, so eliminate the others now. */
931 if (size
& PSEUDOVECTOR_FLAG
)
933 if (!(size
& PVEC_COMPILED
))
935 size
&= PSEUDOVECTOR_SIZE_MASK
;
937 for (i
= 0; i
< size
; i
++)
940 v1
= XVECTOR (o1
)->contents
[i
];
941 v2
= XVECTOR (o2
)->contents
[i
];
942 if (!internal_equal (v1
, v2
, depth
+ 1))
950 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
952 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
955 #ifdef USE_TEXT_PROPERTIES
956 /* If the strings have intervals, verify they match;
957 if not, they are unequal. */
958 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
959 && ! compare_string_intervals (o1
, o2
))
967 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
968 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
970 Lisp_Object array
, item
;
972 register int size
, index
, charval
;
976 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
977 size
= XVECTOR (array
)->size
;
978 for (index
= 0; index
< size
; index
++)
981 else if (STRINGP (array
))
983 register unsigned char *p
= XSTRING (array
)->data
;
984 CHECK_NUMBER (item
, 1);
985 charval
= XINT (item
);
986 size
= XSTRING (array
)->size
;
987 for (index
= 0; index
< size
; index
++)
992 array
= wrong_type_argument (Qarrayp
, array
);
1004 Lisp_Object args
[2];
1007 return Fnconc (2, args
);
1009 return Fnconc (2, &s1
);
1010 #endif /* NO_ARG_ARRAY */
1013 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1014 "Concatenate any number of lists by altering them.\n\
1015 Only the last argument is not altered, and need not be a list.")
1020 register int argnum
;
1021 register Lisp_Object tail
, tem
, val
;
1025 for (argnum
= 0; argnum
< nargs
; argnum
++)
1028 if (NILP (tem
)) continue;
1033 if (argnum
+ 1 == nargs
) break;
1036 tem
= wrong_type_argument (Qlistp
, tem
);
1045 tem
= args
[argnum
+ 1];
1046 Fsetcdr (tail
, tem
);
1048 args
[argnum
+ 1] = tail
;
1054 /* This is the guts of all mapping functions.
1055 Apply fn to each element of seq, one by one,
1056 storing the results into elements of vals, a C vector of Lisp_Objects.
1057 leni is the length of vals, which should also be the length of seq. */
1060 mapcar1 (leni
, vals
, fn
, seq
)
1063 Lisp_Object fn
, seq
;
1065 register Lisp_Object tail
;
1068 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1070 /* Don't let vals contain any garbage when GC happens. */
1071 for (i
= 0; i
< leni
; i
++)
1074 GCPRO3 (dummy
, fn
, seq
);
1076 gcpro1
.nvars
= leni
;
1077 /* We need not explicitly protect `tail' because it is used only on lists, and
1078 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1082 for (i
= 0; i
< leni
; i
++)
1084 dummy
= XVECTOR (seq
)->contents
[i
];
1085 vals
[i
] = call1 (fn
, dummy
);
1088 else if (STRINGP (seq
))
1090 for (i
= 0; i
< leni
; i
++)
1092 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1093 vals
[i
] = call1 (fn
, dummy
);
1096 else /* Must be a list, since Flength did not get an error */
1099 for (i
= 0; i
< leni
; i
++)
1101 vals
[i
] = call1 (fn
, Fcar (tail
));
1109 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1110 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1111 In between each pair of results, stick in SEP.\n\
1112 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1114 Lisp_Object fn
, seq
, sep
;
1119 register Lisp_Object
*args
;
1121 struct gcpro gcpro1
;
1123 len
= Flength (seq
);
1125 nargs
= leni
+ leni
- 1;
1126 if (nargs
< 0) return build_string ("");
1128 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1131 mapcar1 (leni
, args
, fn
, seq
);
1134 for (i
= leni
- 1; i
>= 0; i
--)
1135 args
[i
+ i
] = args
[i
];
1137 for (i
= 1; i
< nargs
; i
+= 2)
1140 return Fconcat (nargs
, args
);
1143 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1144 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1145 The result is a list just as long as SEQUENCE.\n\
1146 SEQUENCE may be a list, a vector or a string.")
1148 Lisp_Object fn
, seq
;
1150 register Lisp_Object len
;
1152 register Lisp_Object
*args
;
1154 len
= Flength (seq
);
1155 leni
= XFASTINT (len
);
1156 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1158 mapcar1 (leni
, args
, fn
, seq
);
1160 return Flist (leni
, args
);
1163 /* Anything that calls this function must protect from GC! */
1165 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1166 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1167 Takes one argument, which is the string to display to ask the question.\n\
1168 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1169 No confirmation of the answer is requested; a single character is enough.\n\
1170 Also accepts Space to mean yes, or Delete to mean no.")
1174 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1175 register int answer
;
1176 Lisp_Object xprompt
;
1177 Lisp_Object args
[2];
1178 int ocech
= cursor_in_echo_area
;
1179 struct gcpro gcpro1
, gcpro2
;
1181 map
= Fsymbol_value (intern ("query-replace-map"));
1183 CHECK_STRING (prompt
, 0);
1185 GCPRO2 (prompt
, xprompt
);
1190 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1193 Lisp_Object pane
, menu
;
1194 redisplay_preserve_echo_area ();
1195 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1196 Fcons (Fcons (build_string ("No"), Qnil
),
1198 menu
= Fcons (prompt
, pane
);
1199 obj
= Fx_popup_dialog (Qt
, menu
);
1200 answer
= !NILP (obj
);
1204 cursor_in_echo_area
= 1;
1205 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1207 obj
= read_filtered_event (1, 0, 0);
1208 cursor_in_echo_area
= 0;
1209 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1212 key
= Fmake_vector (make_number (1), obj
);
1213 def
= Flookup_key (map
, key
);
1214 answer_string
= Fsingle_key_description (obj
);
1216 if (EQ (def
, intern ("skip")))
1221 else if (EQ (def
, intern ("act")))
1226 else if (EQ (def
, intern ("recenter")))
1232 else if (EQ (def
, intern ("quit")))
1234 /* We want to exit this command for exit-prefix,
1235 and this is the only way to do it. */
1236 else if (EQ (def
, intern ("exit-prefix")))
1241 /* If we don't clear this, then the next call to read_char will
1242 return quit_char again, and we'll enter an infinite loop. */
1247 if (EQ (xprompt
, prompt
))
1249 args
[0] = build_string ("Please answer y or n. ");
1251 xprompt
= Fconcat (2, args
);
1256 if (! noninteractive
)
1258 cursor_in_echo_area
= -1;
1259 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1260 cursor_in_echo_area
= ocech
;
1263 return answer
? Qt
: Qnil
;
1266 /* This is how C code calls `yes-or-no-p' and allows the user
1269 Anything that calls this function must protect from GC! */
1272 do_yes_or_no_p (prompt
)
1275 return call1 (intern ("yes-or-no-p"), prompt
);
1278 /* Anything that calls this function must protect from GC! */
1280 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1281 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1282 Takes one argument, which is the string to display to ask the question.\n\
1283 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1284 The user must confirm the answer with RET,\n\
1285 and can edit it until it as been confirmed.")
1289 register Lisp_Object ans
;
1290 Lisp_Object args
[2];
1291 struct gcpro gcpro1
;
1294 CHECK_STRING (prompt
, 0);
1297 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1300 Lisp_Object pane
, menu
, obj
;
1301 redisplay_preserve_echo_area ();
1302 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1303 Fcons (Fcons (build_string ("No"), Qnil
),
1306 menu
= Fcons (prompt
, pane
);
1307 obj
= Fx_popup_dialog (Qt
, menu
);
1314 args
[1] = build_string ("(yes or no) ");
1315 prompt
= Fconcat (2, args
);
1321 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1322 Qyes_or_no_p_history
));
1323 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1328 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1336 message ("Please answer yes or no.");
1337 Fsleep_for (make_number (2), Qnil
);
1341 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1342 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1343 Each of the three load averages is multiplied by 100,\n\
1344 then converted to integer.\n\
1345 If the 5-minute or 15-minute load averages are not available, return a\n\
1346 shortened list, containing only those averages which are available.")
1350 int loads
= getloadavg (load_ave
, 3);
1354 error ("load-average not implemented for this operating system");
1358 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1363 Lisp_Object Vfeatures
;
1365 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1366 "Returns t if FEATURE is present in this Emacs.\n\
1367 Use this to conditionalize execution of lisp code based on the presence or\n\
1368 absence of emacs or environment extensions.\n\
1369 Use `provide' to declare that a feature is available.\n\
1370 This function looks at the value of the variable `features'.")
1372 Lisp_Object feature
;
1374 register Lisp_Object tem
;
1375 CHECK_SYMBOL (feature
, 0);
1376 tem
= Fmemq (feature
, Vfeatures
);
1377 return (NILP (tem
)) ? Qnil
: Qt
;
1380 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1381 "Announce that FEATURE is a feature of the current Emacs.")
1383 Lisp_Object feature
;
1385 register Lisp_Object tem
;
1386 CHECK_SYMBOL (feature
, 0);
1387 if (!NILP (Vautoload_queue
))
1388 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1389 tem
= Fmemq (feature
, Vfeatures
);
1391 Vfeatures
= Fcons (feature
, Vfeatures
);
1392 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1396 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1397 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1398 If FEATURE is not a member of the list `features', then the feature\n\
1399 is not loaded; so load the file FILENAME.\n\
1400 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1401 (feature
, file_name
)
1402 Lisp_Object feature
, file_name
;
1404 register Lisp_Object tem
;
1405 CHECK_SYMBOL (feature
, 0);
1406 tem
= Fmemq (feature
, Vfeatures
);
1407 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1410 int count
= specpdl_ptr
- specpdl
;
1412 /* Value saved here is to be restored into Vautoload_queue */
1413 record_unwind_protect (un_autoload
, Vautoload_queue
);
1414 Vautoload_queue
= Qt
;
1416 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1419 tem
= Fmemq (feature
, Vfeatures
);
1421 error ("Required feature %s was not provided",
1422 XSYMBOL (feature
)->name
->data
);
1424 /* Once loading finishes, don't undo it. */
1425 Vautoload_queue
= Qt
;
1426 feature
= unbind_to (count
, feature
);
1433 Qstring_lessp
= intern ("string-lessp");
1434 staticpro (&Qstring_lessp
);
1435 Qprovide
= intern ("provide");
1436 staticpro (&Qprovide
);
1437 Qrequire
= intern ("require");
1438 staticpro (&Qrequire
);
1439 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1440 staticpro (&Qyes_or_no_p_history
);
1442 DEFVAR_LISP ("features", &Vfeatures
,
1443 "A list of symbols which are the features of the executing emacs.\n\
1444 Used by `featurep' and `require', and altered by `provide'.");
1447 defsubr (&Sidentity
);
1450 defsubr (&Sstring_equal
);
1451 defsubr (&Sstring_lessp
);
1454 defsubr (&Svconcat
);
1455 defsubr (&Scopy_sequence
);
1456 defsubr (&Scopy_alist
);
1457 defsubr (&Ssubstring
);
1468 defsubr (&Snreverse
);
1469 defsubr (&Sreverse
);
1474 defsubr (&Sfillarray
);
1477 defsubr (&Smapconcat
);
1478 defsubr (&Sy_or_n_p
);
1479 defsubr (&Syes_or_no_p
);
1480 defsubr (&Sload_average
);
1481 defsubr (&Sfeaturep
);
1482 defsubr (&Srequire
);
1483 defsubr (&Sprovide
);