1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
24 /* Note on some machines this defines `vector' as a typedef,
25 so make sure we don't use that name in this file. */
35 #include "intervals.h"
40 #define NULL (void *)0
43 /* Nonzero enables use of dialog boxes for questions
44 asked by mouse commands. */
47 extern Lisp_Object
Flookup_key ();
49 extern int minibuffer_auto_raise
;
50 extern Lisp_Object minibuf_window
;
52 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
53 Lisp_Object Qyes_or_no_p_history
;
54 Lisp_Object Qcursor_in_echo_area
;
56 static int internal_equal ();
58 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
59 "Return the argument unchanged.")
66 extern long get_random ();
67 extern void seed_random ();
70 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
71 "Return a pseudo-random number.\n\
72 All integers representable in Lisp are equally likely.\n\
73 On most systems, this is 28 bits' worth.\n\
74 With positive integer argument N, return random number in interval [0,N).\n\
75 With argument t, set the random number seed from the current time and pid.")
80 Lisp_Object lispy_val
;
81 unsigned long denominator
;
84 seed_random (getpid () + time (NULL
));
85 if (NATNUMP (n
) && XFASTINT (n
) != 0)
87 /* Try to take our random number from the higher bits of VAL,
88 not the lower, since (says Gentzel) the low bits of `random'
89 are less random than the higher ones. We do this by using the
90 quotient rather than the remainder. At the high end of the RNG
91 it's possible to get a quotient larger than n; discarding
92 these values eliminates the bias that would otherwise appear
93 when using a large n. */
94 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
96 val
= get_random () / denominator
;
97 while (val
>= XFASTINT (n
));
101 XSETINT (lispy_val
, val
);
105 /* Random data-structure functions */
107 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
108 "Return the length of vector, list or string SEQUENCE.\n\
109 A byte-code function object is also allowed.")
111 register Lisp_Object sequence
;
113 register Lisp_Object tail
, val
;
117 if (STRINGP (sequence
))
118 XSETFASTINT (val
, XSTRING (sequence
)->size
);
119 else if (VECTORP (sequence
))
120 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
121 else if (CHAR_TABLE_P (sequence
))
122 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
123 else if (BOOL_VECTOR_P (sequence
))
124 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
125 else if (COMPILEDP (sequence
))
126 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
127 else if (CONSP (sequence
))
129 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
135 XSETFASTINT (val
, i
);
137 else if (NILP (sequence
))
138 XSETFASTINT (val
, 0);
141 sequence
= wrong_type_argument (Qsequencep
, sequence
);
147 /* This does not check for quits. That is safe
148 since it must terminate. */
150 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
151 "Return the length of a list, but avoid error or infinite loop.\n\
152 This function never gets an error. If LIST is not really a list,\n\
153 it returns 0. If LIST is circular, it returns a finite value\n\
154 which is at least the number of distinct elements.")
158 Lisp_Object tail
, halftail
, length
;
161 /* halftail is used to detect circular lists. */
163 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
165 if (EQ (tail
, halftail
) && len
!= 0)
169 halftail
= XCONS (halftail
)->cdr
;
172 XSETINT (length
, len
);
176 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
177 "T if two strings have identical contents.\n\
178 Case is significant, but text properties are ignored.\n\
179 Symbols are also allowed; their print names are used instead.")
181 register Lisp_Object s1
, s2
;
184 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
186 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
187 CHECK_STRING (s1
, 0);
188 CHECK_STRING (s2
, 1);
190 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
191 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
196 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
197 "T if first arg string is less than second in lexicographic order.\n\
198 Case is significant.\n\
199 Symbols are also allowed; their print names are used instead.")
201 register Lisp_Object s1
, s2
;
204 register unsigned char *p1
, *p2
;
208 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
210 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
211 CHECK_STRING (s1
, 0);
212 CHECK_STRING (s2
, 1);
214 p1
= XSTRING (s1
)->data
;
215 p2
= XSTRING (s2
)->data
;
216 end
= XSTRING (s1
)->size
;
217 if (end
> XSTRING (s2
)->size
)
218 end
= XSTRING (s2
)->size
;
220 for (i
= 0; i
< end
; i
++)
223 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
225 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
228 static Lisp_Object
concat ();
239 return concat (2, args
, Lisp_String
, 0);
241 return concat (2, &s1
, Lisp_String
, 0);
242 #endif /* NO_ARG_ARRAY */
248 Lisp_Object s1
, s2
, s3
;
255 return concat (3, args
, Lisp_String
, 0);
257 return concat (3, &s1
, Lisp_String
, 0);
258 #endif /* NO_ARG_ARRAY */
261 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
262 "Concatenate all the arguments and make the result a list.\n\
263 The result is a list whose elements are the elements of all the arguments.\n\
264 Each argument may be a list, vector or string.\n\
265 The last argument is not copied, just used as the tail of the new list.")
270 return concat (nargs
, args
, Lisp_Cons
, 1);
273 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
274 "Concatenate all the arguments and make the result a string.\n\
275 The result is a string whose elements are the elements of all the arguments.\n\
276 Each argument may be a string or a list or vector of characters (integers).\n\
278 Do not use individual integers as arguments!\n\
279 The behavior of `concat' in that case will be changed later!\n\
280 If your program passes an integer as an argument to `concat',\n\
281 you should change it right away not to do so.")
286 return concat (nargs
, args
, Lisp_String
, 0);
289 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
290 "Concatenate all the arguments and make the result a vector.\n\
291 The result is a vector whose elements are the elements of all the arguments.\n\
292 Each argument may be a list, vector or string.")
297 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
300 /* Retrun a copy of a sub char table ARG. The elements except for a
301 nested sub char table are not copied. */
303 copy_sub_char_table (arg
)
306 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
309 /* Copy all the contents. */
310 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
311 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
312 /* Recursively copy any sub char-tables in the ordinary slots. */
313 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
314 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
315 XCHAR_TABLE (copy
)->contents
[i
]
316 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
322 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
323 "Return a copy of a list, vector or string.\n\
324 The elements of a list or vector are not copied; they are shared\n\
329 if (NILP (arg
)) return arg
;
331 if (CHAR_TABLE_P (arg
))
336 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
337 /* Copy all the slots, including the extra ones. */
338 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
339 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
340 * sizeof (Lisp_Object
)));
342 /* Recursively copy any sub char tables in the ordinary slots
343 for multibyte characters. */
344 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
345 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
346 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
347 XCHAR_TABLE (copy
)->contents
[i
]
348 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
353 if (BOOL_VECTOR_P (arg
))
357 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
359 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
360 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
365 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
366 arg
= wrong_type_argument (Qsequencep
, arg
);
367 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
371 concat (nargs
, args
, target_type
, last_special
)
374 enum Lisp_Type target_type
;
379 register Lisp_Object tail
;
380 register Lisp_Object
this;
384 Lisp_Object last_tail
;
387 /* In append, the last arg isn't treated like the others */
388 if (last_special
&& nargs
> 0)
391 last_tail
= args
[nargs
];
396 for (argnum
= 0; argnum
< nargs
; argnum
++)
399 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
400 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
403 args
[argnum
] = Fnumber_to_string (this);
405 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
409 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
412 len
= Flength (this);
413 if (VECTORP (this) && target_type
== Lisp_String
)
415 /* We must pay attention to a multibyte character which
416 takes more than one byte in string. */
420 for (i
= 0; i
< XFASTINT (len
); i
++)
422 ch
= XVECTOR (this)->contents
[i
];
424 wrong_type_argument (Qintegerp
, ch
);
425 leni
+= Fchar_bytes (ch
);
429 leni
+= XFASTINT (len
);
432 XSETFASTINT (len
, leni
);
434 if (target_type
== Lisp_Cons
)
435 val
= Fmake_list (len
, Qnil
);
436 else if (target_type
== Lisp_Vectorlike
)
437 val
= Fmake_vector (len
, Qnil
);
439 val
= Fmake_string (len
, len
);
441 /* In append, if all but last arg are nil, return last arg */
442 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
446 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
452 for (argnum
= 0; argnum
< nargs
; argnum
++)
456 register unsigned int thisindex
= 0;
460 thislen
= Flength (this), thisleni
= XINT (thislen
);
462 if (STRINGP (this) && STRINGP (val
)
463 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
465 copy_text_properties (make_number (0), thislen
, this,
466 make_number (toindex
), val
, Qnil
);
471 register Lisp_Object elt
;
473 /* Fetch next element of `this' arg into `elt', or break if
474 `this' is exhausted. */
475 if (NILP (this)) break;
477 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
480 if (thisindex
>= thisleni
) break;
482 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
483 else if (BOOL_VECTOR_P (this))
486 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
489 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
490 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
496 elt
= XVECTOR (this)->contents
[thisindex
++];
499 /* Store into result */
502 XCONS (tail
)->car
= elt
;
504 tail
= XCONS (tail
)->cdr
;
506 else if (VECTORP (val
))
507 XVECTOR (val
)->contents
[toindex
++] = elt
;
510 while (!INTEGERP (elt
))
511 elt
= wrong_type_argument (Qintegerp
, elt
);
514 unsigned char work
[4], *str
;
515 int i
= CHAR_STRING (c
, work
, str
);
517 #ifdef MASSC_REGISTER_BUG
518 /* Even removing all "register"s doesn't disable this bug!
519 Nothing simpler than this seems to work. */
520 unsigned char *p
= & XSTRING (val
)->data
[toindex
];
523 bcopy (str
, & XSTRING (val
)->data
[toindex
], i
);
531 XCONS (prev
)->cdr
= last_tail
;
536 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
537 "Return a copy of ALIST.\n\
538 This is an alist which represents the same mapping from objects to objects,\n\
539 but does not share the alist structure with ALIST.\n\
540 The objects mapped (cars and cdrs of elements of the alist)\n\
541 are shared, however.\n\
542 Elements of ALIST that are not conses are also shared.")
546 register Lisp_Object tem
;
548 CHECK_LIST (alist
, 0);
551 alist
= concat (1, &alist
, Lisp_Cons
, 0);
552 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
554 register Lisp_Object car
;
555 car
= XCONS (tem
)->car
;
558 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
563 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
564 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
565 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
566 If FROM or TO is negative, it counts from the end.\n\
568 This function allows vectors as well as strings.")
571 register Lisp_Object from
, to
;
576 if (! (STRINGP (string
) || VECTORP (string
)))
577 wrong_type_argument (Qarrayp
, string
);
579 CHECK_NUMBER (from
, 1);
581 if (STRINGP (string
))
582 size
= XSTRING (string
)->size
;
584 size
= XVECTOR (string
)->size
;
589 CHECK_NUMBER (to
, 2);
592 XSETINT (from
, XINT (from
) + size
);
594 XSETINT (to
, XINT (to
) + size
);
595 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
596 && XINT (to
) <= size
))
597 args_out_of_range_3 (string
, from
, to
);
599 if (STRINGP (string
))
601 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
602 XINT (to
) - XINT (from
));
603 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
606 res
= Fvector (XINT (to
) - XINT (from
),
607 XVECTOR (string
)->contents
+ XINT (from
));
612 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
613 "Take cdr N times on LIST, returns the result.")
616 register Lisp_Object list
;
621 for (i
= 0; i
< num
&& !NILP (list
); i
++)
629 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
630 "Return the Nth element of LIST.\n\
631 N counts from zero. If LIST is not that long, nil is returned.")
635 return Fcar (Fnthcdr (n
, list
));
638 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
639 "Return element of SEQUENCE at index N.")
641 register Lisp_Object sequence
, n
;
646 if (CONSP (sequence
) || NILP (sequence
))
647 return Fcar (Fnthcdr (n
, sequence
));
648 else if (STRINGP (sequence
) || VECTORP (sequence
)
649 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
650 return Faref (sequence
, n
);
652 sequence
= wrong_type_argument (Qsequencep
, sequence
);
656 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
657 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
658 The value is actually the tail of LIST whose car is ELT.")
660 register Lisp_Object elt
;
663 register Lisp_Object tail
;
664 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
666 register Lisp_Object tem
;
668 if (! NILP (Fequal (elt
, tem
)))
675 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
676 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
677 The value is actually the tail of LIST whose car is ELT.")
679 register Lisp_Object elt
;
682 register Lisp_Object tail
;
683 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
685 register Lisp_Object tem
;
687 if (EQ (elt
, tem
)) return tail
;
693 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
694 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
695 The value is actually the element of LIST whose car is KEY.\n\
696 Elements of LIST that are not conses are ignored.")
698 register Lisp_Object key
;
701 register Lisp_Object tail
;
702 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
704 register Lisp_Object elt
, tem
;
706 if (!CONSP (elt
)) continue;
707 tem
= XCONS (elt
)->car
;
708 if (EQ (key
, tem
)) return elt
;
714 /* Like Fassq but never report an error and do not allow quits.
715 Use only on lists known never to be circular. */
718 assq_no_quit (key
, list
)
719 register Lisp_Object key
;
722 register Lisp_Object tail
;
723 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
725 register Lisp_Object elt
, tem
;
727 if (!CONSP (elt
)) continue;
728 tem
= XCONS (elt
)->car
;
729 if (EQ (key
, tem
)) return elt
;
734 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
735 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
736 The value is actually the element of LIST whose car equals KEY.")
738 register Lisp_Object key
;
741 register Lisp_Object tail
;
742 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
744 register Lisp_Object elt
, tem
;
746 if (!CONSP (elt
)) continue;
747 tem
= Fequal (XCONS (elt
)->car
, key
);
748 if (!NILP (tem
)) return elt
;
754 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
755 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
756 The value is actually the element of LIST whose cdr is ELT.")
758 register Lisp_Object key
;
761 register Lisp_Object tail
;
762 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
764 register Lisp_Object elt
, tem
;
766 if (!CONSP (elt
)) continue;
767 tem
= XCONS (elt
)->cdr
;
768 if (EQ (key
, tem
)) return elt
;
774 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
775 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
776 The value is actually the element of LIST whose cdr equals KEY.")
778 register Lisp_Object key
;
781 register Lisp_Object tail
;
782 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
784 register Lisp_Object elt
, tem
;
786 if (!CONSP (elt
)) continue;
787 tem
= Fequal (XCONS (elt
)->cdr
, key
);
788 if (!NILP (tem
)) return elt
;
794 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
795 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
796 The modified LIST is returned. Comparison is done with `eq'.\n\
797 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
798 therefore, write `(setq foo (delq element foo))'\n\
799 to be sure of changing the value of `foo'.")
801 register Lisp_Object elt
;
804 register Lisp_Object tail
, prev
;
805 register Lisp_Object tem
;
815 list
= XCONS (tail
)->cdr
;
817 Fsetcdr (prev
, XCONS (tail
)->cdr
);
821 tail
= XCONS (tail
)->cdr
;
827 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
828 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
829 The modified LIST is returned. Comparison is done with `equal'.\n\
830 If the first member of LIST is ELT, deleting it is not a side effect;\n\
831 it is simply using a different list.\n\
832 Therefore, write `(setq foo (delete element foo))'\n\
833 to be sure of changing the value of `foo'.")
835 register Lisp_Object elt
;
838 register Lisp_Object tail
, prev
;
839 register Lisp_Object tem
;
846 if (! NILP (Fequal (elt
, tem
)))
849 list
= XCONS (tail
)->cdr
;
851 Fsetcdr (prev
, XCONS (tail
)->cdr
);
855 tail
= XCONS (tail
)->cdr
;
861 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
862 "Reverse LIST by modifying cdr pointers.\n\
863 Returns the beginning of the reversed list.")
867 register Lisp_Object prev
, tail
, next
;
869 if (NILP (list
)) return list
;
876 Fsetcdr (tail
, prev
);
883 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
884 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
885 See also the function `nreverse', which is used more often.")
891 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
892 new = Fcons (XCONS (list
)->car
, new);
894 wrong_type_argument (Qconsp
, list
);
898 Lisp_Object
merge ();
900 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
901 "Sort LIST, stably, comparing elements using PREDICATE.\n\
902 Returns the sorted list. LIST is modified by side effects.\n\
903 PREDICATE is called with two elements of LIST, and should return T\n\
904 if the first element is \"less\" than the second.")
906 Lisp_Object list
, predicate
;
908 Lisp_Object front
, back
;
909 register Lisp_Object len
, tem
;
910 struct gcpro gcpro1
, gcpro2
;
914 len
= Flength (list
);
919 XSETINT (len
, (length
/ 2) - 1);
920 tem
= Fnthcdr (len
, list
);
924 GCPRO2 (front
, back
);
925 front
= Fsort (front
, predicate
);
926 back
= Fsort (back
, predicate
);
928 return merge (front
, back
, predicate
);
932 merge (org_l1
, org_l2
, pred
)
933 Lisp_Object org_l1
, org_l2
;
937 register Lisp_Object tail
;
939 register Lisp_Object l1
, l2
;
940 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
947 /* It is sufficient to protect org_l1 and org_l2.
948 When l1 and l2 are updated, we copy the new values
949 back into the org_ vars. */
950 GCPRO4 (org_l1
, org_l2
, pred
, value
);
970 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
992 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
993 "Extract a value from a property list.\n\
994 PLIST is a property list, which is a list of the form\n\
995 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
996 corresponding to the given PROP, or nil if PROP is not\n\
997 one of the properties on the list.")
1000 register Lisp_Object prop
;
1002 register Lisp_Object tail
;
1003 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1005 register Lisp_Object tem
;
1008 return Fcar (XCONS (tail
)->cdr
);
1013 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1014 "Return the value of SYMBOL's PROPNAME property.\n\
1015 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1017 Lisp_Object symbol
, propname
;
1019 CHECK_SYMBOL (symbol
, 0);
1020 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1023 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1024 "Change value in PLIST of PROP to VAL.\n\
1025 PLIST is a property list, which is a list of the form\n\
1026 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1027 If PROP is already a property on the list, its value is set to VAL,\n\
1028 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1029 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1030 The PLIST is modified by side effects.")
1033 register Lisp_Object prop
;
1036 register Lisp_Object tail
, prev
;
1037 Lisp_Object newcell
;
1039 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1040 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1042 if (EQ (prop
, XCONS (tail
)->car
))
1044 Fsetcar (XCONS (tail
)->cdr
, val
);
1049 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1053 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1057 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1058 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1059 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1060 (symbol
, propname
, value
)
1061 Lisp_Object symbol
, propname
, value
;
1063 CHECK_SYMBOL (symbol
, 0);
1064 XSYMBOL (symbol
)->plist
1065 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1069 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1070 "T if two Lisp objects have similar structure and contents.\n\
1071 They must have the same data type.\n\
1072 Conses are compared by comparing the cars and the cdrs.\n\
1073 Vectors and strings are compared element by element.\n\
1074 Numbers are compared by value, but integers cannot equal floats.\n\
1075 (Use `=' if you want integers and floats to be able to be equal.)\n\
1076 Symbols must match exactly.")
1078 register Lisp_Object o1
, o2
;
1080 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1084 internal_equal (o1
, o2
, depth
)
1085 register Lisp_Object o1
, o2
;
1089 error ("Stack overflow in equal");
1095 if (XTYPE (o1
) != XTYPE (o2
))
1100 #ifdef LISP_FLOAT_TYPE
1102 return (extract_float (o1
) == extract_float (o2
));
1106 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1108 o1
= XCONS (o1
)->cdr
;
1109 o2
= XCONS (o2
)->cdr
;
1113 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1117 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1119 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1122 o1
= XOVERLAY (o1
)->plist
;
1123 o2
= XOVERLAY (o2
)->plist
;
1128 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1129 && (XMARKER (o1
)->buffer
== 0
1130 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1134 case Lisp_Vectorlike
:
1136 register int i
, size
;
1137 size
= XVECTOR (o1
)->size
;
1138 /* Pseudovectors have the type encoded in the size field, so this test
1139 actually checks that the objects have the same type as well as the
1141 if (XVECTOR (o2
)->size
!= size
)
1143 /* Boolvectors are compared much like strings. */
1144 if (BOOL_VECTOR_P (o1
))
1147 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1149 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1151 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1157 /* Aside from them, only true vectors, char-tables, and compiled
1158 functions are sensible to compare, so eliminate the others now. */
1159 if (size
& PSEUDOVECTOR_FLAG
)
1161 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1163 size
&= PSEUDOVECTOR_SIZE_MASK
;
1165 for (i
= 0; i
< size
; i
++)
1168 v1
= XVECTOR (o1
)->contents
[i
];
1169 v2
= XVECTOR (o2
)->contents
[i
];
1170 if (!internal_equal (v1
, v2
, depth
+ 1))
1178 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1180 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1181 XSTRING (o1
)->size
))
1188 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1189 "Store each element of ARRAY with ITEM.\n\
1190 ARRAY is a vector, string, char-table, or bool-vector.")
1192 Lisp_Object array
, item
;
1194 register int size
, index
, charval
;
1196 if (VECTORP (array
))
1198 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1199 size
= XVECTOR (array
)->size
;
1200 for (index
= 0; index
< size
; index
++)
1203 else if (CHAR_TABLE_P (array
))
1205 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1206 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1207 for (index
= 0; index
< size
; index
++)
1209 XCHAR_TABLE (array
)->defalt
= Qnil
;
1211 else if (STRINGP (array
))
1213 register unsigned char *p
= XSTRING (array
)->data
;
1214 CHECK_NUMBER (item
, 1);
1215 charval
= XINT (item
);
1216 size
= XSTRING (array
)->size
;
1217 for (index
= 0; index
< size
; index
++)
1220 else if (BOOL_VECTOR_P (array
))
1222 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1224 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1226 charval
= (! NILP (item
) ? -1 : 0);
1227 for (index
= 0; index
< size_in_chars
; index
++)
1232 array
= wrong_type_argument (Qarrayp
, array
);
1238 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1240 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1242 Lisp_Object char_table
;
1244 CHECK_CHAR_TABLE (char_table
, 0);
1246 return XCHAR_TABLE (char_table
)->purpose
;
1249 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1251 "Return the parent char-table of CHAR-TABLE.\n\
1252 The value is either nil or another char-table.\n\
1253 If CHAR-TABLE holds nil for a given character,\n\
1254 then the actual applicable value is inherited from the parent char-table\n\
1255 \(or from its parents, if necessary).")
1257 Lisp_Object char_table
;
1259 CHECK_CHAR_TABLE (char_table
, 0);
1261 return XCHAR_TABLE (char_table
)->parent
;
1264 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1266 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1267 PARENT must be either nil or another char-table.")
1268 (char_table
, parent
)
1269 Lisp_Object char_table
, parent
;
1273 CHECK_CHAR_TABLE (char_table
, 0);
1277 CHECK_CHAR_TABLE (parent
, 0);
1279 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1280 if (EQ (temp
, char_table
))
1281 error ("Attempt to make a chartable be its own parent");
1284 XCHAR_TABLE (char_table
)->parent
= parent
;
1289 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1291 "Return the value of CHAR-TABLE's extra-slot number N.")
1293 Lisp_Object char_table
, n
;
1295 CHECK_CHAR_TABLE (char_table
, 1);
1296 CHECK_NUMBER (n
, 2);
1298 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1299 args_out_of_range (char_table
, n
);
1301 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1304 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1305 Sset_char_table_extra_slot
,
1307 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1308 (char_table
, n
, value
)
1309 Lisp_Object char_table
, n
, value
;
1311 CHECK_CHAR_TABLE (char_table
, 1);
1312 CHECK_NUMBER (n
, 2);
1314 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1315 args_out_of_range (char_table
, n
);
1317 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1320 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1322 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1323 RANGE should be t (for all characters), nil (for the default value)\n\
1324 a vector which identifies a character set or a row of a character set,\n\
1325 or a character code.")
1327 Lisp_Object char_table
, range
;
1331 CHECK_CHAR_TABLE (char_table
, 0);
1333 if (EQ (range
, Qnil
))
1334 return XCHAR_TABLE (char_table
)->defalt
;
1335 else if (INTEGERP (range
))
1336 return Faref (char_table
, range
);
1337 else if (VECTORP (range
))
1339 if (XVECTOR (range
)->size
== 1)
1340 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1343 int size
= XVECTOR (range
)->size
;
1344 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1345 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1346 size
<= 1 ? Qnil
: val
[1],
1347 size
<= 2 ? Qnil
: val
[2]);
1348 return Faref (char_table
, ch
);
1352 error ("Invalid RANGE argument to `char-table-range'");
1355 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1357 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1358 RANGE should be t (for all characters), nil (for the default value)\n\
1359 a vector which identifies a character set or a row of a character set,\n\
1360 or a character code.")
1361 (char_table
, range
, value
)
1362 Lisp_Object char_table
, range
, value
;
1366 CHECK_CHAR_TABLE (char_table
, 0);
1369 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1370 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1371 else if (EQ (range
, Qnil
))
1372 XCHAR_TABLE (char_table
)->defalt
= value
;
1373 else if (INTEGERP (range
))
1374 Faset (char_table
, range
, value
);
1375 else if (VECTORP (range
))
1377 if (XVECTOR (range
)->size
== 1)
1378 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1381 int size
= XVECTOR (range
)->size
;
1382 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1383 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1384 size
<= 1 ? Qnil
: val
[1],
1385 size
<= 2 ? Qnil
: val
[2]);
1386 return Faset (char_table
, ch
, value
);
1390 error ("Invalid RANGE argument to `set-char-table-range'");
1395 DEFUN ("set-char-table-default", Fset_char_table_default
,
1396 Sset_char_table_default
, 3, 3, 0,
1397 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1398 The generic character specifies the group of characters.\n\
1399 See also the documentation of make-char.")
1400 (char_table
, ch
, value
)
1401 Lisp_Object char_table
, ch
, value
;
1403 int c
, i
, charset
, code1
, code2
;
1406 CHECK_CHAR_TABLE (char_table
, 0);
1407 CHECK_NUMBER (ch
, 1);
1410 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1411 if (! CHARSET_DEFINED_P (charset
))
1412 error ("Invalid character: %d", c
);
1414 if (charset
== CHARSET_ASCII
)
1415 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1417 /* Even if C is not a generic char, we had better behave as if a
1418 generic char is specified. */
1419 if (CHARSET_DIMENSION (charset
) == 1)
1421 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1424 if (SUB_CHAR_TABLE_P (temp
))
1425 XCHAR_TABLE (temp
)->defalt
= value
;
1427 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1431 if (! SUB_CHAR_TABLE_P (char_table
))
1432 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1433 = make_sub_char_table (temp
));
1434 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1435 if (SUB_CHAR_TABLE_P (temp
))
1436 XCHAR_TABLE (temp
)->defalt
= value
;
1438 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1443 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1444 character or group of characters that share a value.
1445 DEPTH is the current depth in the originally specified
1446 chartable, and INDICES contains the vector indices
1447 for the levels our callers have descended.
1449 ARG is passed to C_FUNCTION when that is called. */
1452 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1453 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1460 /* At first, handle ASCII and 8-bit European characters. */
1461 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1463 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1465 (*c_function
) (arg
, make_number (i
), elt
);
1467 call2 (function
, make_number (i
), elt
);
1469 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1474 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1479 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1481 XSETFASTINT (indices
[depth
], i
);
1483 if (SUB_CHAR_TABLE_P (elt
))
1486 error ("Too deep char table");
1487 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1491 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1493 if (CHARSET_DEFINED_P (charset
))
1495 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1496 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1497 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1499 (*c_function
) (arg
, make_number (c
), elt
);
1501 call2 (function
, make_number (c
), elt
);
1507 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1509 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1510 FUNCTION is called with two arguments--a key and a value.\n\
1511 The key is always a possible IDX argument to `aref'.")
1512 (function
, char_table
)
1513 Lisp_Object function
, char_table
;
1515 /* The depth of char table is at most 3. */
1516 Lisp_Object indices
[3];
1518 CHECK_CHAR_TABLE (char_table
, 1);
1520 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1530 Lisp_Object args
[2];
1533 return Fnconc (2, args
);
1535 return Fnconc (2, &s1
);
1536 #endif /* NO_ARG_ARRAY */
1539 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1540 "Concatenate any number of lists by altering them.\n\
1541 Only the last argument is not altered, and need not be a list.")
1546 register int argnum
;
1547 register Lisp_Object tail
, tem
, val
;
1551 for (argnum
= 0; argnum
< nargs
; argnum
++)
1554 if (NILP (tem
)) continue;
1559 if (argnum
+ 1 == nargs
) break;
1562 tem
= wrong_type_argument (Qlistp
, tem
);
1571 tem
= args
[argnum
+ 1];
1572 Fsetcdr (tail
, tem
);
1574 args
[argnum
+ 1] = tail
;
1580 /* This is the guts of all mapping functions.
1581 Apply fn to each element of seq, one by one,
1582 storing the results into elements of vals, a C vector of Lisp_Objects.
1583 leni is the length of vals, which should also be the length of seq. */
1586 mapcar1 (leni
, vals
, fn
, seq
)
1589 Lisp_Object fn
, seq
;
1591 register Lisp_Object tail
;
1594 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1596 /* Don't let vals contain any garbage when GC happens. */
1597 for (i
= 0; i
< leni
; i
++)
1600 GCPRO3 (dummy
, fn
, seq
);
1602 gcpro1
.nvars
= leni
;
1603 /* We need not explicitly protect `tail' because it is used only on lists, and
1604 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1608 for (i
= 0; i
< leni
; i
++)
1610 dummy
= XVECTOR (seq
)->contents
[i
];
1611 vals
[i
] = call1 (fn
, dummy
);
1614 else if (STRINGP (seq
))
1616 for (i
= 0; i
< leni
; i
++)
1618 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1619 vals
[i
] = call1 (fn
, dummy
);
1622 else /* Must be a list, since Flength did not get an error */
1625 for (i
= 0; i
< leni
; i
++)
1627 vals
[i
] = call1 (fn
, Fcar (tail
));
1628 tail
= XCONS (tail
)->cdr
;
1635 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1636 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1637 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1638 SEPARATOR results in spaces between the values returned by FUNCTION.")
1639 (function
, sequence
, separator
)
1640 Lisp_Object function
, sequence
, separator
;
1645 register Lisp_Object
*args
;
1647 struct gcpro gcpro1
;
1649 len
= Flength (sequence
);
1651 nargs
= leni
+ leni
- 1;
1652 if (nargs
< 0) return build_string ("");
1654 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1657 mapcar1 (leni
, args
, function
, sequence
);
1660 for (i
= leni
- 1; i
>= 0; i
--)
1661 args
[i
+ i
] = args
[i
];
1663 for (i
= 1; i
< nargs
; i
+= 2)
1664 args
[i
] = separator
;
1666 return Fconcat (nargs
, args
);
1669 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1670 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1671 The result is a list just as long as SEQUENCE.\n\
1672 SEQUENCE may be a list, a vector or a string.")
1673 (function
, sequence
)
1674 Lisp_Object function
, sequence
;
1676 register Lisp_Object len
;
1678 register Lisp_Object
*args
;
1680 len
= Flength (sequence
);
1681 leni
= XFASTINT (len
);
1682 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1684 mapcar1 (leni
, args
, function
, sequence
);
1686 return Flist (leni
, args
);
1689 /* Anything that calls this function must protect from GC! */
1691 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1692 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1693 Takes one argument, which is the string to display to ask the question.\n\
1694 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1695 No confirmation of the answer is requested; a single character is enough.\n\
1696 Also accepts Space to mean yes, or Delete to mean no.")
1700 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1701 register int answer
;
1702 Lisp_Object xprompt
;
1703 Lisp_Object args
[2];
1704 struct gcpro gcpro1
, gcpro2
;
1705 int count
= specpdl_ptr
- specpdl
;
1707 specbind (Qcursor_in_echo_area
, Qt
);
1709 map
= Fsymbol_value (intern ("query-replace-map"));
1711 CHECK_STRING (prompt
, 0);
1713 GCPRO2 (prompt
, xprompt
);
1720 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1724 Lisp_Object pane
, menu
;
1725 redisplay_preserve_echo_area ();
1726 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1727 Fcons (Fcons (build_string ("No"), Qnil
),
1729 menu
= Fcons (prompt
, pane
);
1730 obj
= Fx_popup_dialog (Qt
, menu
);
1731 answer
= !NILP (obj
);
1734 #endif /* HAVE_MENUS */
1735 cursor_in_echo_area
= 1;
1736 choose_minibuf_frame ();
1737 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1739 if (minibuffer_auto_raise
)
1741 Lisp_Object mini_frame
;
1743 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1745 Fraise_frame (mini_frame
);
1748 obj
= read_filtered_event (1, 0, 0);
1749 cursor_in_echo_area
= 0;
1750 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1753 key
= Fmake_vector (make_number (1), obj
);
1754 def
= Flookup_key (map
, key
, Qt
);
1755 answer_string
= Fsingle_key_description (obj
);
1757 if (EQ (def
, intern ("skip")))
1762 else if (EQ (def
, intern ("act")))
1767 else if (EQ (def
, intern ("recenter")))
1773 else if (EQ (def
, intern ("quit")))
1775 /* We want to exit this command for exit-prefix,
1776 and this is the only way to do it. */
1777 else if (EQ (def
, intern ("exit-prefix")))
1782 /* If we don't clear this, then the next call to read_char will
1783 return quit_char again, and we'll enter an infinite loop. */
1788 if (EQ (xprompt
, prompt
))
1790 args
[0] = build_string ("Please answer y or n. ");
1792 xprompt
= Fconcat (2, args
);
1797 if (! noninteractive
)
1799 cursor_in_echo_area
= -1;
1800 message_nolog ("%s(y or n) %c",
1801 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1804 unbind_to (count
, Qnil
);
1805 return answer
? Qt
: Qnil
;
1808 /* This is how C code calls `yes-or-no-p' and allows the user
1811 Anything that calls this function must protect from GC! */
1814 do_yes_or_no_p (prompt
)
1817 return call1 (intern ("yes-or-no-p"), prompt
);
1820 /* Anything that calls this function must protect from GC! */
1822 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1823 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1824 Takes one argument, which is the string to display to ask the question.\n\
1825 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1826 The user must confirm the answer with RET,\n\
1827 and can edit it until it has been confirmed.")
1831 register Lisp_Object ans
;
1832 Lisp_Object args
[2];
1833 struct gcpro gcpro1
;
1836 CHECK_STRING (prompt
, 0);
1839 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1843 Lisp_Object pane
, menu
, obj
;
1844 redisplay_preserve_echo_area ();
1845 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1846 Fcons (Fcons (build_string ("No"), Qnil
),
1849 menu
= Fcons (prompt
, pane
);
1850 obj
= Fx_popup_dialog (Qt
, menu
);
1854 #endif /* HAVE_MENUS */
1857 args
[1] = build_string ("(yes or no) ");
1858 prompt
= Fconcat (2, args
);
1864 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1865 Qyes_or_no_p_history
, Qnil
));
1866 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1871 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1879 message ("Please answer yes or no.");
1880 Fsleep_for (make_number (2), Qnil
);
1884 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1885 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1886 Each of the three load averages is multiplied by 100,\n\
1887 then converted to integer.\n\
1888 If the 5-minute or 15-minute load averages are not available, return a\n\
1889 shortened list, containing only those averages which are available.")
1893 int loads
= getloadavg (load_ave
, 3);
1897 error ("load-average not implemented for this operating system");
1901 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1906 Lisp_Object Vfeatures
;
1908 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1909 "Returns t if FEATURE is present in this Emacs.\n\
1910 Use this to conditionalize execution of lisp code based on the presence or\n\
1911 absence of emacs or environment extensions.\n\
1912 Use `provide' to declare that a feature is available.\n\
1913 This function looks at the value of the variable `features'.")
1915 Lisp_Object feature
;
1917 register Lisp_Object tem
;
1918 CHECK_SYMBOL (feature
, 0);
1919 tem
= Fmemq (feature
, Vfeatures
);
1920 return (NILP (tem
)) ? Qnil
: Qt
;
1923 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1924 "Announce that FEATURE is a feature of the current Emacs.")
1926 Lisp_Object feature
;
1928 register Lisp_Object tem
;
1929 CHECK_SYMBOL (feature
, 0);
1930 if (!NILP (Vautoload_queue
))
1931 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1932 tem
= Fmemq (feature
, Vfeatures
);
1934 Vfeatures
= Fcons (feature
, Vfeatures
);
1935 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1939 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1940 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1941 If FEATURE is not a member of the list `features', then the feature\n\
1942 is not loaded; so load the file FILENAME.\n\
1943 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1944 (feature
, file_name
)
1945 Lisp_Object feature
, file_name
;
1947 register Lisp_Object tem
;
1948 CHECK_SYMBOL (feature
, 0);
1949 tem
= Fmemq (feature
, Vfeatures
);
1950 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1953 int count
= specpdl_ptr
- specpdl
;
1955 /* Value saved here is to be restored into Vautoload_queue */
1956 record_unwind_protect (un_autoload
, Vautoload_queue
);
1957 Vautoload_queue
= Qt
;
1959 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1962 tem
= Fmemq (feature
, Vfeatures
);
1964 error ("Required feature %s was not provided",
1965 XSYMBOL (feature
)->name
->data
);
1967 /* Once loading finishes, don't undo it. */
1968 Vautoload_queue
= Qt
;
1969 feature
= unbind_to (count
, feature
);
1976 Qstring_lessp
= intern ("string-lessp");
1977 staticpro (&Qstring_lessp
);
1978 Qprovide
= intern ("provide");
1979 staticpro (&Qprovide
);
1980 Qrequire
= intern ("require");
1981 staticpro (&Qrequire
);
1982 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1983 staticpro (&Qyes_or_no_p_history
);
1984 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1985 staticpro (&Qcursor_in_echo_area
);
1987 Fset (Qyes_or_no_p_history
, Qnil
);
1989 DEFVAR_LISP ("features", &Vfeatures
,
1990 "A list of symbols which are the features of the executing emacs.\n\
1991 Used by `featurep' and `require', and altered by `provide'.");
1994 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
1995 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
1996 This applies to y-or-n and yes-or-no questions asked by commands
1997 invoked by mouse clicks and mouse menu items.");
2000 defsubr (&Sidentity
);
2003 defsubr (&Ssafe_length
);
2004 defsubr (&Sstring_equal
);
2005 defsubr (&Sstring_lessp
);
2008 defsubr (&Svconcat
);
2009 defsubr (&Scopy_sequence
);
2010 defsubr (&Scopy_alist
);
2011 defsubr (&Ssubstring
);
2023 defsubr (&Snreverse
);
2024 defsubr (&Sreverse
);
2026 defsubr (&Splist_get
);
2028 defsubr (&Splist_put
);
2031 defsubr (&Sfillarray
);
2032 defsubr (&Schar_table_subtype
);
2033 defsubr (&Schar_table_parent
);
2034 defsubr (&Sset_char_table_parent
);
2035 defsubr (&Schar_table_extra_slot
);
2036 defsubr (&Sset_char_table_extra_slot
);
2037 defsubr (&Schar_table_range
);
2038 defsubr (&Sset_char_table_range
);
2039 defsubr (&Sset_char_table_default
);
2040 defsubr (&Smap_char_table
);
2043 defsubr (&Smapconcat
);
2044 defsubr (&Sy_or_n_p
);
2045 defsubr (&Syes_or_no_p
);
2046 defsubr (&Sload_average
);
2047 defsubr (&Sfeaturep
);
2048 defsubr (&Srequire
);
2049 defsubr (&Sprovide
);