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.\n\
110 If the string contains multibyte characters, this is not the necessarily\n\
111 the number of characters in the string; it is the number of bytes.\n\
112 To get the number of characters, use `chars-in-string'")
114 register Lisp_Object sequence
;
116 register Lisp_Object tail
, val
;
120 if (STRINGP (sequence
))
121 XSETFASTINT (val
, XSTRING (sequence
)->size
);
122 else if (VECTORP (sequence
))
123 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
124 else if (CHAR_TABLE_P (sequence
))
125 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
126 else if (BOOL_VECTOR_P (sequence
))
127 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
128 else if (COMPILEDP (sequence
))
129 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
130 else if (CONSP (sequence
))
132 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
138 XSETFASTINT (val
, i
);
140 else if (NILP (sequence
))
141 XSETFASTINT (val
, 0);
144 sequence
= wrong_type_argument (Qsequencep
, sequence
);
150 /* This does not check for quits. That is safe
151 since it must terminate. */
153 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
154 "Return the length of a list, but avoid error or infinite loop.\n\
155 This function never gets an error. If LIST is not really a list,\n\
156 it returns 0. If LIST is circular, it returns a finite value\n\
157 which is at least the number of distinct elements.")
161 Lisp_Object tail
, halftail
, length
;
164 /* halftail is used to detect circular lists. */
166 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
168 if (EQ (tail
, halftail
) && len
!= 0)
172 halftail
= XCONS (halftail
)->cdr
;
175 XSETINT (length
, len
);
179 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
180 "T if two strings have identical contents.\n\
181 Case is significant, but text properties are ignored.\n\
182 Symbols are also allowed; their print names are used instead.")
184 register Lisp_Object s1
, s2
;
187 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
189 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
190 CHECK_STRING (s1
, 0);
191 CHECK_STRING (s2
, 1);
193 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
194 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
199 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
200 "T if first arg string is less than second in lexicographic order.\n\
201 Case is significant.\n\
202 Symbols are also allowed; their print names are used instead.")
204 register Lisp_Object s1
, s2
;
207 register unsigned char *p1
, *p2
;
211 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
213 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
214 CHECK_STRING (s1
, 0);
215 CHECK_STRING (s2
, 1);
217 p1
= XSTRING (s1
)->data
;
218 p2
= XSTRING (s2
)->data
;
219 end
= XSTRING (s1
)->size
;
220 if (end
> XSTRING (s2
)->size
)
221 end
= XSTRING (s2
)->size
;
223 for (i
= 0; i
< end
; i
++)
226 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
228 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
231 static Lisp_Object
concat ();
242 return concat (2, args
, Lisp_String
, 0);
244 return concat (2, &s1
, Lisp_String
, 0);
245 #endif /* NO_ARG_ARRAY */
251 Lisp_Object s1
, s2
, s3
;
258 return concat (3, args
, Lisp_String
, 0);
260 return concat (3, &s1
, Lisp_String
, 0);
261 #endif /* NO_ARG_ARRAY */
264 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
265 "Concatenate all the arguments and make the result a list.\n\
266 The result is a list whose elements are the elements of all the arguments.\n\
267 Each argument may be a list, vector or string.\n\
268 The last argument is not copied, just used as the tail of the new list.")
273 return concat (nargs
, args
, Lisp_Cons
, 1);
276 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
277 "Concatenate all the arguments and make the result a string.\n\
278 The result is a string whose elements are the elements of all the arguments.\n\
279 Each argument may be a string or a list or vector of characters (integers).\n\
281 Do not use individual integers as arguments!\n\
282 The behavior of `concat' in that case will be changed later!\n\
283 If your program passes an integer as an argument to `concat',\n\
284 you should change it right away not to do so.")
289 return concat (nargs
, args
, Lisp_String
, 0);
292 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
293 "Concatenate all the arguments and make the result a vector.\n\
294 The result is a vector whose elements are the elements of all the arguments.\n\
295 Each argument may be a list, vector or string.")
300 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
303 /* Retrun a copy of a sub char table ARG. The elements except for a
304 nested sub char table are not copied. */
306 copy_sub_char_table (arg
)
309 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
312 /* Copy all the contents. */
313 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
314 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
315 /* Recursively copy any sub char-tables in the ordinary slots. */
316 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
317 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
318 XCHAR_TABLE (copy
)->contents
[i
]
319 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
325 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
326 "Return a copy of a list, vector or string.\n\
327 The elements of a list or vector are not copied; they are shared\n\
332 if (NILP (arg
)) return arg
;
334 if (CHAR_TABLE_P (arg
))
339 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
340 /* Copy all the slots, including the extra ones. */
341 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
342 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
343 * sizeof (Lisp_Object
)));
345 /* Recursively copy any sub char tables in the ordinary slots
346 for multibyte characters. */
347 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
348 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
349 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
350 XCHAR_TABLE (copy
)->contents
[i
]
351 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
356 if (BOOL_VECTOR_P (arg
))
360 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
362 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
363 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
368 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
369 arg
= wrong_type_argument (Qsequencep
, arg
);
370 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
374 concat (nargs
, args
, target_type
, last_special
)
377 enum Lisp_Type target_type
;
382 register Lisp_Object tail
;
383 register Lisp_Object
this;
387 Lisp_Object last_tail
;
390 /* In append, the last arg isn't treated like the others */
391 if (last_special
&& nargs
> 0)
394 last_tail
= args
[nargs
];
399 for (argnum
= 0; argnum
< nargs
; argnum
++)
402 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
403 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
406 args
[argnum
] = Fnumber_to_string (this);
408 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
412 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
415 len
= Flength (this);
416 if ((VECTORP (this) || CONSP (this)) && target_type
== Lisp_String
)
419 /* We must pay attention to a multibyte character which
420 takes more than one byte in string. */
425 for (i
= 0; i
< XFASTINT (len
); i
++)
427 ch
= XVECTOR (this)->contents
[i
];
429 wrong_type_argument (Qintegerp
, ch
);
430 leni
+= XFASTINT (Fchar_bytes (ch
));
433 for (; CONSP (this); this = XCONS (this)->cdr
)
435 ch
= XCONS (this)->car
;
437 wrong_type_argument (Qintegerp
, ch
);
438 leni
+= XFASTINT (Fchar_bytes (ch
));
442 leni
+= XFASTINT (len
);
445 XSETFASTINT (len
, leni
);
447 if (target_type
== Lisp_Cons
)
448 val
= Fmake_list (len
, Qnil
);
449 else if (target_type
== Lisp_Vectorlike
)
450 val
= Fmake_vector (len
, Qnil
);
452 val
= Fmake_string (len
, len
);
454 /* In append, if all but last arg are nil, return last arg */
455 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
459 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
465 for (argnum
= 0; argnum
< nargs
; argnum
++)
469 register unsigned int thisindex
= 0;
473 thislen
= Flength (this), thisleni
= XINT (thislen
);
475 if (STRINGP (this) && STRINGP (val
)
476 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
478 copy_text_properties (make_number (0), thislen
, this,
479 make_number (toindex
), val
, Qnil
);
484 register Lisp_Object elt
;
486 /* Fetch next element of `this' arg into `elt', or break if
487 `this' is exhausted. */
488 if (NILP (this)) break;
490 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
493 if (thisindex
>= thisleni
) break;
495 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
496 else if (BOOL_VECTOR_P (this))
499 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
502 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
503 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
509 elt
= XVECTOR (this)->contents
[thisindex
++];
512 /* Store into result */
515 XCONS (tail
)->car
= elt
;
517 tail
= XCONS (tail
)->cdr
;
519 else if (VECTORP (val
))
520 XVECTOR (val
)->contents
[toindex
++] = elt
;
523 while (!INTEGERP (elt
))
524 elt
= wrong_type_argument (Qintegerp
, elt
);
527 unsigned char work
[4], *str
;
528 int i
= CHAR_STRING (c
, work
, str
);
530 #ifdef MASSC_REGISTER_BUG
531 /* Even removing all "register"s doesn't disable this bug!
532 Nothing simpler than this seems to work. */
533 unsigned char *p
= & XSTRING (val
)->data
[toindex
];
536 bcopy (str
, & XSTRING (val
)->data
[toindex
], i
);
544 XCONS (prev
)->cdr
= last_tail
;
549 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
550 "Return a copy of ALIST.\n\
551 This is an alist which represents the same mapping from objects to objects,\n\
552 but does not share the alist structure with ALIST.\n\
553 The objects mapped (cars and cdrs of elements of the alist)\n\
554 are shared, however.\n\
555 Elements of ALIST that are not conses are also shared.")
559 register Lisp_Object tem
;
561 CHECK_LIST (alist
, 0);
564 alist
= concat (1, &alist
, Lisp_Cons
, 0);
565 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
567 register Lisp_Object car
;
568 car
= XCONS (tem
)->car
;
571 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
576 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
577 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
578 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
579 If FROM or TO is negative, it counts from the end.\n\
581 This function allows vectors as well as strings.")
584 register Lisp_Object from
, to
;
589 if (! (STRINGP (string
) || VECTORP (string
)))
590 wrong_type_argument (Qarrayp
, string
);
592 CHECK_NUMBER (from
, 1);
594 if (STRINGP (string
))
595 size
= XSTRING (string
)->size
;
597 size
= XVECTOR (string
)->size
;
602 CHECK_NUMBER (to
, 2);
605 XSETINT (from
, XINT (from
) + size
);
607 XSETINT (to
, XINT (to
) + size
);
608 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
609 && XINT (to
) <= size
))
610 args_out_of_range_3 (string
, from
, to
);
612 if (STRINGP (string
))
614 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
615 XINT (to
) - XINT (from
));
616 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
619 res
= Fvector (XINT (to
) - XINT (from
),
620 XVECTOR (string
)->contents
+ XINT (from
));
625 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
626 "Take cdr N times on LIST, returns the result.")
629 register Lisp_Object list
;
634 for (i
= 0; i
< num
&& !NILP (list
); i
++)
642 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
643 "Return the Nth element of LIST.\n\
644 N counts from zero. If LIST is not that long, nil is returned.")
648 return Fcar (Fnthcdr (n
, list
));
651 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
652 "Return element of SEQUENCE at index N.")
654 register Lisp_Object sequence
, n
;
659 if (CONSP (sequence
) || NILP (sequence
))
660 return Fcar (Fnthcdr (n
, sequence
));
661 else if (STRINGP (sequence
) || VECTORP (sequence
)
662 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
663 return Faref (sequence
, n
);
665 sequence
= wrong_type_argument (Qsequencep
, sequence
);
669 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
670 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
671 The value is actually the tail of LIST whose car is ELT.")
673 register Lisp_Object elt
;
676 register Lisp_Object tail
;
677 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
679 register Lisp_Object tem
;
681 if (! NILP (Fequal (elt
, tem
)))
688 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
689 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
690 The value is actually the tail of LIST whose car is ELT.")
692 register Lisp_Object elt
;
695 register Lisp_Object tail
;
696 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
698 register Lisp_Object tem
;
700 if (EQ (elt
, tem
)) return tail
;
706 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
707 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
708 The value is actually the element of LIST whose car is KEY.\n\
709 Elements of LIST that are not conses are ignored.")
711 register Lisp_Object key
;
714 register Lisp_Object tail
;
715 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
717 register Lisp_Object elt
, tem
;
719 if (!CONSP (elt
)) continue;
720 tem
= XCONS (elt
)->car
;
721 if (EQ (key
, tem
)) return elt
;
727 /* Like Fassq but never report an error and do not allow quits.
728 Use only on lists known never to be circular. */
731 assq_no_quit (key
, list
)
732 register Lisp_Object key
;
735 register Lisp_Object tail
;
736 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
738 register Lisp_Object elt
, tem
;
740 if (!CONSP (elt
)) continue;
741 tem
= XCONS (elt
)->car
;
742 if (EQ (key
, tem
)) return elt
;
747 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
748 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
749 The value is actually the element of LIST whose car equals KEY.")
751 register Lisp_Object key
;
754 register Lisp_Object tail
;
755 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
757 register Lisp_Object elt
, tem
;
759 if (!CONSP (elt
)) continue;
760 tem
= Fequal (XCONS (elt
)->car
, key
);
761 if (!NILP (tem
)) return elt
;
767 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
768 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
769 The value is actually the element of LIST whose cdr is ELT.")
771 register Lisp_Object key
;
774 register Lisp_Object tail
;
775 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
777 register Lisp_Object elt
, tem
;
779 if (!CONSP (elt
)) continue;
780 tem
= XCONS (elt
)->cdr
;
781 if (EQ (key
, tem
)) return elt
;
787 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
788 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
789 The value is actually the element of LIST whose cdr equals KEY.")
791 register Lisp_Object key
;
794 register Lisp_Object tail
;
795 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
797 register Lisp_Object elt
, tem
;
799 if (!CONSP (elt
)) continue;
800 tem
= Fequal (XCONS (elt
)->cdr
, key
);
801 if (!NILP (tem
)) return elt
;
807 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
808 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
809 The modified LIST is returned. Comparison is done with `eq'.\n\
810 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
811 therefore, write `(setq foo (delq element foo))'\n\
812 to be sure of changing the value of `foo'.")
814 register Lisp_Object elt
;
817 register Lisp_Object tail
, prev
;
818 register Lisp_Object tem
;
828 list
= XCONS (tail
)->cdr
;
830 Fsetcdr (prev
, XCONS (tail
)->cdr
);
834 tail
= XCONS (tail
)->cdr
;
840 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
841 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
842 The modified LIST is returned. Comparison is done with `equal'.\n\
843 If the first member of LIST is ELT, deleting it is not a side effect;\n\
844 it is simply using a different list.\n\
845 Therefore, write `(setq foo (delete element foo))'\n\
846 to be sure of changing the value of `foo'.")
848 register Lisp_Object elt
;
851 register Lisp_Object tail
, prev
;
852 register Lisp_Object tem
;
859 if (! NILP (Fequal (elt
, tem
)))
862 list
= XCONS (tail
)->cdr
;
864 Fsetcdr (prev
, XCONS (tail
)->cdr
);
868 tail
= XCONS (tail
)->cdr
;
874 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
875 "Reverse LIST by modifying cdr pointers.\n\
876 Returns the beginning of the reversed list.")
880 register Lisp_Object prev
, tail
, next
;
882 if (NILP (list
)) return list
;
889 Fsetcdr (tail
, prev
);
896 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
897 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
898 See also the function `nreverse', which is used more often.")
904 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
905 new = Fcons (XCONS (list
)->car
, new);
907 wrong_type_argument (Qconsp
, list
);
911 Lisp_Object
merge ();
913 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
914 "Sort LIST, stably, comparing elements using PREDICATE.\n\
915 Returns the sorted list. LIST is modified by side effects.\n\
916 PREDICATE is called with two elements of LIST, and should return T\n\
917 if the first element is \"less\" than the second.")
919 Lisp_Object list
, predicate
;
921 Lisp_Object front
, back
;
922 register Lisp_Object len
, tem
;
923 struct gcpro gcpro1
, gcpro2
;
927 len
= Flength (list
);
932 XSETINT (len
, (length
/ 2) - 1);
933 tem
= Fnthcdr (len
, list
);
937 GCPRO2 (front
, back
);
938 front
= Fsort (front
, predicate
);
939 back
= Fsort (back
, predicate
);
941 return merge (front
, back
, predicate
);
945 merge (org_l1
, org_l2
, pred
)
946 Lisp_Object org_l1
, org_l2
;
950 register Lisp_Object tail
;
952 register Lisp_Object l1
, l2
;
953 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
960 /* It is sufficient to protect org_l1 and org_l2.
961 When l1 and l2 are updated, we copy the new values
962 back into the org_ vars. */
963 GCPRO4 (org_l1
, org_l2
, pred
, value
);
983 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1005 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1006 "Extract a value from a property list.\n\
1007 PLIST is a property list, which is a list of the form\n\
1008 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1009 corresponding to the given PROP, or nil if PROP is not\n\
1010 one of the properties on the list.")
1013 register Lisp_Object prop
;
1015 register Lisp_Object tail
;
1016 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1018 register Lisp_Object tem
;
1021 return Fcar (XCONS (tail
)->cdr
);
1026 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1027 "Return the value of SYMBOL's PROPNAME property.\n\
1028 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1030 Lisp_Object symbol
, propname
;
1032 CHECK_SYMBOL (symbol
, 0);
1033 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1036 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1037 "Change value in PLIST of PROP to VAL.\n\
1038 PLIST is a property list, which is a list of the form\n\
1039 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1040 If PROP is already a property on the list, its value is set to VAL,\n\
1041 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1042 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1043 The PLIST is modified by side effects.")
1046 register Lisp_Object prop
;
1049 register Lisp_Object tail
, prev
;
1050 Lisp_Object newcell
;
1052 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1053 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1055 if (EQ (prop
, XCONS (tail
)->car
))
1057 Fsetcar (XCONS (tail
)->cdr
, val
);
1062 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1066 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1070 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1071 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1072 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1073 (symbol
, propname
, value
)
1074 Lisp_Object symbol
, propname
, value
;
1076 CHECK_SYMBOL (symbol
, 0);
1077 XSYMBOL (symbol
)->plist
1078 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1082 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1083 "T if two Lisp objects have similar structure and contents.\n\
1084 They must have the same data type.\n\
1085 Conses are compared by comparing the cars and the cdrs.\n\
1086 Vectors and strings are compared element by element.\n\
1087 Numbers are compared by value, but integers cannot equal floats.\n\
1088 (Use `=' if you want integers and floats to be able to be equal.)\n\
1089 Symbols must match exactly.")
1091 register Lisp_Object o1
, o2
;
1093 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1097 internal_equal (o1
, o2
, depth
)
1098 register Lisp_Object o1
, o2
;
1102 error ("Stack overflow in equal");
1108 if (XTYPE (o1
) != XTYPE (o2
))
1113 #ifdef LISP_FLOAT_TYPE
1115 return (extract_float (o1
) == extract_float (o2
));
1119 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1121 o1
= XCONS (o1
)->cdr
;
1122 o2
= XCONS (o2
)->cdr
;
1126 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1130 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1132 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1135 o1
= XOVERLAY (o1
)->plist
;
1136 o2
= XOVERLAY (o2
)->plist
;
1141 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1142 && (XMARKER (o1
)->buffer
== 0
1143 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1147 case Lisp_Vectorlike
:
1149 register int i
, size
;
1150 size
= XVECTOR (o1
)->size
;
1151 /* Pseudovectors have the type encoded in the size field, so this test
1152 actually checks that the objects have the same type as well as the
1154 if (XVECTOR (o2
)->size
!= size
)
1156 /* Boolvectors are compared much like strings. */
1157 if (BOOL_VECTOR_P (o1
))
1160 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1162 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1164 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1170 /* Aside from them, only true vectors, char-tables, and compiled
1171 functions are sensible to compare, so eliminate the others now. */
1172 if (size
& PSEUDOVECTOR_FLAG
)
1174 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1176 size
&= PSEUDOVECTOR_SIZE_MASK
;
1178 for (i
= 0; i
< size
; i
++)
1181 v1
= XVECTOR (o1
)->contents
[i
];
1182 v2
= XVECTOR (o2
)->contents
[i
];
1183 if (!internal_equal (v1
, v2
, depth
+ 1))
1191 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1193 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1194 XSTRING (o1
)->size
))
1201 extern Lisp_Object
Fmake_char_internal ();
1203 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1204 "Store each element of ARRAY with ITEM.\n\
1205 ARRAY is a vector, string, char-table, or bool-vector.")
1207 Lisp_Object array
, item
;
1209 register int size
, index
, charval
;
1211 if (VECTORP (array
))
1213 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1214 size
= XVECTOR (array
)->size
;
1215 for (index
= 0; index
< size
; index
++)
1218 else if (CHAR_TABLE_P (array
))
1220 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1221 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1222 for (index
= 0; index
< size
; index
++)
1224 XCHAR_TABLE (array
)->defalt
= Qnil
;
1226 else if (STRINGP (array
))
1228 register unsigned char *p
= XSTRING (array
)->data
;
1229 CHECK_NUMBER (item
, 1);
1230 charval
= XINT (item
);
1231 size
= XSTRING (array
)->size
;
1232 for (index
= 0; index
< size
; index
++)
1235 else if (BOOL_VECTOR_P (array
))
1237 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1239 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1241 charval
= (! NILP (item
) ? -1 : 0);
1242 for (index
= 0; index
< size_in_chars
; index
++)
1247 array
= wrong_type_argument (Qarrayp
, array
);
1253 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1255 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1257 Lisp_Object char_table
;
1259 CHECK_CHAR_TABLE (char_table
, 0);
1261 return XCHAR_TABLE (char_table
)->purpose
;
1264 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1266 "Return the parent char-table of CHAR-TABLE.\n\
1267 The value is either nil or another char-table.\n\
1268 If CHAR-TABLE holds nil for a given character,\n\
1269 then the actual applicable value is inherited from the parent char-table\n\
1270 \(or from its parents, if necessary).")
1272 Lisp_Object char_table
;
1274 CHECK_CHAR_TABLE (char_table
, 0);
1276 return XCHAR_TABLE (char_table
)->parent
;
1279 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1281 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1282 PARENT must be either nil or another char-table.")
1283 (char_table
, parent
)
1284 Lisp_Object char_table
, parent
;
1288 CHECK_CHAR_TABLE (char_table
, 0);
1292 CHECK_CHAR_TABLE (parent
, 0);
1294 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1295 if (EQ (temp
, char_table
))
1296 error ("Attempt to make a chartable be its own parent");
1299 XCHAR_TABLE (char_table
)->parent
= parent
;
1304 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1306 "Return the value of CHAR-TABLE's extra-slot number N.")
1308 Lisp_Object char_table
, n
;
1310 CHECK_CHAR_TABLE (char_table
, 1);
1311 CHECK_NUMBER (n
, 2);
1313 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1314 args_out_of_range (char_table
, n
);
1316 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1319 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1320 Sset_char_table_extra_slot
,
1322 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1323 (char_table
, n
, value
)
1324 Lisp_Object char_table
, n
, value
;
1326 CHECK_CHAR_TABLE (char_table
, 1);
1327 CHECK_NUMBER (n
, 2);
1329 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1330 args_out_of_range (char_table
, n
);
1332 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1335 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1337 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1338 RANGE should be t (for all characters), nil (for the default value)\n\
1339 a vector which identifies a character set or a row of a character set,\n\
1340 or a character code.")
1342 Lisp_Object char_table
, range
;
1346 CHECK_CHAR_TABLE (char_table
, 0);
1348 if (EQ (range
, Qnil
))
1349 return XCHAR_TABLE (char_table
)->defalt
;
1350 else if (INTEGERP (range
))
1351 return Faref (char_table
, range
);
1352 else if (VECTORP (range
))
1354 if (XVECTOR (range
)->size
== 1)
1355 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1358 int size
= XVECTOR (range
)->size
;
1359 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1360 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1361 size
<= 1 ? Qnil
: val
[1],
1362 size
<= 2 ? Qnil
: val
[2]);
1363 return Faref (char_table
, ch
);
1367 error ("Invalid RANGE argument to `char-table-range'");
1370 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1372 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1373 RANGE should be t (for all characters), nil (for the default value)\n\
1374 a vector which identifies a character set or a row of a character set,\n\
1375 or a character code.")
1376 (char_table
, range
, value
)
1377 Lisp_Object char_table
, range
, value
;
1381 CHECK_CHAR_TABLE (char_table
, 0);
1384 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1385 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1386 else if (EQ (range
, Qnil
))
1387 XCHAR_TABLE (char_table
)->defalt
= value
;
1388 else if (INTEGERP (range
))
1389 Faset (char_table
, range
, value
);
1390 else if (VECTORP (range
))
1392 if (XVECTOR (range
)->size
== 1)
1393 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1396 int size
= XVECTOR (range
)->size
;
1397 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1398 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1399 size
<= 1 ? Qnil
: val
[1],
1400 size
<= 2 ? Qnil
: val
[2]);
1401 return Faset (char_table
, ch
, value
);
1405 error ("Invalid RANGE argument to `set-char-table-range'");
1410 DEFUN ("set-char-table-default", Fset_char_table_default
,
1411 Sset_char_table_default
, 3, 3, 0,
1412 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1413 The generic character specifies the group of characters.\n\
1414 See also the documentation of make-char.")
1415 (char_table
, ch
, value
)
1416 Lisp_Object char_table
, ch
, value
;
1418 int c
, i
, charset
, code1
, code2
;
1421 CHECK_CHAR_TABLE (char_table
, 0);
1422 CHECK_NUMBER (ch
, 1);
1425 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1426 if (! CHARSET_DEFINED_P (charset
))
1427 error ("Invalid character: %d", c
);
1429 if (charset
== CHARSET_ASCII
)
1430 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1432 /* Even if C is not a generic char, we had better behave as if a
1433 generic char is specified. */
1434 if (CHARSET_DIMENSION (charset
) == 1)
1436 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1439 if (SUB_CHAR_TABLE_P (temp
))
1440 XCHAR_TABLE (temp
)->defalt
= value
;
1442 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1446 if (! SUB_CHAR_TABLE_P (char_table
))
1447 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1448 = make_sub_char_table (temp
));
1449 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1450 if (SUB_CHAR_TABLE_P (temp
))
1451 XCHAR_TABLE (temp
)->defalt
= value
;
1453 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1458 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1459 character or group of characters that share a value.
1460 DEPTH is the current depth in the originally specified
1461 chartable, and INDICES contains the vector indices
1462 for the levels our callers have descended.
1464 ARG is passed to C_FUNCTION when that is called. */
1467 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1468 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1475 /* At first, handle ASCII and 8-bit European characters. */
1476 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1478 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1480 (*c_function
) (arg
, make_number (i
), elt
);
1482 call2 (function
, make_number (i
), elt
);
1484 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1489 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1494 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1496 XSETFASTINT (indices
[depth
], i
);
1498 if (SUB_CHAR_TABLE_P (elt
))
1501 error ("Too deep char table");
1502 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1506 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1508 if (CHARSET_DEFINED_P (charset
))
1510 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1511 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1512 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1514 (*c_function
) (arg
, make_number (c
), elt
);
1516 call2 (function
, make_number (c
), elt
);
1522 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1524 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1525 FUNCTION is called with two arguments--a key and a value.\n\
1526 The key is always a possible IDX argument to `aref'.")
1527 (function
, char_table
)
1528 Lisp_Object function
, char_table
;
1530 /* The depth of char table is at most 3. */
1531 Lisp_Object indices
[3];
1533 CHECK_CHAR_TABLE (char_table
, 1);
1535 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1545 Lisp_Object args
[2];
1548 return Fnconc (2, args
);
1550 return Fnconc (2, &s1
);
1551 #endif /* NO_ARG_ARRAY */
1554 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1555 "Concatenate any number of lists by altering them.\n\
1556 Only the last argument is not altered, and need not be a list.")
1561 register int argnum
;
1562 register Lisp_Object tail
, tem
, val
;
1566 for (argnum
= 0; argnum
< nargs
; argnum
++)
1569 if (NILP (tem
)) continue;
1574 if (argnum
+ 1 == nargs
) break;
1577 tem
= wrong_type_argument (Qlistp
, tem
);
1586 tem
= args
[argnum
+ 1];
1587 Fsetcdr (tail
, tem
);
1589 args
[argnum
+ 1] = tail
;
1595 /* This is the guts of all mapping functions.
1596 Apply fn to each element of seq, one by one,
1597 storing the results into elements of vals, a C vector of Lisp_Objects.
1598 leni is the length of vals, which should also be the length of seq. */
1601 mapcar1 (leni
, vals
, fn
, seq
)
1604 Lisp_Object fn
, seq
;
1606 register Lisp_Object tail
;
1609 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1611 /* Don't let vals contain any garbage when GC happens. */
1612 for (i
= 0; i
< leni
; i
++)
1615 GCPRO3 (dummy
, fn
, seq
);
1617 gcpro1
.nvars
= leni
;
1618 /* We need not explicitly protect `tail' because it is used only on lists, and
1619 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1623 for (i
= 0; i
< leni
; i
++)
1625 dummy
= XVECTOR (seq
)->contents
[i
];
1626 vals
[i
] = call1 (fn
, dummy
);
1629 else if (STRINGP (seq
))
1631 for (i
= 0; i
< leni
; i
++)
1633 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1634 vals
[i
] = call1 (fn
, dummy
);
1637 else /* Must be a list, since Flength did not get an error */
1640 for (i
= 0; i
< leni
; i
++)
1642 vals
[i
] = call1 (fn
, Fcar (tail
));
1643 tail
= XCONS (tail
)->cdr
;
1650 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1651 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1652 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1653 SEPARATOR results in spaces between the values returned by FUNCTION.")
1654 (function
, sequence
, separator
)
1655 Lisp_Object function
, sequence
, separator
;
1660 register Lisp_Object
*args
;
1662 struct gcpro gcpro1
;
1664 len
= Flength (sequence
);
1666 nargs
= leni
+ leni
- 1;
1667 if (nargs
< 0) return build_string ("");
1669 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1672 mapcar1 (leni
, args
, function
, sequence
);
1675 for (i
= leni
- 1; i
>= 0; i
--)
1676 args
[i
+ i
] = args
[i
];
1678 for (i
= 1; i
< nargs
; i
+= 2)
1679 args
[i
] = separator
;
1681 return Fconcat (nargs
, args
);
1684 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1685 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1686 The result is a list just as long as SEQUENCE.\n\
1687 SEQUENCE may be a list, a vector or a string.")
1688 (function
, sequence
)
1689 Lisp_Object function
, sequence
;
1691 register Lisp_Object len
;
1693 register Lisp_Object
*args
;
1695 len
= Flength (sequence
);
1696 leni
= XFASTINT (len
);
1697 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1699 mapcar1 (leni
, args
, function
, sequence
);
1701 return Flist (leni
, args
);
1704 /* Anything that calls this function must protect from GC! */
1706 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1707 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1708 Takes one argument, which is the string to display to ask the question.\n\
1709 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1710 No confirmation of the answer is requested; a single character is enough.\n\
1711 Also accepts Space to mean yes, or Delete to mean no.")
1715 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1716 register int answer
;
1717 Lisp_Object xprompt
;
1718 Lisp_Object args
[2];
1719 struct gcpro gcpro1
, gcpro2
;
1720 int count
= specpdl_ptr
- specpdl
;
1722 specbind (Qcursor_in_echo_area
, Qt
);
1724 map
= Fsymbol_value (intern ("query-replace-map"));
1726 CHECK_STRING (prompt
, 0);
1728 GCPRO2 (prompt
, xprompt
);
1735 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1739 Lisp_Object pane
, menu
;
1740 redisplay_preserve_echo_area ();
1741 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1742 Fcons (Fcons (build_string ("No"), Qnil
),
1744 menu
= Fcons (prompt
, pane
);
1745 obj
= Fx_popup_dialog (Qt
, menu
);
1746 answer
= !NILP (obj
);
1749 #endif /* HAVE_MENUS */
1750 cursor_in_echo_area
= 1;
1751 choose_minibuf_frame ();
1752 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1754 if (minibuffer_auto_raise
)
1756 Lisp_Object mini_frame
;
1758 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1760 Fraise_frame (mini_frame
);
1763 obj
= read_filtered_event (1, 0, 0);
1764 cursor_in_echo_area
= 0;
1765 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1768 key
= Fmake_vector (make_number (1), obj
);
1769 def
= Flookup_key (map
, key
, Qt
);
1770 answer_string
= Fsingle_key_description (obj
);
1772 if (EQ (def
, intern ("skip")))
1777 else if (EQ (def
, intern ("act")))
1782 else if (EQ (def
, intern ("recenter")))
1788 else if (EQ (def
, intern ("quit")))
1790 /* We want to exit this command for exit-prefix,
1791 and this is the only way to do it. */
1792 else if (EQ (def
, intern ("exit-prefix")))
1797 /* If we don't clear this, then the next call to read_char will
1798 return quit_char again, and we'll enter an infinite loop. */
1803 if (EQ (xprompt
, prompt
))
1805 args
[0] = build_string ("Please answer y or n. ");
1807 xprompt
= Fconcat (2, args
);
1812 if (! noninteractive
)
1814 cursor_in_echo_area
= -1;
1815 message_nolog ("%s(y or n) %c",
1816 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1819 unbind_to (count
, Qnil
);
1820 return answer
? Qt
: Qnil
;
1823 /* This is how C code calls `yes-or-no-p' and allows the user
1826 Anything that calls this function must protect from GC! */
1829 do_yes_or_no_p (prompt
)
1832 return call1 (intern ("yes-or-no-p"), prompt
);
1835 /* Anything that calls this function must protect from GC! */
1837 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1838 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1839 Takes one argument, which is the string to display to ask the question.\n\
1840 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1841 The user must confirm the answer with RET,\n\
1842 and can edit it until it has been confirmed.")
1846 register Lisp_Object ans
;
1847 Lisp_Object args
[2];
1848 struct gcpro gcpro1
;
1851 CHECK_STRING (prompt
, 0);
1854 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1858 Lisp_Object pane
, menu
, obj
;
1859 redisplay_preserve_echo_area ();
1860 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1861 Fcons (Fcons (build_string ("No"), Qnil
),
1864 menu
= Fcons (prompt
, pane
);
1865 obj
= Fx_popup_dialog (Qt
, menu
);
1869 #endif /* HAVE_MENUS */
1872 args
[1] = build_string ("(yes or no) ");
1873 prompt
= Fconcat (2, args
);
1879 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1880 Qyes_or_no_p_history
, Qnil
,
1882 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1887 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1895 message ("Please answer yes or no.");
1896 Fsleep_for (make_number (2), Qnil
);
1900 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1901 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1902 Each of the three load averages is multiplied by 100,\n\
1903 then converted to integer.\n\
1904 If the 5-minute or 15-minute load averages are not available, return a\n\
1905 shortened list, containing only those averages which are available.")
1909 int loads
= getloadavg (load_ave
, 3);
1913 error ("load-average not implemented for this operating system");
1917 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1922 Lisp_Object Vfeatures
;
1924 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1925 "Returns t if FEATURE is present in this Emacs.\n\
1926 Use this to conditionalize execution of lisp code based on the presence or\n\
1927 absence of emacs or environment extensions.\n\
1928 Use `provide' to declare that a feature is available.\n\
1929 This function looks at the value of the variable `features'.")
1931 Lisp_Object feature
;
1933 register Lisp_Object tem
;
1934 CHECK_SYMBOL (feature
, 0);
1935 tem
= Fmemq (feature
, Vfeatures
);
1936 return (NILP (tem
)) ? Qnil
: Qt
;
1939 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1940 "Announce that FEATURE is a feature of the current Emacs.")
1942 Lisp_Object feature
;
1944 register Lisp_Object tem
;
1945 CHECK_SYMBOL (feature
, 0);
1946 if (!NILP (Vautoload_queue
))
1947 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1948 tem
= Fmemq (feature
, Vfeatures
);
1950 Vfeatures
= Fcons (feature
, Vfeatures
);
1951 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1955 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1956 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1957 If FEATURE is not a member of the list `features', then the feature\n\
1958 is not loaded; so load the file FILENAME.\n\
1959 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1960 (feature
, file_name
)
1961 Lisp_Object feature
, file_name
;
1963 register Lisp_Object tem
;
1964 CHECK_SYMBOL (feature
, 0);
1965 tem
= Fmemq (feature
, Vfeatures
);
1966 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1969 int count
= specpdl_ptr
- specpdl
;
1971 /* Value saved here is to be restored into Vautoload_queue */
1972 record_unwind_protect (un_autoload
, Vautoload_queue
);
1973 Vautoload_queue
= Qt
;
1975 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1976 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
1978 tem
= Fmemq (feature
, Vfeatures
);
1980 error ("Required feature %s was not provided",
1981 XSYMBOL (feature
)->name
->data
);
1983 /* Once loading finishes, don't undo it. */
1984 Vautoload_queue
= Qt
;
1985 feature
= unbind_to (count
, feature
);
1992 Qstring_lessp
= intern ("string-lessp");
1993 staticpro (&Qstring_lessp
);
1994 Qprovide
= intern ("provide");
1995 staticpro (&Qprovide
);
1996 Qrequire
= intern ("require");
1997 staticpro (&Qrequire
);
1998 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1999 staticpro (&Qyes_or_no_p_history
);
2000 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2001 staticpro (&Qcursor_in_echo_area
);
2003 Fset (Qyes_or_no_p_history
, Qnil
);
2005 DEFVAR_LISP ("features", &Vfeatures
,
2006 "A list of symbols which are the features of the executing emacs.\n\
2007 Used by `featurep' and `require', and altered by `provide'.");
2010 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2011 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2012 This applies to y-or-n and yes-or-no questions asked by commands\n\
2013 invoked by mouse clicks and mouse menu items.");
2016 defsubr (&Sidentity
);
2019 defsubr (&Ssafe_length
);
2020 defsubr (&Sstring_equal
);
2021 defsubr (&Sstring_lessp
);
2024 defsubr (&Svconcat
);
2025 defsubr (&Scopy_sequence
);
2026 defsubr (&Scopy_alist
);
2027 defsubr (&Ssubstring
);
2039 defsubr (&Snreverse
);
2040 defsubr (&Sreverse
);
2042 defsubr (&Splist_get
);
2044 defsubr (&Splist_put
);
2047 defsubr (&Sfillarray
);
2048 defsubr (&Schar_table_subtype
);
2049 defsubr (&Schar_table_parent
);
2050 defsubr (&Sset_char_table_parent
);
2051 defsubr (&Schar_table_extra_slot
);
2052 defsubr (&Sset_char_table_extra_slot
);
2053 defsubr (&Schar_table_range
);
2054 defsubr (&Sset_char_table_range
);
2055 defsubr (&Sset_char_table_default
);
2056 defsubr (&Smap_char_table
);
2059 defsubr (&Smapconcat
);
2060 defsubr (&Sy_or_n_p
);
2061 defsubr (&Syes_or_no_p
);
2062 defsubr (&Sload_average
);
2063 defsubr (&Sfeaturep
);
2064 defsubr (&Srequire
);
2065 defsubr (&Sprovide
);