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 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
36 Lisp_Object Qyes_or_no_p_history
;
38 static Lisp_Object
internal_equal ();
40 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
41 "Return the argument unchanged.")
48 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
49 "Return a pseudo-random number.\n\
50 On most systems all integers representable in Lisp are equally likely.\n\
51 This is 24 bits' worth.\n\
52 With argument N, return random number in interval [0,N).\n\
53 With argument t, set the random number seed from the current time and pid.")
58 unsigned long denominator
;
59 extern long random ();
64 srandom (getpid () + time (0));
65 if (XTYPE (limit
) == Lisp_Int
&& XINT (limit
) > 0)
67 if (XINT (limit
) >= 0x40000000)
68 /* This case may occur on 64-bit machines. */
69 val
= random () % XINT (limit
);
72 /* Try to take our random number from the higher bits of VAL,
73 not the lower, since (says Gentzel) the low bits of `random'
74 are less random than the higher ones. We do this by using the
75 quotient rather than the remainder. At the high end of the RNG
76 it's possible to get a quotient larger than limit; discarding
77 these values eliminates the bias that would otherwise appear
78 when using a large limit. */
79 denominator
= (unsigned long)0x40000000 / XFASTINT (limit
);
81 val
= (random () & 0x3fffffff) / denominator
;
87 return make_number (val
);
90 /* Random data-structure functions */
92 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
93 "Return the length of vector, list or string SEQUENCE.\n\
94 A byte-code function object is also allowed.")
96 register Lisp_Object obj
;
98 register Lisp_Object tail
, val
;
102 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
103 || XTYPE (obj
) == Lisp_Compiled
)
104 return Farray_length (obj
);
105 else if (CONSP (obj
))
107 for (i
= 0, tail
= obj
; !NILP(tail
); i
++)
123 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.\n\
131 Symbols are also allowed; their print names are used instead.")
133 register Lisp_Object s1
, s2
;
135 if (XTYPE (s1
) == Lisp_Symbol
)
136 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
137 if (XTYPE (s2
) == Lisp_Symbol
)
138 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
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
;
159 if (XTYPE (s1
) == Lisp_Symbol
)
160 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
161 if (XTYPE (s2
) == Lisp_Symbol
)
162 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
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 */
197 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
198 "Concatenate all the arguments and make the result a list.\n\
199 The result is a list whose elements are the elements of all the arguments.\n\
200 Each argument may be a list, vector or string.\n\
201 The last argument is not copied, just used as the tail of the new list.")
206 return concat (nargs
, args
, Lisp_Cons
, 1);
209 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
210 "Concatenate all the arguments and make the result a string.\n\
211 The result is a string whose elements are the elements of all the arguments.\n\
212 Each argument may be a string, a list of characters (integers),\n\
213 or a vector of characters (integers).")
218 return concat (nargs
, args
, Lisp_String
, 0);
221 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
222 "Concatenate all the arguments and make the result a vector.\n\
223 The result is a vector whose elements are the elements of all the arguments.\n\
224 Each argument may be a list, vector or string.")
229 return concat (nargs
, args
, Lisp_Vector
, 0);
232 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
233 "Return a copy of a list, vector or string.\n\
234 The elements of a list or vector are not copied; they are shared\n\
239 if (NILP (arg
)) return arg
;
240 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
241 arg
= wrong_type_argument (Qsequencep
, arg
);
242 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
246 concat (nargs
, args
, target_type
, last_special
)
249 enum Lisp_Type target_type
;
254 register Lisp_Object tail
;
255 register Lisp_Object
this;
259 Lisp_Object last_tail
;
262 /* In append, the last arg isn't treated like the others */
263 if (last_special
&& nargs
> 0)
266 last_tail
= args
[nargs
];
271 for (argnum
= 0; argnum
< nargs
; argnum
++)
274 if (!(CONSP (this) || NILP (this)
275 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
276 || XTYPE (this) == Lisp_Compiled
))
278 if (XTYPE (this) == Lisp_Int
)
279 args
[argnum
] = Fnumber_to_string (this);
281 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
285 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
288 len
= Flength (this);
289 leni
+= XFASTINT (len
);
292 XFASTINT (len
) = leni
;
294 if (target_type
== Lisp_Cons
)
295 val
= Fmake_list (len
, Qnil
);
296 else if (target_type
== Lisp_Vector
)
297 val
= Fmake_vector (len
, Qnil
);
299 val
= Fmake_string (len
, len
);
301 /* In append, if all but last arg are nil, return last arg */
302 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
306 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
312 for (argnum
= 0; argnum
< nargs
; argnum
++)
316 register int thisindex
= 0;
320 thislen
= Flength (this), thisleni
= XINT (thislen
);
322 if (XTYPE (this) == Lisp_String
&& XTYPE (val
) == Lisp_String
323 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
325 copy_text_properties (make_number (0), thislen
, this,
326 make_number (toindex
), val
, Qnil
);
331 register Lisp_Object elt
;
333 /* Fetch next element of `this' arg into `elt', or break if
334 `this' is exhausted. */
335 if (NILP (this)) break;
337 elt
= Fcar (this), this = Fcdr (this);
340 if (thisindex
>= thisleni
) break;
341 if (XTYPE (this) == Lisp_String
)
342 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
344 elt
= XVECTOR (this)->contents
[thisindex
++];
347 /* Store into result */
350 XCONS (tail
)->car
= elt
;
352 tail
= XCONS (tail
)->cdr
;
354 else if (XTYPE (val
) == Lisp_Vector
)
355 XVECTOR (val
)->contents
[toindex
++] = elt
;
358 while (XTYPE (elt
) != Lisp_Int
)
359 elt
= wrong_type_argument (Qintegerp
, elt
);
361 #ifdef MASSC_REGISTER_BUG
362 /* Even removing all "register"s doesn't disable this bug!
363 Nothing simpler than this seems to work. */
364 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
367 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
374 XCONS (prev
)->cdr
= last_tail
;
379 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
380 "Return a copy of ALIST.\n\
381 This is an alist which represents the same mapping from objects to objects,\n\
382 but does not share the alist structure with ALIST.\n\
383 The objects mapped (cars and cdrs of elements of the alist)\n\
384 are shared, however.\n\
385 Elements of ALIST that are not conses are also shared.")
389 register Lisp_Object tem
;
391 CHECK_LIST (alist
, 0);
394 alist
= concat (1, &alist
, Lisp_Cons
, 0);
395 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
397 register Lisp_Object car
;
398 car
= XCONS (tem
)->car
;
401 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
406 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
407 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
408 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
409 If FROM or TO is negative, it counts from the end.")
412 register Lisp_Object from
, to
;
416 CHECK_STRING (string
, 0);
417 CHECK_NUMBER (from
, 1);
419 to
= Flength (string
);
421 CHECK_NUMBER (to
, 2);
424 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
426 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
427 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
428 && XINT (to
) <= XSTRING (string
)->size
))
429 args_out_of_range_3 (string
, from
, to
);
431 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
432 XINT (to
) - XINT (from
));
433 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
437 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
438 "Take cdr N times on LIST, returns the result.")
441 register Lisp_Object list
;
446 for (i
= 0; i
< num
&& !NILP (list
); i
++)
454 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
455 "Return the Nth element of LIST.\n\
456 N counts from zero. If LIST is not that long, nil is returned.")
460 return Fcar (Fnthcdr (n
, list
));
463 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
464 "Return element of SEQUENCE at index N.")
466 register Lisp_Object seq
, n
;
471 if (XTYPE (seq
) == Lisp_Cons
|| NILP (seq
))
472 return Fcar (Fnthcdr (n
, seq
));
473 else if (XTYPE (seq
) == Lisp_String
474 || XTYPE (seq
) == Lisp_Vector
)
475 return Faref (seq
, n
);
477 seq
= wrong_type_argument (Qsequencep
, seq
);
481 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
482 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
483 The value is actually the tail of LIST whose car is ELT.")
485 register Lisp_Object elt
;
488 register Lisp_Object tail
;
489 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
491 register Lisp_Object tem
;
493 if (! NILP (Fequal (elt
, tem
)))
500 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
501 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
502 The value is actually the tail of LIST whose car is ELT.")
504 register Lisp_Object elt
;
507 register Lisp_Object tail
;
508 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
510 register Lisp_Object tem
;
512 if (EQ (elt
, tem
)) return tail
;
518 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
519 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
520 The value is actually the element of LIST whose car is KEY.\n\
521 Elements of LIST that are not conses are ignored.")
523 register Lisp_Object key
;
526 register Lisp_Object tail
;
527 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
529 register Lisp_Object elt
, tem
;
531 if (!CONSP (elt
)) continue;
533 if (EQ (key
, tem
)) return elt
;
539 /* Like Fassq but never report an error and do not allow quits.
540 Use only on lists known never to be circular. */
543 assq_no_quit (key
, list
)
544 register Lisp_Object key
;
547 register Lisp_Object tail
;
548 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
550 register Lisp_Object elt
, tem
;
552 if (!CONSP (elt
)) continue;
554 if (EQ (key
, tem
)) return elt
;
559 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
560 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
561 The value is actually the element of LIST whose car is KEY.")
563 register Lisp_Object key
;
566 register Lisp_Object tail
;
567 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
569 register Lisp_Object elt
, tem
;
571 if (!CONSP (elt
)) continue;
572 tem
= Fequal (Fcar (elt
), key
);
573 if (!NILP (tem
)) return elt
;
579 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
580 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
581 The value is actually the element of LIST whose cdr is ELT.")
583 register Lisp_Object key
;
586 register Lisp_Object tail
;
587 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
589 register Lisp_Object elt
, tem
;
591 if (!CONSP (elt
)) continue;
593 if (EQ (key
, tem
)) return elt
;
599 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
600 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
601 The modified LIST is returned. Comparison is done with `eq'.\n\
602 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
603 therefore, write `(setq foo (delq element foo))'\n\
604 to be sure of changing the value of `foo'.")
606 register Lisp_Object elt
;
609 register Lisp_Object tail
, prev
;
610 register Lisp_Object tem
;
622 Fsetcdr (prev
, Fcdr (tail
));
632 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
633 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
634 The modified LIST is returned. Comparison is done with `equal'.\n\
635 If the first member of LIST is ELT, deleting it is not a side effect;\n\
636 it is simply using a different list.\n\
637 Therefore, write `(setq foo (delete element foo))'\n\
638 to be sure of changing the value of `foo'.")
640 register Lisp_Object elt
;
643 register Lisp_Object tail
, prev
;
644 register Lisp_Object tem
;
651 if (! NILP (Fequal (elt
, tem
)))
656 Fsetcdr (prev
, Fcdr (tail
));
666 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
667 "Reverse LIST by modifying cdr pointers.\n\
668 Returns the beginning of the reversed list.")
672 register Lisp_Object prev
, tail
, next
;
674 if (NILP (list
)) return list
;
681 Fsetcdr (tail
, prev
);
688 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
689 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
690 See also the function `nreverse', which is used more often.")
695 register Lisp_Object
*vec
;
696 register Lisp_Object tail
;
699 length
= Flength (list
);
700 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
701 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
702 vec
[i
] = Fcar (tail
);
704 return Flist (XINT (length
), vec
);
707 Lisp_Object
merge ();
709 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
710 "Sort LIST, stably, comparing elements using PREDICATE.\n\
711 Returns the sorted list. LIST is modified by side effects.\n\
712 PREDICATE is called with two elements of LIST, and should return T\n\
713 if the first element is \"less\" than the second.")
715 Lisp_Object list
, pred
;
717 Lisp_Object front
, back
;
718 register Lisp_Object len
, tem
;
719 struct gcpro gcpro1
, gcpro2
;
723 len
= Flength (list
);
728 XSETINT (len
, (length
/ 2) - 1);
729 tem
= Fnthcdr (len
, list
);
733 GCPRO2 (front
, back
);
734 front
= Fsort (front
, pred
);
735 back
= Fsort (back
, pred
);
737 return merge (front
, back
, pred
);
741 merge (org_l1
, org_l2
, pred
)
742 Lisp_Object org_l1
, org_l2
;
746 register Lisp_Object tail
;
748 register Lisp_Object l1
, l2
;
749 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
756 /* It is sufficient to protect org_l1 and org_l2.
757 When l1 and l2 are updated, we copy the new values
758 back into the org_ vars. */
759 GCPRO4 (org_l1
, org_l2
, pred
, value
);
779 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
800 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
801 "Return the value of SYMBOL's PROPNAME property.\n\
802 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
805 register Lisp_Object prop
;
807 register Lisp_Object tail
;
808 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
810 register Lisp_Object tem
;
813 return Fcar (Fcdr (tail
));
818 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
819 "Store SYMBOL's PROPNAME property with value VALUE.\n\
820 It can be retrieved with `(get SYMBOL PROPNAME)'.")
823 register Lisp_Object prop
;
826 register Lisp_Object tail
, prev
;
829 for (tail
= Fsymbol_plist (sym
); !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
831 register Lisp_Object tem
;
834 return Fsetcar (Fcdr (tail
), val
);
837 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
839 Fsetplist (sym
, newcell
);
841 Fsetcdr (Fcdr (prev
), newcell
);
845 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
846 "T if two Lisp objects have similar structure and contents.\n\
847 They must have the same data type.\n\
848 Conses are compared by comparing the cars and the cdrs.\n\
849 Vectors and strings are compared element by element.\n\
850 Numbers are compared by value, but integers cannot equal floats.\n\
851 (Use `=' if you want integers and floats to be able to be equal.)\n\
852 Symbols must match exactly.")
854 register Lisp_Object o1
, o2
;
856 return internal_equal (o1
, o2
, 0);
860 internal_equal (o1
, o2
, depth
)
861 register Lisp_Object o1
, o2
;
865 error ("Stack overflow in equal");
868 if (EQ (o1
, o2
)) return Qt
;
869 #ifdef LISP_FLOAT_TYPE
870 if (FLOATP (o1
) && FLOATP (o2
))
871 return (extract_float (o1
) == extract_float (o2
)) ? Qt
: Qnil
;
873 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
874 if (XTYPE (o1
) == Lisp_Cons
875 || XTYPE (o1
) == Lisp_Overlay
)
878 v1
= internal_equal (Fcar (o1
), Fcar (o2
), depth
+ 1);
881 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
884 if (XTYPE (o1
) == Lisp_Marker
)
886 return ((XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
887 && (XMARKER (o1
)->buffer
== 0
888 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
))
891 if (XTYPE (o1
) == Lisp_Vector
892 || XTYPE (o1
) == Lisp_Compiled
)
895 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
897 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
899 Lisp_Object v
, v1
, v2
;
900 v1
= XVECTOR (o1
)->contents
[index
];
901 v2
= XVECTOR (o2
)->contents
[index
];
902 v
= internal_equal (v1
, v2
, depth
+ 1);
903 if (NILP (v
)) return v
;
907 if (XTYPE (o1
) == Lisp_String
)
909 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
911 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
918 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
919 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
921 Lisp_Object array
, item
;
923 register int size
, index
, charval
;
925 if (XTYPE (array
) == Lisp_Vector
)
927 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
928 size
= XVECTOR (array
)->size
;
929 for (index
= 0; index
< size
; index
++)
932 else if (XTYPE (array
) == Lisp_String
)
934 register unsigned char *p
= XSTRING (array
)->data
;
935 CHECK_NUMBER (item
, 1);
936 charval
= XINT (item
);
937 size
= XSTRING (array
)->size
;
938 for (index
= 0; index
< size
; index
++)
943 array
= wrong_type_argument (Qarrayp
, array
);
958 return Fnconc (2, args
);
960 return Fnconc (2, &s1
);
961 #endif /* NO_ARG_ARRAY */
964 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
965 "Concatenate any number of lists by altering them.\n\
966 Only the last argument is not altered, and need not be a list.")
972 register Lisp_Object tail
, tem
, val
;
976 for (argnum
= 0; argnum
< nargs
; argnum
++)
979 if (NILP (tem
)) continue;
984 if (argnum
+ 1 == nargs
) break;
987 tem
= wrong_type_argument (Qlistp
, tem
);
996 tem
= args
[argnum
+ 1];
999 args
[argnum
+ 1] = tail
;
1005 /* This is the guts of all mapping functions.
1006 Apply fn to each element of seq, one by one,
1007 storing the results into elements of vals, a C vector of Lisp_Objects.
1008 leni is the length of vals, which should also be the length of seq. */
1011 mapcar1 (leni
, vals
, fn
, seq
)
1014 Lisp_Object fn
, seq
;
1016 register Lisp_Object tail
;
1019 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1021 /* Don't let vals contain any garbage when GC happens. */
1022 for (i
= 0; i
< leni
; i
++)
1025 GCPRO3 (dummy
, fn
, seq
);
1027 gcpro1
.nvars
= leni
;
1028 /* We need not explicitly protect `tail' because it is used only on lists, and
1029 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1031 if (XTYPE (seq
) == Lisp_Vector
)
1033 for (i
= 0; i
< leni
; i
++)
1035 dummy
= XVECTOR (seq
)->contents
[i
];
1036 vals
[i
] = call1 (fn
, dummy
);
1039 else if (XTYPE (seq
) == Lisp_String
)
1041 for (i
= 0; i
< leni
; i
++)
1043 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1044 vals
[i
] = call1 (fn
, dummy
);
1047 else /* Must be a list, since Flength did not get an error */
1050 for (i
= 0; i
< leni
; i
++)
1052 vals
[i
] = call1 (fn
, Fcar (tail
));
1060 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1061 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1062 In between each pair of results, stick in SEP.\n\
1063 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1065 Lisp_Object fn
, seq
, sep
;
1070 register Lisp_Object
*args
;
1072 struct gcpro gcpro1
;
1074 len
= Flength (seq
);
1076 nargs
= leni
+ leni
- 1;
1077 if (nargs
< 0) return build_string ("");
1079 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1082 mapcar1 (leni
, args
, fn
, seq
);
1085 for (i
= leni
- 1; i
>= 0; i
--)
1086 args
[i
+ i
] = args
[i
];
1088 for (i
= 1; i
< nargs
; i
+= 2)
1091 return Fconcat (nargs
, args
);
1094 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1095 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1096 The result is a list just as long as SEQUENCE.\n\
1097 SEQUENCE may be a list, a vector or a string.")
1099 Lisp_Object fn
, seq
;
1101 register Lisp_Object len
;
1103 register Lisp_Object
*args
;
1105 len
= Flength (seq
);
1106 leni
= XFASTINT (len
);
1107 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1109 mapcar1 (leni
, args
, fn
, seq
);
1111 return Flist (leni
, args
);
1114 /* Anything that calls this function must protect from GC! */
1116 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1117 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1118 Takes one argument, which is the string to display to ask the question.\n\
1119 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1120 No confirmation of the answer is requested; a single character is enough.\n\
1121 Also accepts Space to mean yes, or Delete to mean no.")
1125 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1126 register int answer
;
1127 Lisp_Object xprompt
;
1128 Lisp_Object args
[2];
1129 int ocech
= cursor_in_echo_area
;
1130 struct gcpro gcpro1
, gcpro2
;
1132 map
= Fsymbol_value (intern ("query-replace-map"));
1134 CHECK_STRING (prompt
, 0);
1136 GCPRO2 (prompt
, xprompt
);
1141 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1144 Lisp_Object pane
, menu
;
1145 redisplay_preserve_echo_area ();
1146 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1147 Fcons (Fcons (build_string ("No"), Qnil
),
1149 menu
= Fcons (prompt
, pane
);
1150 obj
= Fx_popup_dialog (Qt
, menu
);
1151 answer
= !NILP (obj
);
1155 cursor_in_echo_area
= 1;
1156 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1158 obj
= read_filtered_event (1, 0, 0);
1159 cursor_in_echo_area
= 0;
1160 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1163 key
= Fmake_vector (make_number (1), obj
);
1164 def
= Flookup_key (map
, key
);
1165 answer_string
= Fsingle_key_description (obj
);
1167 if (EQ (def
, intern ("skip")))
1172 else if (EQ (def
, intern ("act")))
1177 else if (EQ (def
, intern ("recenter")))
1183 else if (EQ (def
, intern ("quit")))
1188 /* If we don't clear this, then the next call to read_char will
1189 return quit_char again, and we'll enter an infinite loop. */
1194 if (EQ (xprompt
, prompt
))
1196 args
[0] = build_string ("Please answer y or n. ");
1198 xprompt
= Fconcat (2, args
);
1203 if (! noninteractive
)
1205 cursor_in_echo_area
= -1;
1206 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1207 cursor_in_echo_area
= ocech
;
1210 return answer
? Qt
: Qnil
;
1213 /* This is how C code calls `yes-or-no-p' and allows the user
1216 Anything that calls this function must protect from GC! */
1219 do_yes_or_no_p (prompt
)
1222 return call1 (intern ("yes-or-no-p"), prompt
);
1225 /* Anything that calls this function must protect from GC! */
1227 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1228 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1229 Takes one argument, which is the string to display to ask the question.\n\
1230 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1231 The user must confirm the answer with RET,\n\
1232 and can edit it until it as been confirmed.")
1236 register Lisp_Object ans
;
1237 Lisp_Object args
[2];
1238 struct gcpro gcpro1
;
1241 CHECK_STRING (prompt
, 0);
1244 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1247 Lisp_Object pane
, menu
, obj
;
1248 redisplay_preserve_echo_area ();
1249 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1250 Fcons (Fcons (build_string ("No"), Qnil
),
1253 menu
= Fcons (prompt
, pane
);
1254 obj
= Fx_popup_dialog (Qt
, menu
);
1261 args
[1] = build_string ("(yes or no) ");
1262 prompt
= Fconcat (2, args
);
1268 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1269 Qyes_or_no_p_history
));
1270 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1275 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1283 message ("Please answer yes or no.");
1284 Fsleep_for (make_number (2), Qnil
);
1288 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1289 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1290 Each of the three load averages is multiplied by 100,\n\
1291 then converted to integer.\n\
1292 If the 5-minute or 15-minute load averages are not available, return a\n\
1293 shortened list, containing only those averages which are available.")
1297 int loads
= getloadavg (load_ave
, 3);
1301 error ("load-average not implemented for this operating system");
1305 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1310 Lisp_Object Vfeatures
;
1312 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1313 "Returns t if FEATURE is present in this Emacs.\n\
1314 Use this to conditionalize execution of lisp code based on the presence or\n\
1315 absence of emacs or environment extensions.\n\
1316 Use `provide' to declare that a feature is available.\n\
1317 This function looks at the value of the variable `features'.")
1319 Lisp_Object feature
;
1321 register Lisp_Object tem
;
1322 CHECK_SYMBOL (feature
, 0);
1323 tem
= Fmemq (feature
, Vfeatures
);
1324 return (NILP (tem
)) ? Qnil
: Qt
;
1327 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1328 "Announce that FEATURE is a feature of the current Emacs.")
1330 Lisp_Object feature
;
1332 register Lisp_Object tem
;
1333 CHECK_SYMBOL (feature
, 0);
1334 if (!NILP (Vautoload_queue
))
1335 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1336 tem
= Fmemq (feature
, Vfeatures
);
1338 Vfeatures
= Fcons (feature
, Vfeatures
);
1339 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1343 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1344 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1345 If FEATURE is not a member of the list `features', then the feature\n\
1346 is not loaded; so load the file FILENAME.\n\
1347 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1348 (feature
, file_name
)
1349 Lisp_Object feature
, file_name
;
1351 register Lisp_Object tem
;
1352 CHECK_SYMBOL (feature
, 0);
1353 tem
= Fmemq (feature
, Vfeatures
);
1354 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1357 int count
= specpdl_ptr
- specpdl
;
1359 /* Value saved here is to be restored into Vautoload_queue */
1360 record_unwind_protect (un_autoload
, Vautoload_queue
);
1361 Vautoload_queue
= Qt
;
1363 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1366 tem
= Fmemq (feature
, Vfeatures
);
1368 error ("Required feature %s was not provided",
1369 XSYMBOL (feature
)->name
->data
);
1371 /* Once loading finishes, don't undo it. */
1372 Vautoload_queue
= Qt
;
1373 feature
= unbind_to (count
, feature
);
1380 Qstring_lessp
= intern ("string-lessp");
1381 staticpro (&Qstring_lessp
);
1382 Qprovide
= intern ("provide");
1383 staticpro (&Qprovide
);
1384 Qrequire
= intern ("require");
1385 staticpro (&Qrequire
);
1386 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1387 staticpro (&Qyes_or_no_p_history
);
1389 DEFVAR_LISP ("features", &Vfeatures
,
1390 "A list of symbols which are the features of the executing emacs.\n\
1391 Used by `featurep' and `require', and altered by `provide'.");
1394 defsubr (&Sidentity
);
1397 defsubr (&Sstring_equal
);
1398 defsubr (&Sstring_lessp
);
1401 defsubr (&Svconcat
);
1402 defsubr (&Scopy_sequence
);
1403 defsubr (&Scopy_alist
);
1404 defsubr (&Ssubstring
);
1415 defsubr (&Snreverse
);
1416 defsubr (&Sreverse
);
1421 defsubr (&Sfillarray
);
1424 defsubr (&Smapconcat
);
1425 defsubr (&Sy_or_n_p
);
1426 defsubr (&Syes_or_no_p
);
1427 defsubr (&Sload_average
);
1428 defsubr (&Sfeaturep
);
1429 defsubr (&Srequire
);
1430 defsubr (&Sprovide
);