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 extern Lisp_Object
Fmake_char_internal ();
1190 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1191 "Store each element of ARRAY with ITEM.\n\
1192 ARRAY is a vector, string, char-table, or bool-vector.")
1194 Lisp_Object array
, item
;
1196 register int size
, index
, charval
;
1198 if (VECTORP (array
))
1200 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1201 size
= XVECTOR (array
)->size
;
1202 for (index
= 0; index
< size
; index
++)
1205 else if (CHAR_TABLE_P (array
))
1207 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1208 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1209 for (index
= 0; index
< size
; index
++)
1211 XCHAR_TABLE (array
)->defalt
= Qnil
;
1213 else if (STRINGP (array
))
1215 register unsigned char *p
= XSTRING (array
)->data
;
1216 CHECK_NUMBER (item
, 1);
1217 charval
= XINT (item
);
1218 size
= XSTRING (array
)->size
;
1219 for (index
= 0; index
< size
; index
++)
1222 else if (BOOL_VECTOR_P (array
))
1224 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1226 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1228 charval
= (! NILP (item
) ? -1 : 0);
1229 for (index
= 0; index
< size_in_chars
; index
++)
1234 array
= wrong_type_argument (Qarrayp
, array
);
1240 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1242 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1244 Lisp_Object char_table
;
1246 CHECK_CHAR_TABLE (char_table
, 0);
1248 return XCHAR_TABLE (char_table
)->purpose
;
1251 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1253 "Return the parent char-table of CHAR-TABLE.\n\
1254 The value is either nil or another char-table.\n\
1255 If CHAR-TABLE holds nil for a given character,\n\
1256 then the actual applicable value is inherited from the parent char-table\n\
1257 \(or from its parents, if necessary).")
1259 Lisp_Object char_table
;
1261 CHECK_CHAR_TABLE (char_table
, 0);
1263 return XCHAR_TABLE (char_table
)->parent
;
1266 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1268 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1269 PARENT must be either nil or another char-table.")
1270 (char_table
, parent
)
1271 Lisp_Object char_table
, parent
;
1275 CHECK_CHAR_TABLE (char_table
, 0);
1279 CHECK_CHAR_TABLE (parent
, 0);
1281 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1282 if (EQ (temp
, char_table
))
1283 error ("Attempt to make a chartable be its own parent");
1286 XCHAR_TABLE (char_table
)->parent
= parent
;
1291 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1293 "Return the value of CHAR-TABLE's extra-slot number N.")
1295 Lisp_Object char_table
, n
;
1297 CHECK_CHAR_TABLE (char_table
, 1);
1298 CHECK_NUMBER (n
, 2);
1300 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1301 args_out_of_range (char_table
, n
);
1303 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1306 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1307 Sset_char_table_extra_slot
,
1309 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1310 (char_table
, n
, value
)
1311 Lisp_Object char_table
, n
, value
;
1313 CHECK_CHAR_TABLE (char_table
, 1);
1314 CHECK_NUMBER (n
, 2);
1316 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1317 args_out_of_range (char_table
, n
);
1319 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1322 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1324 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1325 RANGE should be t (for all characters), nil (for the default value)\n\
1326 a vector which identifies a character set or a row of a character set,\n\
1327 or a character code.")
1329 Lisp_Object char_table
, range
;
1333 CHECK_CHAR_TABLE (char_table
, 0);
1335 if (EQ (range
, Qnil
))
1336 return XCHAR_TABLE (char_table
)->defalt
;
1337 else if (INTEGERP (range
))
1338 return Faref (char_table
, range
);
1339 else if (VECTORP (range
))
1341 if (XVECTOR (range
)->size
== 1)
1342 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1345 int size
= XVECTOR (range
)->size
;
1346 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1347 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1348 size
<= 1 ? Qnil
: val
[1],
1349 size
<= 2 ? Qnil
: val
[2]);
1350 return Faref (char_table
, ch
);
1354 error ("Invalid RANGE argument to `char-table-range'");
1357 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1359 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1360 RANGE should be t (for all characters), nil (for the default value)\n\
1361 a vector which identifies a character set or a row of a character set,\n\
1362 or a character code.")
1363 (char_table
, range
, value
)
1364 Lisp_Object char_table
, range
, value
;
1368 CHECK_CHAR_TABLE (char_table
, 0);
1371 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1372 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1373 else if (EQ (range
, Qnil
))
1374 XCHAR_TABLE (char_table
)->defalt
= value
;
1375 else if (INTEGERP (range
))
1376 Faset (char_table
, range
, value
);
1377 else if (VECTORP (range
))
1379 if (XVECTOR (range
)->size
== 1)
1380 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1383 int size
= XVECTOR (range
)->size
;
1384 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1385 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1386 size
<= 1 ? Qnil
: val
[1],
1387 size
<= 2 ? Qnil
: val
[2]);
1388 return Faset (char_table
, ch
, value
);
1392 error ("Invalid RANGE argument to `set-char-table-range'");
1397 DEFUN ("set-char-table-default", Fset_char_table_default
,
1398 Sset_char_table_default
, 3, 3, 0,
1399 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1400 The generic character specifies the group of characters.\n\
1401 See also the documentation of make-char.")
1402 (char_table
, ch
, value
)
1403 Lisp_Object char_table
, ch
, value
;
1405 int c
, i
, charset
, code1
, code2
;
1408 CHECK_CHAR_TABLE (char_table
, 0);
1409 CHECK_NUMBER (ch
, 1);
1412 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1413 if (! CHARSET_DEFINED_P (charset
))
1414 error ("Invalid character: %d", c
);
1416 if (charset
== CHARSET_ASCII
)
1417 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1419 /* Even if C is not a generic char, we had better behave as if a
1420 generic char is specified. */
1421 if (CHARSET_DIMENSION (charset
) == 1)
1423 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1426 if (SUB_CHAR_TABLE_P (temp
))
1427 XCHAR_TABLE (temp
)->defalt
= value
;
1429 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1433 if (! SUB_CHAR_TABLE_P (char_table
))
1434 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1435 = make_sub_char_table (temp
));
1436 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1437 if (SUB_CHAR_TABLE_P (temp
))
1438 XCHAR_TABLE (temp
)->defalt
= value
;
1440 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1445 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1446 character or group of characters that share a value.
1447 DEPTH is the current depth in the originally specified
1448 chartable, and INDICES contains the vector indices
1449 for the levels our callers have descended.
1451 ARG is passed to C_FUNCTION when that is called. */
1454 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1455 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1462 /* At first, handle ASCII and 8-bit European characters. */
1463 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1465 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1467 (*c_function
) (arg
, make_number (i
), elt
);
1469 call2 (function
, make_number (i
), elt
);
1471 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1476 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1481 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1483 XSETFASTINT (indices
[depth
], i
);
1485 if (SUB_CHAR_TABLE_P (elt
))
1488 error ("Too deep char table");
1489 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1493 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1495 if (CHARSET_DEFINED_P (charset
))
1497 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1498 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1499 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1501 (*c_function
) (arg
, make_number (c
), elt
);
1503 call2 (function
, make_number (c
), elt
);
1509 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1511 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1512 FUNCTION is called with two arguments--a key and a value.\n\
1513 The key is always a possible IDX argument to `aref'.")
1514 (function
, char_table
)
1515 Lisp_Object function
, char_table
;
1517 /* The depth of char table is at most 3. */
1518 Lisp_Object indices
[3];
1520 CHECK_CHAR_TABLE (char_table
, 1);
1522 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1532 Lisp_Object args
[2];
1535 return Fnconc (2, args
);
1537 return Fnconc (2, &s1
);
1538 #endif /* NO_ARG_ARRAY */
1541 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1542 "Concatenate any number of lists by altering them.\n\
1543 Only the last argument is not altered, and need not be a list.")
1548 register int argnum
;
1549 register Lisp_Object tail
, tem
, val
;
1553 for (argnum
= 0; argnum
< nargs
; argnum
++)
1556 if (NILP (tem
)) continue;
1561 if (argnum
+ 1 == nargs
) break;
1564 tem
= wrong_type_argument (Qlistp
, tem
);
1573 tem
= args
[argnum
+ 1];
1574 Fsetcdr (tail
, tem
);
1576 args
[argnum
+ 1] = tail
;
1582 /* This is the guts of all mapping functions.
1583 Apply fn to each element of seq, one by one,
1584 storing the results into elements of vals, a C vector of Lisp_Objects.
1585 leni is the length of vals, which should also be the length of seq. */
1588 mapcar1 (leni
, vals
, fn
, seq
)
1591 Lisp_Object fn
, seq
;
1593 register Lisp_Object tail
;
1596 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1598 /* Don't let vals contain any garbage when GC happens. */
1599 for (i
= 0; i
< leni
; i
++)
1602 GCPRO3 (dummy
, fn
, seq
);
1604 gcpro1
.nvars
= leni
;
1605 /* We need not explicitly protect `tail' because it is used only on lists, and
1606 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1610 for (i
= 0; i
< leni
; i
++)
1612 dummy
= XVECTOR (seq
)->contents
[i
];
1613 vals
[i
] = call1 (fn
, dummy
);
1616 else if (STRINGP (seq
))
1618 for (i
= 0; i
< leni
; i
++)
1620 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1621 vals
[i
] = call1 (fn
, dummy
);
1624 else /* Must be a list, since Flength did not get an error */
1627 for (i
= 0; i
< leni
; i
++)
1629 vals
[i
] = call1 (fn
, Fcar (tail
));
1630 tail
= XCONS (tail
)->cdr
;
1637 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1638 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1639 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1640 SEPARATOR results in spaces between the values returned by FUNCTION.")
1641 (function
, sequence
, separator
)
1642 Lisp_Object function
, sequence
, separator
;
1647 register Lisp_Object
*args
;
1649 struct gcpro gcpro1
;
1651 len
= Flength (sequence
);
1653 nargs
= leni
+ leni
- 1;
1654 if (nargs
< 0) return build_string ("");
1656 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1659 mapcar1 (leni
, args
, function
, sequence
);
1662 for (i
= leni
- 1; i
>= 0; i
--)
1663 args
[i
+ i
] = args
[i
];
1665 for (i
= 1; i
< nargs
; i
+= 2)
1666 args
[i
] = separator
;
1668 return Fconcat (nargs
, args
);
1671 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1672 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1673 The result is a list just as long as SEQUENCE.\n\
1674 SEQUENCE may be a list, a vector or a string.")
1675 (function
, sequence
)
1676 Lisp_Object function
, sequence
;
1678 register Lisp_Object len
;
1680 register Lisp_Object
*args
;
1682 len
= Flength (sequence
);
1683 leni
= XFASTINT (len
);
1684 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1686 mapcar1 (leni
, args
, function
, sequence
);
1688 return Flist (leni
, args
);
1691 /* Anything that calls this function must protect from GC! */
1693 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1694 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1695 Takes one argument, which is the string to display to ask the question.\n\
1696 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1697 No confirmation of the answer is requested; a single character is enough.\n\
1698 Also accepts Space to mean yes, or Delete to mean no.")
1702 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1703 register int answer
;
1704 Lisp_Object xprompt
;
1705 Lisp_Object args
[2];
1706 struct gcpro gcpro1
, gcpro2
;
1707 int count
= specpdl_ptr
- specpdl
;
1709 specbind (Qcursor_in_echo_area
, Qt
);
1711 map
= Fsymbol_value (intern ("query-replace-map"));
1713 CHECK_STRING (prompt
, 0);
1715 GCPRO2 (prompt
, xprompt
);
1722 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1726 Lisp_Object pane
, menu
;
1727 redisplay_preserve_echo_area ();
1728 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1729 Fcons (Fcons (build_string ("No"), Qnil
),
1731 menu
= Fcons (prompt
, pane
);
1732 obj
= Fx_popup_dialog (Qt
, menu
);
1733 answer
= !NILP (obj
);
1736 #endif /* HAVE_MENUS */
1737 cursor_in_echo_area
= 1;
1738 choose_minibuf_frame ();
1739 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1741 if (minibuffer_auto_raise
)
1743 Lisp_Object mini_frame
;
1745 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1747 Fraise_frame (mini_frame
);
1750 obj
= read_filtered_event (1, 0, 0);
1751 cursor_in_echo_area
= 0;
1752 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1755 key
= Fmake_vector (make_number (1), obj
);
1756 def
= Flookup_key (map
, key
, Qt
);
1757 answer_string
= Fsingle_key_description (obj
);
1759 if (EQ (def
, intern ("skip")))
1764 else if (EQ (def
, intern ("act")))
1769 else if (EQ (def
, intern ("recenter")))
1775 else if (EQ (def
, intern ("quit")))
1777 /* We want to exit this command for exit-prefix,
1778 and this is the only way to do it. */
1779 else if (EQ (def
, intern ("exit-prefix")))
1784 /* If we don't clear this, then the next call to read_char will
1785 return quit_char again, and we'll enter an infinite loop. */
1790 if (EQ (xprompt
, prompt
))
1792 args
[0] = build_string ("Please answer y or n. ");
1794 xprompt
= Fconcat (2, args
);
1799 if (! noninteractive
)
1801 cursor_in_echo_area
= -1;
1802 message_nolog ("%s(y or n) %c",
1803 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1806 unbind_to (count
, Qnil
);
1807 return answer
? Qt
: Qnil
;
1810 /* This is how C code calls `yes-or-no-p' and allows the user
1813 Anything that calls this function must protect from GC! */
1816 do_yes_or_no_p (prompt
)
1819 return call1 (intern ("yes-or-no-p"), prompt
);
1822 /* Anything that calls this function must protect from GC! */
1824 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1825 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1826 Takes one argument, which is the string to display to ask the question.\n\
1827 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1828 The user must confirm the answer with RET,\n\
1829 and can edit it until it has been confirmed.")
1833 register Lisp_Object ans
;
1834 Lisp_Object args
[2];
1835 struct gcpro gcpro1
;
1838 CHECK_STRING (prompt
, 0);
1841 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1845 Lisp_Object pane
, menu
, obj
;
1846 redisplay_preserve_echo_area ();
1847 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1848 Fcons (Fcons (build_string ("No"), Qnil
),
1851 menu
= Fcons (prompt
, pane
);
1852 obj
= Fx_popup_dialog (Qt
, menu
);
1856 #endif /* HAVE_MENUS */
1859 args
[1] = build_string ("(yes or no) ");
1860 prompt
= Fconcat (2, args
);
1866 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1867 Qyes_or_no_p_history
, Qnil
));
1868 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1873 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1881 message ("Please answer yes or no.");
1882 Fsleep_for (make_number (2), Qnil
);
1886 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1887 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1888 Each of the three load averages is multiplied by 100,\n\
1889 then converted to integer.\n\
1890 If the 5-minute or 15-minute load averages are not available, return a\n\
1891 shortened list, containing only those averages which are available.")
1895 int loads
= getloadavg (load_ave
, 3);
1899 error ("load-average not implemented for this operating system");
1903 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1908 Lisp_Object Vfeatures
;
1910 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1911 "Returns t if FEATURE is present in this Emacs.\n\
1912 Use this to conditionalize execution of lisp code based on the presence or\n\
1913 absence of emacs or environment extensions.\n\
1914 Use `provide' to declare that a feature is available.\n\
1915 This function looks at the value of the variable `features'.")
1917 Lisp_Object feature
;
1919 register Lisp_Object tem
;
1920 CHECK_SYMBOL (feature
, 0);
1921 tem
= Fmemq (feature
, Vfeatures
);
1922 return (NILP (tem
)) ? Qnil
: Qt
;
1925 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1926 "Announce that FEATURE is a feature of the current Emacs.")
1928 Lisp_Object feature
;
1930 register Lisp_Object tem
;
1931 CHECK_SYMBOL (feature
, 0);
1932 if (!NILP (Vautoload_queue
))
1933 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1934 tem
= Fmemq (feature
, Vfeatures
);
1936 Vfeatures
= Fcons (feature
, Vfeatures
);
1937 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1941 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1942 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1943 If FEATURE is not a member of the list `features', then the feature\n\
1944 is not loaded; so load the file FILENAME.\n\
1945 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1946 (feature
, file_name
)
1947 Lisp_Object feature
, file_name
;
1949 register Lisp_Object tem
;
1950 CHECK_SYMBOL (feature
, 0);
1951 tem
= Fmemq (feature
, Vfeatures
);
1952 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1955 int count
= specpdl_ptr
- specpdl
;
1957 /* Value saved here is to be restored into Vautoload_queue */
1958 record_unwind_protect (un_autoload
, Vautoload_queue
);
1959 Vautoload_queue
= Qt
;
1961 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1964 tem
= Fmemq (feature
, Vfeatures
);
1966 error ("Required feature %s was not provided",
1967 XSYMBOL (feature
)->name
->data
);
1969 /* Once loading finishes, don't undo it. */
1970 Vautoload_queue
= Qt
;
1971 feature
= unbind_to (count
, feature
);
1978 Qstring_lessp
= intern ("string-lessp");
1979 staticpro (&Qstring_lessp
);
1980 Qprovide
= intern ("provide");
1981 staticpro (&Qprovide
);
1982 Qrequire
= intern ("require");
1983 staticpro (&Qrequire
);
1984 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1985 staticpro (&Qyes_or_no_p_history
);
1986 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1987 staticpro (&Qcursor_in_echo_area
);
1989 Fset (Qyes_or_no_p_history
, Qnil
);
1991 DEFVAR_LISP ("features", &Vfeatures
,
1992 "A list of symbols which are the features of the executing emacs.\n\
1993 Used by `featurep' and `require', and altered by `provide'.");
1996 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
1997 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
1998 This applies to y-or-n and yes-or-no questions asked by commands\n\
1999 invoked by mouse clicks and mouse menu items.");
2002 defsubr (&Sidentity
);
2005 defsubr (&Ssafe_length
);
2006 defsubr (&Sstring_equal
);
2007 defsubr (&Sstring_lessp
);
2010 defsubr (&Svconcat
);
2011 defsubr (&Scopy_sequence
);
2012 defsubr (&Scopy_alist
);
2013 defsubr (&Ssubstring
);
2025 defsubr (&Snreverse
);
2026 defsubr (&Sreverse
);
2028 defsubr (&Splist_get
);
2030 defsubr (&Splist_put
);
2033 defsubr (&Sfillarray
);
2034 defsubr (&Schar_table_subtype
);
2035 defsubr (&Schar_table_parent
);
2036 defsubr (&Sset_char_table_parent
);
2037 defsubr (&Schar_table_extra_slot
);
2038 defsubr (&Sset_char_table_extra_slot
);
2039 defsubr (&Schar_table_range
);
2040 defsubr (&Sset_char_table_range
);
2041 defsubr (&Sset_char_table_default
);
2042 defsubr (&Smap_char_table
);
2045 defsubr (&Smapconcat
);
2046 defsubr (&Sy_or_n_p
);
2047 defsubr (&Syes_or_no_p
);
2048 defsubr (&Sload_average
);
2049 defsubr (&Sfeaturep
);
2050 defsubr (&Srequire
);
2051 defsubr (&Sprovide
);