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
))
1162 #ifdef USE_TEXT_PROPERTIES
1163 /* If the strings have intervals, verify they match;
1164 if not, they are unequal. */
1165 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1166 && ! compare_string_intervals (o1
, o2
))
1174 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1175 "Store each element of ARRAY with ITEM.\n\
1176 ARRAY is a vector, string, char-table, or bool-vector.")
1178 Lisp_Object array
, item
;
1180 register int size
, index
, charval
;
1182 if (VECTORP (array
))
1184 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1185 size
= XVECTOR (array
)->size
;
1186 for (index
= 0; index
< size
; index
++)
1189 else if (CHAR_TABLE_P (array
))
1191 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1192 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1193 for (index
= 0; index
< size
; index
++)
1195 XCHAR_TABLE (array
)->defalt
= Qnil
;
1197 else if (STRINGP (array
))
1199 register unsigned char *p
= XSTRING (array
)->data
;
1200 CHECK_NUMBER (item
, 1);
1201 charval
= XINT (item
);
1202 size
= XSTRING (array
)->size
;
1203 for (index
= 0; index
< size
; index
++)
1206 else if (BOOL_VECTOR_P (array
))
1208 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1210 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1212 charval
= (! NILP (item
) ? -1 : 0);
1213 for (index
= 0; index
< size_in_chars
; index
++)
1218 array
= wrong_type_argument (Qarrayp
, array
);
1224 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1226 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1228 Lisp_Object char_table
;
1230 CHECK_CHAR_TABLE (char_table
, 0);
1232 return XCHAR_TABLE (char_table
)->purpose
;
1235 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1237 "Return the parent char-table of CHAR-TABLE.\n\
1238 The value is either nil or another char-table.\n\
1239 If CHAR-TABLE holds nil for a given character,\n\
1240 then the actual applicable value is inherited from the parent char-table\n\
1241 \(or from its parents, if necessary).")
1243 Lisp_Object char_table
;
1245 CHECK_CHAR_TABLE (char_table
, 0);
1247 return XCHAR_TABLE (char_table
)->parent
;
1250 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1252 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1253 PARENT must be either nil or another char-table.")
1254 (char_table
, parent
)
1255 Lisp_Object char_table
, parent
;
1259 CHECK_CHAR_TABLE (char_table
, 0);
1263 CHECK_CHAR_TABLE (parent
, 0);
1265 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1266 if (EQ (temp
, char_table
))
1267 error ("Attempt to make a chartable be its own parent");
1270 XCHAR_TABLE (char_table
)->parent
= parent
;
1275 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1277 "Return the value of CHAR-TABLE's extra-slot number N.")
1279 Lisp_Object char_table
, n
;
1281 CHECK_CHAR_TABLE (char_table
, 1);
1282 CHECK_NUMBER (n
, 2);
1284 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1285 args_out_of_range (char_table
, n
);
1287 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1290 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1291 Sset_char_table_extra_slot
,
1293 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1294 (char_table
, n
, value
)
1295 Lisp_Object char_table
, n
, value
;
1297 CHECK_CHAR_TABLE (char_table
, 1);
1298 CHECK_NUMBER (n
, 2);
1300 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1301 args_out_of_range (char_table
, n
);
1303 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1306 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1308 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1309 RANGE should be t (for all characters), nil (for the default value)\n\
1310 a vector which identifies a character set or a row of a character set,\n\
1311 or a character code.")
1313 Lisp_Object char_table
, range
;
1317 CHECK_CHAR_TABLE (char_table
, 0);
1319 if (EQ (range
, Qnil
))
1320 return XCHAR_TABLE (char_table
)->defalt
;
1321 else if (INTEGERP (range
))
1322 return Faref (char_table
, range
);
1323 else if (VECTORP (range
))
1325 int size
= XVECTOR (range
)->size
;
1326 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1327 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1328 size
<= 1 ? Qnil
: val
[1],
1329 size
<= 2 ? Qnil
: val
[2]);
1330 return Faref (char_table
, ch
);
1333 error ("Invalid RANGE argument to `char-table-range'");
1336 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1338 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1339 RANGE should be t (for all characters), nil (for the default value)\n\
1340 a vector which identifies a character set or a row of a character set,\n\
1341 or a character code.")
1342 (char_table
, range
, value
)
1343 Lisp_Object char_table
, range
, value
;
1347 CHECK_CHAR_TABLE (char_table
, 0);
1350 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1351 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1352 else if (EQ (range
, Qnil
))
1353 XCHAR_TABLE (char_table
)->defalt
= value
;
1354 else if (INTEGERP (range
))
1355 Faset (char_table
, range
, value
);
1356 else if (VECTORP (range
))
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 Faset (char_table
, ch
, value
);
1366 error ("Invalid RANGE argument to `set-char-table-range'");
1371 DEFUN ("set-char-table-default", Fset_char_table_default
,
1372 Sset_char_table_default
, 3, 3, 0,
1373 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1374 The generic character specifies the group of characters.\n\
1375 See also the documentation of make-char.")
1376 (char_table
, ch
, value
)
1377 Lisp_Object char_table
, ch
, value
;
1379 int c
, i
, charset
, code1
, code2
;
1382 CHECK_CHAR_TABLE (char_table
, 0);
1383 CHECK_NUMBER (ch
, 1);
1386 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1387 if (! CHARSET_DEFINED_P (charset
))
1388 error ("Invalid character: %d", c
);
1390 if (charset
== CHARSET_ASCII
)
1391 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1393 /* Even if C is not a generic char, we had better behave as if a
1394 generic char is specified. */
1395 if (CHARSET_DIMENSION (charset
) == 1)
1397 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1400 if (SUB_CHAR_TABLE_P (temp
))
1401 XCHAR_TABLE (temp
)->defalt
= value
;
1403 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1407 if (! SUB_CHAR_TABLE_P (char_table
))
1408 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1409 = make_sub_char_table (temp
));
1410 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1411 if (SUB_CHAR_TABLE_P (temp
))
1412 XCHAR_TABLE (temp
)->defalt
= value
;
1414 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1419 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1420 character or group of characters that share a value.
1421 DEPTH is the current depth in the originally specified
1422 chartable, and INDICES contains the vector indices
1423 for the levels our callers have descended.
1425 ARG is passed to C_FUNCTION when that is called. */
1428 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1429 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1436 /* At first, handle ASCII and 8-bit European characters. */
1437 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1439 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1441 (*c_function
) (arg
, make_number (i
), elt
);
1443 call2 (function
, make_number (i
), elt
);
1445 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1450 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1453 for (i
; i
< to
; i
++)
1455 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1459 if (SUB_CHAR_TABLE_P (elt
))
1462 error ("Too deep char table");
1463 map_char_table (c_function
, function
, elt
, arg
,
1464 depth
+ 1, indices
);
1468 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1470 if (CHARSET_DEFINED_P (charset
))
1472 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1473 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1474 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1476 (*c_function
) (arg
, make_number (c
), elt
);
1478 call2 (function
, make_number (c
), elt
);
1484 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1486 "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
1487 FUNCTION is called with two arguments--a key and a value.\n\
1488 The key is always a possible RANGE argument to `set-char-table-range'.")
1489 (function
, char_table
)
1490 Lisp_Object function
, char_table
;
1493 /* The depth of char table is at most 3. */
1494 Lisp_Object
*indices
= (Lisp_Object
*) alloca (3 * sizeof (Lisp_Object
));
1496 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1506 Lisp_Object args
[2];
1509 return Fnconc (2, args
);
1511 return Fnconc (2, &s1
);
1512 #endif /* NO_ARG_ARRAY */
1515 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1516 "Concatenate any number of lists by altering them.\n\
1517 Only the last argument is not altered, and need not be a list.")
1522 register int argnum
;
1523 register Lisp_Object tail
, tem
, val
;
1527 for (argnum
= 0; argnum
< nargs
; argnum
++)
1530 if (NILP (tem
)) continue;
1535 if (argnum
+ 1 == nargs
) break;
1538 tem
= wrong_type_argument (Qlistp
, tem
);
1547 tem
= args
[argnum
+ 1];
1548 Fsetcdr (tail
, tem
);
1550 args
[argnum
+ 1] = tail
;
1556 /* This is the guts of all mapping functions.
1557 Apply fn to each element of seq, one by one,
1558 storing the results into elements of vals, a C vector of Lisp_Objects.
1559 leni is the length of vals, which should also be the length of seq. */
1562 mapcar1 (leni
, vals
, fn
, seq
)
1565 Lisp_Object fn
, seq
;
1567 register Lisp_Object tail
;
1570 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1572 /* Don't let vals contain any garbage when GC happens. */
1573 for (i
= 0; i
< leni
; i
++)
1576 GCPRO3 (dummy
, fn
, seq
);
1578 gcpro1
.nvars
= leni
;
1579 /* We need not explicitly protect `tail' because it is used only on lists, and
1580 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1584 for (i
= 0; i
< leni
; i
++)
1586 dummy
= XVECTOR (seq
)->contents
[i
];
1587 vals
[i
] = call1 (fn
, dummy
);
1590 else if (STRINGP (seq
))
1592 for (i
= 0; i
< leni
; i
++)
1594 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1595 vals
[i
] = call1 (fn
, dummy
);
1598 else /* Must be a list, since Flength did not get an error */
1601 for (i
= 0; i
< leni
; i
++)
1603 vals
[i
] = call1 (fn
, Fcar (tail
));
1611 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1612 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1613 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1614 SEPARATOR results in spaces between the values returned by FUNCTION.")
1615 (function
, sequence
, separator
)
1616 Lisp_Object function
, sequence
, separator
;
1621 register Lisp_Object
*args
;
1623 struct gcpro gcpro1
;
1625 len
= Flength (sequence
);
1627 nargs
= leni
+ leni
- 1;
1628 if (nargs
< 0) return build_string ("");
1630 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1633 mapcar1 (leni
, args
, function
, sequence
);
1636 for (i
= leni
- 1; i
>= 0; i
--)
1637 args
[i
+ i
] = args
[i
];
1639 for (i
= 1; i
< nargs
; i
+= 2)
1640 args
[i
] = separator
;
1642 return Fconcat (nargs
, args
);
1645 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1646 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1647 The result is a list just as long as SEQUENCE.\n\
1648 SEQUENCE may be a list, a vector or a string.")
1649 (function
, sequence
)
1650 Lisp_Object function
, sequence
;
1652 register Lisp_Object len
;
1654 register Lisp_Object
*args
;
1656 len
= Flength (sequence
);
1657 leni
= XFASTINT (len
);
1658 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1660 mapcar1 (leni
, args
, function
, sequence
);
1662 return Flist (leni
, args
);
1665 /* Anything that calls this function must protect from GC! */
1667 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1668 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1669 Takes one argument, which is the string to display to ask the question.\n\
1670 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1671 No confirmation of the answer is requested; a single character is enough.\n\
1672 Also accepts Space to mean yes, or Delete to mean no.")
1676 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1677 register int answer
;
1678 Lisp_Object xprompt
;
1679 Lisp_Object args
[2];
1680 struct gcpro gcpro1
, gcpro2
;
1681 int count
= specpdl_ptr
- specpdl
;
1683 specbind (Qcursor_in_echo_area
, Qt
);
1685 map
= Fsymbol_value (intern ("query-replace-map"));
1687 CHECK_STRING (prompt
, 0);
1689 GCPRO2 (prompt
, xprompt
);
1696 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1699 Lisp_Object pane
, menu
;
1700 redisplay_preserve_echo_area ();
1701 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1702 Fcons (Fcons (build_string ("No"), Qnil
),
1704 menu
= Fcons (prompt
, pane
);
1705 obj
= Fx_popup_dialog (Qt
, menu
);
1706 answer
= !NILP (obj
);
1709 #endif /* HAVE_MENUS */
1710 cursor_in_echo_area
= 1;
1711 choose_minibuf_frame ();
1712 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1714 if (minibuffer_auto_raise
)
1716 Lisp_Object mini_frame
;
1718 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1720 Fraise_frame (mini_frame
);
1723 obj
= read_filtered_event (1, 0, 0);
1724 cursor_in_echo_area
= 0;
1725 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1728 key
= Fmake_vector (make_number (1), obj
);
1729 def
= Flookup_key (map
, key
, Qt
);
1730 answer_string
= Fsingle_key_description (obj
);
1732 if (EQ (def
, intern ("skip")))
1737 else if (EQ (def
, intern ("act")))
1742 else if (EQ (def
, intern ("recenter")))
1748 else if (EQ (def
, intern ("quit")))
1750 /* We want to exit this command for exit-prefix,
1751 and this is the only way to do it. */
1752 else if (EQ (def
, intern ("exit-prefix")))
1757 /* If we don't clear this, then the next call to read_char will
1758 return quit_char again, and we'll enter an infinite loop. */
1763 if (EQ (xprompt
, prompt
))
1765 args
[0] = build_string ("Please answer y or n. ");
1767 xprompt
= Fconcat (2, args
);
1772 if (! noninteractive
)
1774 cursor_in_echo_area
= -1;
1775 message_nolog ("%s(y or n) %c",
1776 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1779 unbind_to (count
, Qnil
);
1780 return answer
? Qt
: Qnil
;
1783 /* This is how C code calls `yes-or-no-p' and allows the user
1786 Anything that calls this function must protect from GC! */
1789 do_yes_or_no_p (prompt
)
1792 return call1 (intern ("yes-or-no-p"), prompt
);
1795 /* Anything that calls this function must protect from GC! */
1797 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1798 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1799 Takes one argument, which is the string to display to ask the question.\n\
1800 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1801 The user must confirm the answer with RET,\n\
1802 and can edit it until it has been confirmed.")
1806 register Lisp_Object ans
;
1807 Lisp_Object args
[2];
1808 struct gcpro gcpro1
;
1811 CHECK_STRING (prompt
, 0);
1814 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1817 Lisp_Object pane
, menu
, obj
;
1818 redisplay_preserve_echo_area ();
1819 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1820 Fcons (Fcons (build_string ("No"), Qnil
),
1823 menu
= Fcons (prompt
, pane
);
1824 obj
= Fx_popup_dialog (Qt
, menu
);
1828 #endif /* HAVE_MENUS */
1831 args
[1] = build_string ("(yes or no) ");
1832 prompt
= Fconcat (2, args
);
1838 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1839 Qyes_or_no_p_history
, Qnil
));
1840 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1845 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1853 message ("Please answer yes or no.");
1854 Fsleep_for (make_number (2), Qnil
);
1858 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1859 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1860 Each of the three load averages is multiplied by 100,\n\
1861 then converted to integer.\n\
1862 If the 5-minute or 15-minute load averages are not available, return a\n\
1863 shortened list, containing only those averages which are available.")
1867 int loads
= getloadavg (load_ave
, 3);
1871 error ("load-average not implemented for this operating system");
1875 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1880 Lisp_Object Vfeatures
;
1882 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1883 "Returns t if FEATURE is present in this Emacs.\n\
1884 Use this to conditionalize execution of lisp code based on the presence or\n\
1885 absence of emacs or environment extensions.\n\
1886 Use `provide' to declare that a feature is available.\n\
1887 This function looks at the value of the variable `features'.")
1889 Lisp_Object feature
;
1891 register Lisp_Object tem
;
1892 CHECK_SYMBOL (feature
, 0);
1893 tem
= Fmemq (feature
, Vfeatures
);
1894 return (NILP (tem
)) ? Qnil
: Qt
;
1897 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1898 "Announce that FEATURE is a feature of the current Emacs.")
1900 Lisp_Object feature
;
1902 register Lisp_Object tem
;
1903 CHECK_SYMBOL (feature
, 0);
1904 if (!NILP (Vautoload_queue
))
1905 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1906 tem
= Fmemq (feature
, Vfeatures
);
1908 Vfeatures
= Fcons (feature
, Vfeatures
);
1909 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1913 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1914 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1915 If FEATURE is not a member of the list `features', then the feature\n\
1916 is not loaded; so load the file FILENAME.\n\
1917 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1918 (feature
, file_name
)
1919 Lisp_Object feature
, file_name
;
1921 register Lisp_Object tem
;
1922 CHECK_SYMBOL (feature
, 0);
1923 tem
= Fmemq (feature
, Vfeatures
);
1924 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1927 int count
= specpdl_ptr
- specpdl
;
1929 /* Value saved here is to be restored into Vautoload_queue */
1930 record_unwind_protect (un_autoload
, Vautoload_queue
);
1931 Vautoload_queue
= Qt
;
1933 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1936 tem
= Fmemq (feature
, Vfeatures
);
1938 error ("Required feature %s was not provided",
1939 XSYMBOL (feature
)->name
->data
);
1941 /* Once loading finishes, don't undo it. */
1942 Vautoload_queue
= Qt
;
1943 feature
= unbind_to (count
, feature
);
1950 Qstring_lessp
= intern ("string-lessp");
1951 staticpro (&Qstring_lessp
);
1952 Qprovide
= intern ("provide");
1953 staticpro (&Qprovide
);
1954 Qrequire
= intern ("require");
1955 staticpro (&Qrequire
);
1956 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1957 staticpro (&Qyes_or_no_p_history
);
1958 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1959 staticpro (&Qcursor_in_echo_area
);
1961 Fset (Qyes_or_no_p_history
, Qnil
);
1963 DEFVAR_LISP ("features", &Vfeatures
,
1964 "A list of symbols which are the features of the executing emacs.\n\
1965 Used by `featurep' and `require', and altered by `provide'.");
1968 defsubr (&Sidentity
);
1971 defsubr (&Ssafe_length
);
1972 defsubr (&Sstring_equal
);
1973 defsubr (&Sstring_lessp
);
1976 defsubr (&Svconcat
);
1977 defsubr (&Scopy_sequence
);
1978 defsubr (&Scopy_alist
);
1979 defsubr (&Ssubstring
);
1991 defsubr (&Snreverse
);
1992 defsubr (&Sreverse
);
1994 defsubr (&Splist_get
);
1996 defsubr (&Splist_put
);
1999 defsubr (&Sfillarray
);
2000 defsubr (&Schar_table_subtype
);
2001 defsubr (&Schar_table_parent
);
2002 defsubr (&Sset_char_table_parent
);
2003 defsubr (&Schar_table_extra_slot
);
2004 defsubr (&Sset_char_table_extra_slot
);
2005 defsubr (&Schar_table_range
);
2006 defsubr (&Sset_char_table_range
);
2007 defsubr (&Sset_char_table_default
);
2008 defsubr (&Smap_char_table
);
2011 defsubr (&Smapconcat
);
2012 defsubr (&Sy_or_n_p
);
2013 defsubr (&Syes_or_no_p
);
2014 defsubr (&Sload_average
);
2015 defsubr (&Sfeaturep
);
2016 defsubr (&Srequire
);
2017 defsubr (&Sprovide
);