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 extern Lisp_Object
Flookup_key ();
45 extern int minibuffer_auto_raise
;
46 extern Lisp_Object minibuf_window
;
48 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
49 Lisp_Object Qyes_or_no_p_history
;
50 Lisp_Object Qcursor_in_echo_area
;
52 static int internal_equal ();
54 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
55 "Return the argument unchanged.")
62 extern long get_random ();
63 extern void seed_random ();
66 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
67 "Return a pseudo-random number.\n\
68 All integers representable in Lisp are equally likely.\n\
69 On most systems, this is 28 bits' worth.\n\
70 With positive integer argument N, return random number in interval [0,N).\n\
71 With argument t, set the random number seed from the current time and pid.")
76 Lisp_Object lispy_val
;
77 unsigned long denominator
;
80 seed_random (getpid () + time (NULL
));
81 if (NATNUMP (n
) && XFASTINT (n
) != 0)
83 /* Try to take our random number from the higher bits of VAL,
84 not the lower, since (says Gentzel) the low bits of `random'
85 are less random than the higher ones. We do this by using the
86 quotient rather than the remainder. At the high end of the RNG
87 it's possible to get a quotient larger than n; discarding
88 these values eliminates the bias that would otherwise appear
89 when using a large n. */
90 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
92 val
= get_random () / denominator
;
93 while (val
>= XFASTINT (n
));
97 XSETINT (lispy_val
, val
);
101 /* Random data-structure functions */
103 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
104 "Return the length of vector, list or string SEQUENCE.\n\
105 A byte-code function object is also allowed.")
107 register Lisp_Object sequence
;
109 register Lisp_Object tail
, val
;
113 if (STRINGP (sequence
))
114 XSETFASTINT (val
, XSTRING (sequence
)->size
);
115 else if (VECTORP (sequence
))
116 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
117 else if (CHAR_TABLE_P (sequence
))
118 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
119 else if (BOOL_VECTOR_P (sequence
))
120 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
121 else if (COMPILEDP (sequence
))
122 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
123 else if (CONSP (sequence
))
125 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
131 XSETFASTINT (val
, i
);
133 else if (NILP (sequence
))
134 XSETFASTINT (val
, 0);
137 sequence
= wrong_type_argument (Qsequencep
, sequence
);
143 /* This does not check for quits. That is safe
144 since it must terminate. */
146 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
147 "Return the length of a list, but avoid error or infinite loop.\n\
148 This function never gets an error. If LIST is not really a list,\n\
149 it returns 0. If LIST is circular, it returns a finite value\n\
150 which is at least the number of distinct elements.")
154 Lisp_Object tail
, halftail
, length
;
157 /* halftail is used to detect circular lists. */
159 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
161 if (EQ (tail
, halftail
) && len
!= 0)
165 halftail
= XCONS (halftail
)->cdr
;
168 XSETINT (length
, len
);
172 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
173 "T if two strings have identical contents.\n\
174 Case is significant, but text properties are ignored.\n\
175 Symbols are also allowed; their print names are used instead.")
177 register Lisp_Object s1
, s2
;
180 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
182 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
183 CHECK_STRING (s1
, 0);
184 CHECK_STRING (s2
, 1);
186 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
187 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
192 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
193 "T if first arg string is less than second in lexicographic order.\n\
194 Case is significant.\n\
195 Symbols are also allowed; their print names are used instead.")
197 register Lisp_Object s1
, s2
;
200 register unsigned char *p1
, *p2
;
204 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
206 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
207 CHECK_STRING (s1
, 0);
208 CHECK_STRING (s2
, 1);
210 p1
= XSTRING (s1
)->data
;
211 p2
= XSTRING (s2
)->data
;
212 end
= XSTRING (s1
)->size
;
213 if (end
> XSTRING (s2
)->size
)
214 end
= XSTRING (s2
)->size
;
216 for (i
= 0; i
< end
; i
++)
219 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
221 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
224 static Lisp_Object
concat ();
235 return concat (2, args
, Lisp_String
, 0);
237 return concat (2, &s1
, Lisp_String
, 0);
238 #endif /* NO_ARG_ARRAY */
244 Lisp_Object s1
, s2
, s3
;
251 return concat (3, args
, Lisp_String
, 0);
253 return concat (3, &s1
, Lisp_String
, 0);
254 #endif /* NO_ARG_ARRAY */
257 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
258 "Concatenate all the arguments and make the result a list.\n\
259 The result is a list whose elements are the elements of all the arguments.\n\
260 Each argument may be a list, vector or string.\n\
261 The last argument is not copied, just used as the tail of the new list.")
266 return concat (nargs
, args
, Lisp_Cons
, 1);
269 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
270 "Concatenate all the arguments and make the result a string.\n\
271 The result is a string whose elements are the elements of all the arguments.\n\
272 Each argument may be a string or a list or vector of characters (integers).\n\
274 Do not use individual integers as arguments!\n\
275 The behavior of `concat' in that case will be changed later!\n\
276 If your program passes an integer as an argument to `concat',\n\
277 you should change it right away not to do so.")
282 return concat (nargs
, args
, Lisp_String
, 0);
285 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
286 "Concatenate all the arguments and make the result a vector.\n\
287 The result is a vector whose elements are the elements of all the arguments.\n\
288 Each argument may be a list, vector or string.")
293 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
296 /* Retrun a copy of a sub char table ARG. The elements except for a
297 nested sub char table are not copied. */
299 copy_sub_char_table (arg
)
302 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
305 /* Copy all the contents. */
306 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
307 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
308 /* Recursively copy any sub char-tables in the ordinary slots. */
309 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
310 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
311 XCHAR_TABLE (copy
)->contents
[i
]
312 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
318 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
319 "Return a copy of a list, vector or string.\n\
320 The elements of a list or vector are not copied; they are shared\n\
325 if (NILP (arg
)) return arg
;
327 if (CHAR_TABLE_P (arg
))
332 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
333 /* Copy all the slots, including the extra ones. */
334 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
335 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
336 * sizeof (Lisp_Object
)));
338 /* Recursively copy any sub char tables in the ordinary slots
339 for multibyte characters. */
340 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
341 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
342 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
343 XCHAR_TABLE (copy
)->contents
[i
]
344 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
349 if (BOOL_VECTOR_P (arg
))
353 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
355 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
356 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
361 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
362 arg
= wrong_type_argument (Qsequencep
, arg
);
363 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
367 concat (nargs
, args
, target_type
, last_special
)
370 enum Lisp_Type target_type
;
375 register Lisp_Object tail
;
376 register Lisp_Object
this;
380 Lisp_Object last_tail
;
383 /* In append, the last arg isn't treated like the others */
384 if (last_special
&& nargs
> 0)
387 last_tail
= args
[nargs
];
392 for (argnum
= 0; argnum
< nargs
; argnum
++)
395 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
396 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
399 args
[argnum
] = Fnumber_to_string (this);
401 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
405 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
408 len
= Flength (this);
409 leni
+= XFASTINT (len
);
412 XSETFASTINT (len
, leni
);
414 if (target_type
== Lisp_Cons
)
415 val
= Fmake_list (len
, Qnil
);
416 else if (target_type
== Lisp_Vectorlike
)
417 val
= Fmake_vector (len
, Qnil
);
419 val
= Fmake_string (len
, len
);
421 /* In append, if all but last arg are nil, return last arg */
422 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
426 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
432 for (argnum
= 0; argnum
< nargs
; argnum
++)
436 register unsigned int thisindex
= 0;
440 thislen
= Flength (this), thisleni
= XINT (thislen
);
442 if (STRINGP (this) && STRINGP (val
)
443 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
445 copy_text_properties (make_number (0), thislen
, this,
446 make_number (toindex
), val
, Qnil
);
451 register Lisp_Object elt
;
453 /* Fetch next element of `this' arg into `elt', or break if
454 `this' is exhausted. */
455 if (NILP (this)) break;
457 elt
= Fcar (this), this = Fcdr (this);
460 if (thisindex
>= thisleni
) break;
462 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
463 else if (BOOL_VECTOR_P (this))
466 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
469 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
470 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
476 elt
= XVECTOR (this)->contents
[thisindex
++];
479 /* Store into result */
482 XCONS (tail
)->car
= elt
;
484 tail
= XCONS (tail
)->cdr
;
486 else if (VECTORP (val
))
487 XVECTOR (val
)->contents
[toindex
++] = elt
;
490 while (!INTEGERP (elt
))
491 elt
= wrong_type_argument (Qintegerp
, elt
);
493 #ifdef MASSC_REGISTER_BUG
494 /* Even removing all "register"s doesn't disable this bug!
495 Nothing simpler than this seems to work. */
496 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
499 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
506 XCONS (prev
)->cdr
= last_tail
;
511 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
512 "Return a copy of ALIST.\n\
513 This is an alist which represents the same mapping from objects to objects,\n\
514 but does not share the alist structure with ALIST.\n\
515 The objects mapped (cars and cdrs of elements of the alist)\n\
516 are shared, however.\n\
517 Elements of ALIST that are not conses are also shared.")
521 register Lisp_Object tem
;
523 CHECK_LIST (alist
, 0);
526 alist
= concat (1, &alist
, Lisp_Cons
, 0);
527 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
529 register Lisp_Object car
;
530 car
= XCONS (tem
)->car
;
533 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
538 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
539 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
540 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
541 If FROM or TO is negative, it counts from the end.\n\
543 This function allows vectors as well as strings.")
546 register Lisp_Object from
, to
;
551 if (! (STRINGP (string
) || VECTORP (string
)))
552 wrong_type_argument (Qarrayp
, string
);
554 CHECK_NUMBER (from
, 1);
556 if (STRINGP (string
))
557 size
= XSTRING (string
)->size
;
559 size
= XVECTOR (string
)->size
;
564 CHECK_NUMBER (to
, 2);
567 XSETINT (from
, XINT (from
) + size
);
569 XSETINT (to
, XINT (to
) + size
);
570 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
571 && XINT (to
) <= size
))
572 args_out_of_range_3 (string
, from
, to
);
574 if (STRINGP (string
))
576 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
577 XINT (to
) - XINT (from
));
578 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
581 res
= Fvector (XINT (to
) - XINT (from
),
582 XVECTOR (string
)->contents
+ XINT (from
));
587 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
588 "Take cdr N times on LIST, returns the result.")
591 register Lisp_Object list
;
596 for (i
= 0; i
< num
&& !NILP (list
); i
++)
604 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
605 "Return the Nth element of LIST.\n\
606 N counts from zero. If LIST is not that long, nil is returned.")
610 return Fcar (Fnthcdr (n
, list
));
613 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
614 "Return element of SEQUENCE at index N.")
616 register Lisp_Object sequence
, n
;
621 if (CONSP (sequence
) || NILP (sequence
))
622 return Fcar (Fnthcdr (n
, sequence
));
623 else if (STRINGP (sequence
) || VECTORP (sequence
)
624 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
625 return Faref (sequence
, n
);
627 sequence
= wrong_type_argument (Qsequencep
, sequence
);
631 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
632 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
633 The value is actually the tail of LIST whose car is ELT.")
635 register Lisp_Object elt
;
638 register Lisp_Object tail
;
639 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
641 register Lisp_Object tem
;
643 if (! NILP (Fequal (elt
, tem
)))
650 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
651 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
652 The value is actually the tail of LIST whose car is ELT.")
654 register Lisp_Object elt
;
657 register Lisp_Object tail
;
658 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
660 register Lisp_Object tem
;
662 if (EQ (elt
, tem
)) return tail
;
668 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
669 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
670 The value is actually the element of LIST whose car is KEY.\n\
671 Elements of LIST that are not conses are ignored.")
673 register Lisp_Object key
;
676 register Lisp_Object tail
;
677 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
679 register Lisp_Object elt
, tem
;
681 if (!CONSP (elt
)) continue;
683 if (EQ (key
, tem
)) return elt
;
689 /* Like Fassq but never report an error and do not allow quits.
690 Use only on lists known never to be circular. */
693 assq_no_quit (key
, list
)
694 register Lisp_Object key
;
697 register Lisp_Object tail
;
698 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
700 register Lisp_Object elt
, tem
;
702 if (!CONSP (elt
)) continue;
704 if (EQ (key
, tem
)) return elt
;
709 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
710 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
711 The value is actually the element of LIST whose car equals KEY.")
713 register Lisp_Object key
;
716 register Lisp_Object tail
;
717 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
719 register Lisp_Object elt
, tem
;
721 if (!CONSP (elt
)) continue;
722 tem
= Fequal (Fcar (elt
), key
);
723 if (!NILP (tem
)) return elt
;
729 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
730 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
731 The value is actually the element of LIST whose cdr is ELT.")
733 register Lisp_Object key
;
736 register Lisp_Object tail
;
737 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
739 register Lisp_Object elt
, tem
;
741 if (!CONSP (elt
)) continue;
743 if (EQ (key
, tem
)) return elt
;
749 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
750 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
751 The value is actually the element of LIST whose cdr equals KEY.")
753 register Lisp_Object key
;
756 register Lisp_Object tail
;
757 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
759 register Lisp_Object elt
, tem
;
761 if (!CONSP (elt
)) continue;
762 tem
= Fequal (Fcdr (elt
), key
);
763 if (!NILP (tem
)) return elt
;
769 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
770 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
771 The modified LIST is returned. Comparison is done with `eq'.\n\
772 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
773 therefore, write `(setq foo (delq element foo))'\n\
774 to be sure of changing the value of `foo'.")
776 register Lisp_Object elt
;
779 register Lisp_Object tail
, prev
;
780 register Lisp_Object tem
;
792 Fsetcdr (prev
, Fcdr (tail
));
802 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
803 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
804 The modified LIST is returned. Comparison is done with `equal'.\n\
805 If the first member of LIST is ELT, deleting it is not a side effect;\n\
806 it is simply using a different list.\n\
807 Therefore, write `(setq foo (delete element foo))'\n\
808 to be sure of changing the value of `foo'.")
810 register Lisp_Object elt
;
813 register Lisp_Object tail
, prev
;
814 register Lisp_Object tem
;
821 if (! NILP (Fequal (elt
, tem
)))
826 Fsetcdr (prev
, Fcdr (tail
));
836 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
837 "Reverse LIST by modifying cdr pointers.\n\
838 Returns the beginning of the reversed list.")
842 register Lisp_Object prev
, tail
, next
;
844 if (NILP (list
)) return list
;
851 Fsetcdr (tail
, prev
);
858 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
859 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
860 See also the function `nreverse', which is used more often.")
865 register Lisp_Object
*vec
;
866 register Lisp_Object tail
;
869 length
= Flength (list
);
870 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
871 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
872 vec
[i
] = Fcar (tail
);
874 return Flist (XINT (length
), vec
);
877 Lisp_Object
merge ();
879 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
880 "Sort LIST, stably, comparing elements using PREDICATE.\n\
881 Returns the sorted list. LIST is modified by side effects.\n\
882 PREDICATE is called with two elements of LIST, and should return T\n\
883 if the first element is \"less\" than the second.")
885 Lisp_Object list
, predicate
;
887 Lisp_Object front
, back
;
888 register Lisp_Object len
, tem
;
889 struct gcpro gcpro1
, gcpro2
;
893 len
= Flength (list
);
898 XSETINT (len
, (length
/ 2) - 1);
899 tem
= Fnthcdr (len
, list
);
903 GCPRO2 (front
, back
);
904 front
= Fsort (front
, predicate
);
905 back
= Fsort (back
, predicate
);
907 return merge (front
, back
, predicate
);
911 merge (org_l1
, org_l2
, pred
)
912 Lisp_Object org_l1
, org_l2
;
916 register Lisp_Object tail
;
918 register Lisp_Object l1
, l2
;
919 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
926 /* It is sufficient to protect org_l1 and org_l2.
927 When l1 and l2 are updated, we copy the new values
928 back into the org_ vars. */
929 GCPRO4 (org_l1
, org_l2
, pred
, value
);
949 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
971 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
972 "Extract a value from a property list.\n\
973 PLIST is a property list, which is a list of the form\n\
974 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
975 corresponding to the given PROP, or nil if PROP is not\n\
976 one of the properties on the list.")
979 register Lisp_Object prop
;
981 register Lisp_Object tail
;
982 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
984 register Lisp_Object tem
;
987 return Fcar (Fcdr (tail
));
992 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
993 "Return the value of SYMBOL's PROPNAME property.\n\
994 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
996 Lisp_Object symbol
, propname
;
998 CHECK_SYMBOL (symbol
, 0);
999 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1002 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1003 "Change value in PLIST of PROP to VAL.\n\
1004 PLIST is a property list, which is a list of the form\n\
1005 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1006 If PROP is already a property on the list, its value is set to VAL,\n\
1007 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1008 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1009 The PLIST is modified by side effects.")
1012 register Lisp_Object prop
;
1015 register Lisp_Object tail
, prev
;
1016 Lisp_Object newcell
;
1018 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1019 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1021 if (EQ (prop
, XCONS (tail
)->car
))
1023 Fsetcar (XCONS (tail
)->cdr
, val
);
1028 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1032 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1036 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1037 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1038 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1039 (symbol
, propname
, value
)
1040 Lisp_Object symbol
, propname
, value
;
1042 CHECK_SYMBOL (symbol
, 0);
1043 XSYMBOL (symbol
)->plist
1044 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1048 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1049 "T if two Lisp objects have similar structure and contents.\n\
1050 They must have the same data type.\n\
1051 Conses are compared by comparing the cars and the cdrs.\n\
1052 Vectors and strings are compared element by element.\n\
1053 Numbers are compared by value, but integers cannot equal floats.\n\
1054 (Use `=' if you want integers and floats to be able to be equal.)\n\
1055 Symbols must match exactly.")
1057 register Lisp_Object o1
, o2
;
1059 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1063 internal_equal (o1
, o2
, depth
)
1064 register Lisp_Object o1
, o2
;
1068 error ("Stack overflow in equal");
1074 if (XTYPE (o1
) != XTYPE (o2
))
1079 #ifdef LISP_FLOAT_TYPE
1081 return (extract_float (o1
) == extract_float (o2
));
1085 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1087 o1
= XCONS (o1
)->cdr
;
1088 o2
= XCONS (o2
)->cdr
;
1092 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1096 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1098 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1101 o1
= XOVERLAY (o1
)->plist
;
1102 o2
= XOVERLAY (o2
)->plist
;
1107 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1108 && (XMARKER (o1
)->buffer
== 0
1109 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1113 case Lisp_Vectorlike
:
1115 register int i
, size
;
1116 size
= XVECTOR (o1
)->size
;
1117 /* Pseudovectors have the type encoded in the size field, so this test
1118 actually checks that the objects have the same type as well as the
1120 if (XVECTOR (o2
)->size
!= size
)
1122 /* Boolvectors are compared much like strings. */
1123 if (BOOL_VECTOR_P (o1
))
1126 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1128 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1130 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1136 /* Aside from them, only true vectors, char-tables, and compiled
1137 functions are sensible to compare, so eliminate the others now. */
1138 if (size
& PSEUDOVECTOR_FLAG
)
1140 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1142 size
&= PSEUDOVECTOR_SIZE_MASK
;
1144 for (i
= 0; i
< size
; i
++)
1147 v1
= XVECTOR (o1
)->contents
[i
];
1148 v2
= XVECTOR (o2
)->contents
[i
];
1149 if (!internal_equal (v1
, v2
, depth
+ 1))
1157 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1159 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1160 XSTRING (o1
)->size
))
1167 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1168 "Store each element of ARRAY with ITEM.\n\
1169 ARRAY is a vector, string, char-table, or bool-vector.")
1171 Lisp_Object array
, item
;
1173 register int size
, index
, charval
;
1175 if (VECTORP (array
))
1177 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1178 size
= XVECTOR (array
)->size
;
1179 for (index
= 0; index
< size
; index
++)
1182 else if (CHAR_TABLE_P (array
))
1184 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1185 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1186 for (index
= 0; index
< size
; index
++)
1188 XCHAR_TABLE (array
)->defalt
= Qnil
;
1190 else if (STRINGP (array
))
1192 register unsigned char *p
= XSTRING (array
)->data
;
1193 CHECK_NUMBER (item
, 1);
1194 charval
= XINT (item
);
1195 size
= XSTRING (array
)->size
;
1196 for (index
= 0; index
< size
; index
++)
1199 else if (BOOL_VECTOR_P (array
))
1201 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1203 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1205 charval
= (! NILP (item
) ? -1 : 0);
1206 for (index
= 0; index
< size_in_chars
; index
++)
1211 array
= wrong_type_argument (Qarrayp
, array
);
1217 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1219 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1221 Lisp_Object char_table
;
1223 CHECK_CHAR_TABLE (char_table
, 0);
1225 return XCHAR_TABLE (char_table
)->purpose
;
1228 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1230 "Return the parent char-table of CHAR-TABLE.\n\
1231 The value is either nil or another char-table.\n\
1232 If CHAR-TABLE holds nil for a given character,\n\
1233 then the actual applicable value is inherited from the parent char-table\n\
1234 \(or from its parents, if necessary).")
1236 Lisp_Object char_table
;
1238 CHECK_CHAR_TABLE (char_table
, 0);
1240 return XCHAR_TABLE (char_table
)->parent
;
1243 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1245 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1246 PARENT must be either nil or another char-table.")
1247 (char_table
, parent
)
1248 Lisp_Object char_table
, parent
;
1252 CHECK_CHAR_TABLE (char_table
, 0);
1256 CHECK_CHAR_TABLE (parent
, 0);
1258 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1259 if (EQ (temp
, char_table
))
1260 error ("Attempt to make a chartable be its own parent");
1263 XCHAR_TABLE (char_table
)->parent
= parent
;
1268 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1270 "Return the value of CHAR-TABLE's extra-slot number N.")
1272 Lisp_Object char_table
, n
;
1274 CHECK_CHAR_TABLE (char_table
, 1);
1275 CHECK_NUMBER (n
, 2);
1277 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1278 args_out_of_range (char_table
, n
);
1280 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1283 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1284 Sset_char_table_extra_slot
,
1286 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1287 (char_table
, n
, value
)
1288 Lisp_Object char_table
, n
, value
;
1290 CHECK_CHAR_TABLE (char_table
, 1);
1291 CHECK_NUMBER (n
, 2);
1293 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1294 args_out_of_range (char_table
, n
);
1296 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1299 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1301 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1302 RANGE should be t (for all characters), nil (for the default value)\n\
1303 a vector which identifies a character set or a row of a character set,\n\
1304 or a character code.")
1306 Lisp_Object char_table
, range
;
1310 CHECK_CHAR_TABLE (char_table
, 0);
1312 if (EQ (range
, Qnil
))
1313 return XCHAR_TABLE (char_table
)->defalt
;
1314 else if (INTEGERP (range
))
1315 return Faref (char_table
, range
);
1316 else if (VECTORP (range
))
1318 if (XVECTOR (range
)->size
== 1)
1319 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1322 int size
= XVECTOR (range
)->size
;
1323 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1324 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1325 size
<= 1 ? Qnil
: val
[1],
1326 size
<= 2 ? Qnil
: val
[2]);
1327 return Faref (char_table
, ch
);
1331 error ("Invalid RANGE argument to `char-table-range'");
1334 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1336 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1337 RANGE should be t (for all characters), nil (for the default value)\n\
1338 a vector which identifies a character set or a row of a character set,\n\
1339 or a character code.")
1340 (char_table
, range
, value
)
1341 Lisp_Object char_table
, range
, value
;
1345 CHECK_CHAR_TABLE (char_table
, 0);
1348 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1349 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1350 else if (EQ (range
, Qnil
))
1351 XCHAR_TABLE (char_table
)->defalt
= value
;
1352 else if (INTEGERP (range
))
1353 Faset (char_table
, range
, value
);
1354 else if (VECTORP (range
))
1356 if (XVECTOR (range
)->size
== 1)
1357 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1360 int size
= XVECTOR (range
)->size
;
1361 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1362 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1363 size
<= 1 ? Qnil
: val
[1],
1364 size
<= 2 ? Qnil
: val
[2]);
1365 return Faset (char_table
, ch
, value
);
1369 error ("Invalid RANGE argument to `set-char-table-range'");
1374 DEFUN ("set-char-table-default", Fset_char_table_default
,
1375 Sset_char_table_default
, 3, 3, 0,
1376 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1377 The generic character specifies the group of characters.\n\
1378 See also the documentation of make-char.")
1379 (char_table
, ch
, value
)
1380 Lisp_Object char_table
, ch
, value
;
1382 int c
, i
, charset
, code1
, code2
;
1385 CHECK_CHAR_TABLE (char_table
, 0);
1386 CHECK_NUMBER (ch
, 1);
1389 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1390 if (! CHARSET_DEFINED_P (charset
))
1391 error ("Invalid character: %d", c
);
1393 if (charset
== CHARSET_ASCII
)
1394 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1396 /* Even if C is not a generic char, we had better behave as if a
1397 generic char is specified. */
1398 if (CHARSET_DIMENSION (charset
) == 1)
1400 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1403 if (SUB_CHAR_TABLE_P (temp
))
1404 XCHAR_TABLE (temp
)->defalt
= value
;
1406 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1410 if (! SUB_CHAR_TABLE_P (char_table
))
1411 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1412 = make_sub_char_table (temp
));
1413 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1414 if (SUB_CHAR_TABLE_P (temp
))
1415 XCHAR_TABLE (temp
)->defalt
= value
;
1417 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1422 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1423 character or group of characters that share a value.
1424 DEPTH is the current depth in the originally specified
1425 chartable, and INDICES contains the vector indices
1426 for the levels our callers have descended.
1428 ARG is passed to C_FUNCTION when that is called. */
1431 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1432 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1439 /* At first, handle ASCII and 8-bit European characters. */
1440 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1442 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1444 (*c_function
) (arg
, make_number (i
), elt
);
1446 call2 (function
, make_number (i
), elt
);
1448 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1453 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1458 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1462 if (SUB_CHAR_TABLE_P (elt
))
1465 error ("Too deep char table");
1466 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1470 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1472 if (CHARSET_DEFINED_P (charset
))
1474 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1475 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1476 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1478 (*c_function
) (arg
, make_number (c
), elt
);
1480 call2 (function
, make_number (c
), elt
);
1486 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1488 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1489 FUNCTION is called with two arguments--a key and a value.\n\
1490 The key is always a possible IDX argument to `aref'.")
1491 (function
, char_table
)
1492 Lisp_Object function
, char_table
;
1494 /* The depth of char table is at most 3. */
1495 Lisp_Object indices
[3];
1497 CHECK_CHAR_TABLE (char_table
, 1);
1499 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1509 Lisp_Object args
[2];
1512 return Fnconc (2, args
);
1514 return Fnconc (2, &s1
);
1515 #endif /* NO_ARG_ARRAY */
1518 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1519 "Concatenate any number of lists by altering them.\n\
1520 Only the last argument is not altered, and need not be a list.")
1525 register int argnum
;
1526 register Lisp_Object tail
, tem
, val
;
1530 for (argnum
= 0; argnum
< nargs
; argnum
++)
1533 if (NILP (tem
)) continue;
1538 if (argnum
+ 1 == nargs
) break;
1541 tem
= wrong_type_argument (Qlistp
, tem
);
1550 tem
= args
[argnum
+ 1];
1551 Fsetcdr (tail
, tem
);
1553 args
[argnum
+ 1] = tail
;
1559 /* This is the guts of all mapping functions.
1560 Apply fn to each element of seq, one by one,
1561 storing the results into elements of vals, a C vector of Lisp_Objects.
1562 leni is the length of vals, which should also be the length of seq. */
1565 mapcar1 (leni
, vals
, fn
, seq
)
1568 Lisp_Object fn
, seq
;
1570 register Lisp_Object tail
;
1573 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1575 /* Don't let vals contain any garbage when GC happens. */
1576 for (i
= 0; i
< leni
; i
++)
1579 GCPRO3 (dummy
, fn
, seq
);
1581 gcpro1
.nvars
= leni
;
1582 /* We need not explicitly protect `tail' because it is used only on lists, and
1583 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1587 for (i
= 0; i
< leni
; i
++)
1589 dummy
= XVECTOR (seq
)->contents
[i
];
1590 vals
[i
] = call1 (fn
, dummy
);
1593 else if (STRINGP (seq
))
1595 for (i
= 0; i
< leni
; i
++)
1597 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1598 vals
[i
] = call1 (fn
, dummy
);
1601 else /* Must be a list, since Flength did not get an error */
1604 for (i
= 0; i
< leni
; i
++)
1606 vals
[i
] = call1 (fn
, Fcar (tail
));
1614 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1615 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1616 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1617 SEPARATOR results in spaces between the values returned by FUNCTION.")
1618 (function
, sequence
, separator
)
1619 Lisp_Object function
, sequence
, separator
;
1624 register Lisp_Object
*args
;
1626 struct gcpro gcpro1
;
1628 len
= Flength (sequence
);
1630 nargs
= leni
+ leni
- 1;
1631 if (nargs
< 0) return build_string ("");
1633 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1636 mapcar1 (leni
, args
, function
, sequence
);
1639 for (i
= leni
- 1; i
>= 0; i
--)
1640 args
[i
+ i
] = args
[i
];
1642 for (i
= 1; i
< nargs
; i
+= 2)
1643 args
[i
] = separator
;
1645 return Fconcat (nargs
, args
);
1648 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1649 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1650 The result is a list just as long as SEQUENCE.\n\
1651 SEQUENCE may be a list, a vector or a string.")
1652 (function
, sequence
)
1653 Lisp_Object function
, sequence
;
1655 register Lisp_Object len
;
1657 register Lisp_Object
*args
;
1659 len
= Flength (sequence
);
1660 leni
= XFASTINT (len
);
1661 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1663 mapcar1 (leni
, args
, function
, sequence
);
1665 return Flist (leni
, args
);
1668 /* Anything that calls this function must protect from GC! */
1670 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1671 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1672 Takes one argument, which is the string to display to ask the question.\n\
1673 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1674 No confirmation of the answer is requested; a single character is enough.\n\
1675 Also accepts Space to mean yes, or Delete to mean no.")
1679 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1680 register int answer
;
1681 Lisp_Object xprompt
;
1682 Lisp_Object args
[2];
1683 struct gcpro gcpro1
, gcpro2
;
1684 int count
= specpdl_ptr
- specpdl
;
1686 specbind (Qcursor_in_echo_area
, Qt
);
1688 map
= Fsymbol_value (intern ("query-replace-map"));
1690 CHECK_STRING (prompt
, 0);
1692 GCPRO2 (prompt
, xprompt
);
1699 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1702 Lisp_Object pane
, menu
;
1703 redisplay_preserve_echo_area ();
1704 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1705 Fcons (Fcons (build_string ("No"), Qnil
),
1707 menu
= Fcons (prompt
, pane
);
1708 obj
= Fx_popup_dialog (Qt
, menu
);
1709 answer
= !NILP (obj
);
1712 #endif /* HAVE_MENUS */
1713 cursor_in_echo_area
= 1;
1714 choose_minibuf_frame ();
1715 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1717 if (minibuffer_auto_raise
)
1719 Lisp_Object mini_frame
;
1721 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1723 Fraise_frame (mini_frame
);
1726 obj
= read_filtered_event (1, 0, 0);
1727 cursor_in_echo_area
= 0;
1728 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1731 key
= Fmake_vector (make_number (1), obj
);
1732 def
= Flookup_key (map
, key
, Qt
);
1733 answer_string
= Fsingle_key_description (obj
);
1735 if (EQ (def
, intern ("skip")))
1740 else if (EQ (def
, intern ("act")))
1745 else if (EQ (def
, intern ("recenter")))
1751 else if (EQ (def
, intern ("quit")))
1753 /* We want to exit this command for exit-prefix,
1754 and this is the only way to do it. */
1755 else if (EQ (def
, intern ("exit-prefix")))
1760 /* If we don't clear this, then the next call to read_char will
1761 return quit_char again, and we'll enter an infinite loop. */
1766 if (EQ (xprompt
, prompt
))
1768 args
[0] = build_string ("Please answer y or n. ");
1770 xprompt
= Fconcat (2, args
);
1775 if (! noninteractive
)
1777 cursor_in_echo_area
= -1;
1778 message_nolog ("%s(y or n) %c",
1779 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1782 unbind_to (count
, Qnil
);
1783 return answer
? Qt
: Qnil
;
1786 /* This is how C code calls `yes-or-no-p' and allows the user
1789 Anything that calls this function must protect from GC! */
1792 do_yes_or_no_p (prompt
)
1795 return call1 (intern ("yes-or-no-p"), prompt
);
1798 /* Anything that calls this function must protect from GC! */
1800 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1801 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1802 Takes one argument, which is the string to display to ask the question.\n\
1803 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1804 The user must confirm the answer with RET,\n\
1805 and can edit it until it has been confirmed.")
1809 register Lisp_Object ans
;
1810 Lisp_Object args
[2];
1811 struct gcpro gcpro1
;
1814 CHECK_STRING (prompt
, 0);
1817 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1820 Lisp_Object pane
, menu
, obj
;
1821 redisplay_preserve_echo_area ();
1822 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1823 Fcons (Fcons (build_string ("No"), Qnil
),
1826 menu
= Fcons (prompt
, pane
);
1827 obj
= Fx_popup_dialog (Qt
, menu
);
1831 #endif /* HAVE_MENUS */
1834 args
[1] = build_string ("(yes or no) ");
1835 prompt
= Fconcat (2, args
);
1841 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1842 Qyes_or_no_p_history
, Qnil
));
1843 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1848 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1856 message ("Please answer yes or no.");
1857 Fsleep_for (make_number (2), Qnil
);
1861 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1862 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1863 Each of the three load averages is multiplied by 100,\n\
1864 then converted to integer.\n\
1865 If the 5-minute or 15-minute load averages are not available, return a\n\
1866 shortened list, containing only those averages which are available.")
1870 int loads
= getloadavg (load_ave
, 3);
1874 error ("load-average not implemented for this operating system");
1878 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1883 Lisp_Object Vfeatures
;
1885 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1886 "Returns t if FEATURE is present in this Emacs.\n\
1887 Use this to conditionalize execution of lisp code based on the presence or\n\
1888 absence of emacs or environment extensions.\n\
1889 Use `provide' to declare that a feature is available.\n\
1890 This function looks at the value of the variable `features'.")
1892 Lisp_Object feature
;
1894 register Lisp_Object tem
;
1895 CHECK_SYMBOL (feature
, 0);
1896 tem
= Fmemq (feature
, Vfeatures
);
1897 return (NILP (tem
)) ? Qnil
: Qt
;
1900 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1901 "Announce that FEATURE is a feature of the current Emacs.")
1903 Lisp_Object feature
;
1905 register Lisp_Object tem
;
1906 CHECK_SYMBOL (feature
, 0);
1907 if (!NILP (Vautoload_queue
))
1908 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1909 tem
= Fmemq (feature
, Vfeatures
);
1911 Vfeatures
= Fcons (feature
, Vfeatures
);
1912 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1916 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1917 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1918 If FEATURE is not a member of the list `features', then the feature\n\
1919 is not loaded; so load the file FILENAME.\n\
1920 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1921 (feature
, file_name
)
1922 Lisp_Object feature
, file_name
;
1924 register Lisp_Object tem
;
1925 CHECK_SYMBOL (feature
, 0);
1926 tem
= Fmemq (feature
, Vfeatures
);
1927 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1930 int count
= specpdl_ptr
- specpdl
;
1932 /* Value saved here is to be restored into Vautoload_queue */
1933 record_unwind_protect (un_autoload
, Vautoload_queue
);
1934 Vautoload_queue
= Qt
;
1936 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1939 tem
= Fmemq (feature
, Vfeatures
);
1941 error ("Required feature %s was not provided",
1942 XSYMBOL (feature
)->name
->data
);
1944 /* Once loading finishes, don't undo it. */
1945 Vautoload_queue
= Qt
;
1946 feature
= unbind_to (count
, feature
);
1953 Qstring_lessp
= intern ("string-lessp");
1954 staticpro (&Qstring_lessp
);
1955 Qprovide
= intern ("provide");
1956 staticpro (&Qprovide
);
1957 Qrequire
= intern ("require");
1958 staticpro (&Qrequire
);
1959 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1960 staticpro (&Qyes_or_no_p_history
);
1961 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1962 staticpro (&Qcursor_in_echo_area
);
1964 Fset (Qyes_or_no_p_history
, Qnil
);
1966 DEFVAR_LISP ("features", &Vfeatures
,
1967 "A list of symbols which are the features of the executing emacs.\n\
1968 Used by `featurep' and `require', and altered by `provide'.");
1971 defsubr (&Sidentity
);
1974 defsubr (&Ssafe_length
);
1975 defsubr (&Sstring_equal
);
1976 defsubr (&Sstring_lessp
);
1979 defsubr (&Svconcat
);
1980 defsubr (&Scopy_sequence
);
1981 defsubr (&Scopy_alist
);
1982 defsubr (&Ssubstring
);
1994 defsubr (&Snreverse
);
1995 defsubr (&Sreverse
);
1997 defsubr (&Splist_get
);
1999 defsubr (&Splist_put
);
2002 defsubr (&Sfillarray
);
2003 defsubr (&Schar_table_subtype
);
2004 defsubr (&Schar_table_parent
);
2005 defsubr (&Sset_char_table_parent
);
2006 defsubr (&Schar_table_extra_slot
);
2007 defsubr (&Sset_char_table_extra_slot
);
2008 defsubr (&Schar_table_range
);
2009 defsubr (&Sset_char_table_range
);
2010 defsubr (&Sset_char_table_default
);
2011 defsubr (&Smap_char_table
);
2014 defsubr (&Smapconcat
);
2015 defsubr (&Sy_or_n_p
);
2016 defsubr (&Syes_or_no_p
);
2017 defsubr (&Sload_average
);
2018 defsubr (&Sfeaturep
);
2019 defsubr (&Srequire
);
2020 defsubr (&Sprovide
);