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
)
301 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
304 /* Copy all the contents. */
305 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
306 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
307 /* Recursively copy any sub char-tables in the ordinary slots. */
308 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
309 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
310 XCHAR_TABLE (copy
)->contents
[i
]
311 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
317 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
318 "Return a copy of a list, vector or string.\n\
319 The elements of a list or vector are not copied; they are shared\n\
324 if (NILP (arg
)) return arg
;
326 if (CHAR_TABLE_P (arg
))
331 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
332 /* Copy all the slots, including the extra ones. */
333 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
334 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
335 * sizeof (Lisp_Object
)));
337 /* Recursively copy any sub char tables in the ordinary slots
338 for multibyte characters. */
339 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
340 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
341 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
342 XCHAR_TABLE (copy
)->contents
[i
]
343 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
348 if (BOOL_VECTOR_P (arg
))
352 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
354 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
355 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
360 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
361 arg
= wrong_type_argument (Qsequencep
, arg
);
362 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
366 concat (nargs
, args
, target_type
, last_special
)
369 enum Lisp_Type target_type
;
374 register Lisp_Object tail
;
375 register Lisp_Object
this;
379 Lisp_Object last_tail
;
382 /* In append, the last arg isn't treated like the others */
383 if (last_special
&& nargs
> 0)
386 last_tail
= args
[nargs
];
391 for (argnum
= 0; argnum
< nargs
; argnum
++)
394 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
395 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
398 args
[argnum
] = Fnumber_to_string (this);
400 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
404 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
407 len
= Flength (this);
408 leni
+= XFASTINT (len
);
411 XSETFASTINT (len
, leni
);
413 if (target_type
== Lisp_Cons
)
414 val
= Fmake_list (len
, Qnil
);
415 else if (target_type
== Lisp_Vectorlike
)
416 val
= Fmake_vector (len
, Qnil
);
418 val
= Fmake_string (len
, len
);
420 /* In append, if all but last arg are nil, return last arg */
421 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
425 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
431 for (argnum
= 0; argnum
< nargs
; argnum
++)
435 register unsigned int thisindex
= 0;
439 thislen
= Flength (this), thisleni
= XINT (thislen
);
441 if (STRINGP (this) && STRINGP (val
)
442 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
444 copy_text_properties (make_number (0), thislen
, this,
445 make_number (toindex
), val
, Qnil
);
450 register Lisp_Object elt
;
452 /* Fetch next element of `this' arg into `elt', or break if
453 `this' is exhausted. */
454 if (NILP (this)) break;
456 elt
= Fcar (this), this = Fcdr (this);
459 if (thisindex
>= thisleni
) break;
461 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
462 else if (BOOL_VECTOR_P (this))
465 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
468 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
469 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
475 elt
= XVECTOR (this)->contents
[thisindex
++];
478 /* Store into result */
481 XCONS (tail
)->car
= elt
;
483 tail
= XCONS (tail
)->cdr
;
485 else if (VECTORP (val
))
486 XVECTOR (val
)->contents
[toindex
++] = elt
;
489 while (!INTEGERP (elt
))
490 elt
= wrong_type_argument (Qintegerp
, elt
);
492 #ifdef MASSC_REGISTER_BUG
493 /* Even removing all "register"s doesn't disable this bug!
494 Nothing simpler than this seems to work. */
495 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
498 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
505 XCONS (prev
)->cdr
= last_tail
;
510 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
511 "Return a copy of ALIST.\n\
512 This is an alist which represents the same mapping from objects to objects,\n\
513 but does not share the alist structure with ALIST.\n\
514 The objects mapped (cars and cdrs of elements of the alist)\n\
515 are shared, however.\n\
516 Elements of ALIST that are not conses are also shared.")
520 register Lisp_Object tem
;
522 CHECK_LIST (alist
, 0);
525 alist
= concat (1, &alist
, Lisp_Cons
, 0);
526 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
528 register Lisp_Object car
;
529 car
= XCONS (tem
)->car
;
532 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
537 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
538 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
539 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
540 If FROM or TO is negative, it counts from the end.\n\
542 This function allows vectors as well as strings.")
545 register Lisp_Object from
, to
;
550 if (! (STRINGP (string
) || VECTORP (string
)))
551 wrong_type_argument (Qarrayp
, string
);
553 CHECK_NUMBER (from
, 1);
555 if (STRINGP (string
))
556 size
= XSTRING (string
)->size
;
558 size
= XVECTOR (string
)->size
;
563 CHECK_NUMBER (to
, 2);
566 XSETINT (from
, XINT (from
) + size
);
568 XSETINT (to
, XINT (to
) + size
);
569 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
570 && XINT (to
) <= size
))
571 args_out_of_range_3 (string
, from
, to
);
573 if (STRINGP (string
))
575 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
576 XINT (to
) - XINT (from
));
577 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
580 res
= Fvector (XINT (to
) - XINT (from
),
581 XVECTOR (string
)->contents
+ XINT (from
));
586 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
587 "Take cdr N times on LIST, returns the result.")
590 register Lisp_Object list
;
595 for (i
= 0; i
< num
&& !NILP (list
); i
++)
603 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
604 "Return the Nth element of LIST.\n\
605 N counts from zero. If LIST is not that long, nil is returned.")
609 return Fcar (Fnthcdr (n
, list
));
612 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
613 "Return element of SEQUENCE at index N.")
615 register Lisp_Object sequence
, n
;
620 if (CONSP (sequence
) || NILP (sequence
))
621 return Fcar (Fnthcdr (n
, sequence
));
622 else if (STRINGP (sequence
) || VECTORP (sequence
)
623 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
624 return Faref (sequence
, n
);
626 sequence
= wrong_type_argument (Qsequencep
, sequence
);
630 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
631 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
632 The value is actually the tail of LIST whose car is ELT.")
634 register Lisp_Object elt
;
637 register Lisp_Object tail
;
638 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
640 register Lisp_Object tem
;
642 if (! NILP (Fequal (elt
, tem
)))
649 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
650 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
651 The value is actually the tail of LIST whose car is ELT.")
653 register Lisp_Object elt
;
656 register Lisp_Object tail
;
657 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
659 register Lisp_Object tem
;
661 if (EQ (elt
, tem
)) return tail
;
667 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
668 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
669 The value is actually the element of LIST whose car is KEY.\n\
670 Elements of LIST that are not conses are ignored.")
672 register Lisp_Object key
;
675 register Lisp_Object tail
;
676 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
678 register Lisp_Object elt
, tem
;
680 if (!CONSP (elt
)) continue;
682 if (EQ (key
, tem
)) return elt
;
688 /* Like Fassq but never report an error and do not allow quits.
689 Use only on lists known never to be circular. */
692 assq_no_quit (key
, list
)
693 register Lisp_Object key
;
696 register Lisp_Object tail
;
697 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
699 register Lisp_Object elt
, tem
;
701 if (!CONSP (elt
)) continue;
703 if (EQ (key
, tem
)) return elt
;
708 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
709 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
710 The value is actually the element of LIST whose car equals KEY.")
712 register Lisp_Object key
;
715 register Lisp_Object tail
;
716 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
718 register Lisp_Object elt
, tem
;
720 if (!CONSP (elt
)) continue;
721 tem
= Fequal (Fcar (elt
), key
);
722 if (!NILP (tem
)) return elt
;
728 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
729 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
730 The value is actually the element of LIST whose cdr is ELT.")
732 register Lisp_Object key
;
735 register Lisp_Object tail
;
736 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
738 register Lisp_Object elt
, tem
;
740 if (!CONSP (elt
)) continue;
742 if (EQ (key
, tem
)) return elt
;
748 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
749 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
750 The value is actually the element of LIST whose cdr equals KEY.")
752 register Lisp_Object key
;
755 register Lisp_Object tail
;
756 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
758 register Lisp_Object elt
, tem
;
760 if (!CONSP (elt
)) continue;
761 tem
= Fequal (Fcdr (elt
), key
);
762 if (!NILP (tem
)) return elt
;
768 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
769 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
770 The modified LIST is returned. Comparison is done with `eq'.\n\
771 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
772 therefore, write `(setq foo (delq element foo))'\n\
773 to be sure of changing the value of `foo'.")
775 register Lisp_Object elt
;
778 register Lisp_Object tail
, prev
;
779 register Lisp_Object tem
;
791 Fsetcdr (prev
, Fcdr (tail
));
801 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
802 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
803 The modified LIST is returned. Comparison is done with `equal'.\n\
804 If the first member of LIST is ELT, deleting it is not a side effect;\n\
805 it is simply using a different list.\n\
806 Therefore, write `(setq foo (delete element foo))'\n\
807 to be sure of changing the value of `foo'.")
809 register Lisp_Object elt
;
812 register Lisp_Object tail
, prev
;
813 register Lisp_Object tem
;
820 if (! NILP (Fequal (elt
, tem
)))
825 Fsetcdr (prev
, Fcdr (tail
));
835 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
836 "Reverse LIST by modifying cdr pointers.\n\
837 Returns the beginning of the reversed list.")
841 register Lisp_Object prev
, tail
, next
;
843 if (NILP (list
)) return list
;
850 Fsetcdr (tail
, prev
);
857 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
858 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
859 See also the function `nreverse', which is used more often.")
864 register Lisp_Object
*vec
;
865 register Lisp_Object tail
;
868 length
= Flength (list
);
869 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
870 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
871 vec
[i
] = Fcar (tail
);
873 return Flist (XINT (length
), vec
);
876 Lisp_Object
merge ();
878 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
879 "Sort LIST, stably, comparing elements using PREDICATE.\n\
880 Returns the sorted list. LIST is modified by side effects.\n\
881 PREDICATE is called with two elements of LIST, and should return T\n\
882 if the first element is \"less\" than the second.")
884 Lisp_Object list
, predicate
;
886 Lisp_Object front
, back
;
887 register Lisp_Object len
, tem
;
888 struct gcpro gcpro1
, gcpro2
;
892 len
= Flength (list
);
897 XSETINT (len
, (length
/ 2) - 1);
898 tem
= Fnthcdr (len
, list
);
902 GCPRO2 (front
, back
);
903 front
= Fsort (front
, predicate
);
904 back
= Fsort (back
, predicate
);
906 return merge (front
, back
, predicate
);
910 merge (org_l1
, org_l2
, pred
)
911 Lisp_Object org_l1
, org_l2
;
915 register Lisp_Object tail
;
917 register Lisp_Object l1
, l2
;
918 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
925 /* It is sufficient to protect org_l1 and org_l2.
926 When l1 and l2 are updated, we copy the new values
927 back into the org_ vars. */
928 GCPRO4 (org_l1
, org_l2
, pred
, value
);
948 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
970 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
971 "Extract a value from a property list.\n\
972 PLIST is a property list, which is a list of the form\n\
973 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
974 corresponding to the given PROP, or nil if PROP is not\n\
975 one of the properties on the list.")
978 register Lisp_Object prop
;
980 register Lisp_Object tail
;
981 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
983 register Lisp_Object tem
;
986 return Fcar (Fcdr (tail
));
991 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
992 "Return the value of SYMBOL's PROPNAME property.\n\
993 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
995 Lisp_Object symbol
, propname
;
997 CHECK_SYMBOL (symbol
, 0);
998 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1001 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1002 "Change value in PLIST of PROP to VAL.\n\
1003 PLIST is a property list, which is a list of the form\n\
1004 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1005 If PROP is already a property on the list, its value is set to VAL,\n\
1006 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1007 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1008 The PLIST is modified by side effects.")
1011 register Lisp_Object prop
;
1014 register Lisp_Object tail
, prev
;
1015 Lisp_Object newcell
;
1017 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1018 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1020 if (EQ (prop
, XCONS (tail
)->car
))
1022 Fsetcar (XCONS (tail
)->cdr
, val
);
1027 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1031 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1035 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1036 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1037 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1038 (symbol
, propname
, value
)
1039 Lisp_Object symbol
, propname
, value
;
1041 CHECK_SYMBOL (symbol
, 0);
1042 XSYMBOL (symbol
)->plist
1043 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1047 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1048 "T if two Lisp objects have similar structure and contents.\n\
1049 They must have the same data type.\n\
1050 Conses are compared by comparing the cars and the cdrs.\n\
1051 Vectors and strings are compared element by element.\n\
1052 Numbers are compared by value, but integers cannot equal floats.\n\
1053 (Use `=' if you want integers and floats to be able to be equal.)\n\
1054 Symbols must match exactly.")
1056 register Lisp_Object o1
, o2
;
1058 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1062 internal_equal (o1
, o2
, depth
)
1063 register Lisp_Object o1
, o2
;
1067 error ("Stack overflow in equal");
1073 if (XTYPE (o1
) != XTYPE (o2
))
1078 #ifdef LISP_FLOAT_TYPE
1080 return (extract_float (o1
) == extract_float (o2
));
1084 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1086 o1
= XCONS (o1
)->cdr
;
1087 o2
= XCONS (o2
)->cdr
;
1091 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1095 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1097 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1100 o1
= XOVERLAY (o1
)->plist
;
1101 o2
= XOVERLAY (o2
)->plist
;
1106 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1107 && (XMARKER (o1
)->buffer
== 0
1108 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1112 case Lisp_Vectorlike
:
1114 register int i
, size
;
1115 size
= XVECTOR (o1
)->size
;
1116 /* Pseudovectors have the type encoded in the size field, so this test
1117 actually checks that the objects have the same type as well as the
1119 if (XVECTOR (o2
)->size
!= size
)
1121 /* Boolvectors are compared much like strings. */
1122 if (BOOL_VECTOR_P (o1
))
1125 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1127 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1129 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1135 /* Aside from them, only true vectors, char-tables, and compiled
1136 functions are sensible to compare, so eliminate the others now. */
1137 if (size
& PSEUDOVECTOR_FLAG
)
1139 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1141 size
&= PSEUDOVECTOR_SIZE_MASK
;
1143 for (i
= 0; i
< size
; i
++)
1146 v1
= XVECTOR (o1
)->contents
[i
];
1147 v2
= XVECTOR (o2
)->contents
[i
];
1148 if (!internal_equal (v1
, v2
, depth
+ 1))
1156 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1158 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1159 XSTRING (o1
)->size
))
1161 #ifdef USE_TEXT_PROPERTIES
1162 /* If the strings have intervals, verify they match;
1163 if not, they are unequal. */
1164 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1165 && ! compare_string_intervals (o1
, o2
))
1173 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1174 "Store each element of ARRAY with ITEM.\n\
1175 ARRAY is a vector, string, char-table, or bool-vector.")
1177 Lisp_Object array
, item
;
1179 register int size
, index
, charval
;
1181 if (VECTORP (array
))
1183 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1184 size
= XVECTOR (array
)->size
;
1185 for (index
= 0; index
< size
; index
++)
1188 else if (CHAR_TABLE_P (array
))
1190 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1191 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1192 for (index
= 0; index
< size
; index
++)
1194 XCHAR_TABLE (array
)->defalt
= Qnil
;
1196 else if (STRINGP (array
))
1198 register unsigned char *p
= XSTRING (array
)->data
;
1199 CHECK_NUMBER (item
, 1);
1200 charval
= XINT (item
);
1201 size
= XSTRING (array
)->size
;
1202 for (index
= 0; index
< size
; index
++)
1205 else if (BOOL_VECTOR_P (array
))
1207 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1209 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1211 charval
= (! NILP (item
) ? -1 : 0);
1212 for (index
= 0; index
< size_in_chars
; index
++)
1217 array
= wrong_type_argument (Qarrayp
, array
);
1223 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1225 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1227 Lisp_Object char_table
;
1229 CHECK_CHAR_TABLE (char_table
, 0);
1231 return XCHAR_TABLE (char_table
)->purpose
;
1234 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1236 "Return the parent char-table of CHAR-TABLE.\n\
1237 The value is either nil or another char-table.\n\
1238 If CHAR-TABLE holds nil for a given character,\n\
1239 then the actual applicable value is inherited from the parent char-table\n\
1240 \(or from its parents, if necessary).")
1242 Lisp_Object char_table
;
1244 CHECK_CHAR_TABLE (char_table
, 0);
1246 return XCHAR_TABLE (char_table
)->parent
;
1249 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1251 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1252 PARENT must be either nil or another char-table.")
1253 (char_table
, parent
)
1254 Lisp_Object char_table
, parent
;
1258 CHECK_CHAR_TABLE (char_table
, 0);
1262 CHECK_CHAR_TABLE (parent
, 0);
1264 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1265 if (EQ (temp
, char_table
))
1266 error ("Attempt to make a chartable be its own parent");
1269 XCHAR_TABLE (char_table
)->parent
= parent
;
1274 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1276 "Return the value of CHAR-TABLE's extra-slot number N.")
1278 Lisp_Object char_table
, n
;
1280 CHECK_CHAR_TABLE (char_table
, 1);
1281 CHECK_NUMBER (n
, 2);
1283 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1284 args_out_of_range (char_table
, n
);
1286 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1289 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1290 Sset_char_table_extra_slot
,
1292 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1293 (char_table
, n
, value
)
1294 Lisp_Object char_table
, n
, value
;
1296 CHECK_CHAR_TABLE (char_table
, 1);
1297 CHECK_NUMBER (n
, 2);
1299 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1300 args_out_of_range (char_table
, n
);
1302 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1305 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1307 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1308 RANGE should be t (for all characters), nil (for the default value)\n\
1309 a vector which identifies a character set or a row of a character set,\n\
1310 or a character code.")
1312 Lisp_Object char_table
, range
;
1316 CHECK_CHAR_TABLE (char_table
, 0);
1318 if (EQ (range
, Qnil
))
1319 return XCHAR_TABLE (char_table
)->defalt
;
1320 else if (INTEGERP (range
))
1321 return Faref (char_table
, range
);
1322 else if (VECTORP (range
))
1324 int size
= XVECTOR (range
)->size
;
1325 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1326 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1327 size
<= 1 ? Qnil
: val
[1],
1328 size
<= 2 ? Qnil
: val
[2]);
1329 return Faref (char_table
, ch
);
1332 error ("Invalid RANGE argument to `char-table-range'");
1335 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1337 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\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.")
1341 (char_table
, range
, value
)
1342 Lisp_Object char_table
, range
, value
;
1346 CHECK_CHAR_TABLE (char_table
, 0);
1349 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1350 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1351 else if (EQ (range
, Qnil
))
1352 XCHAR_TABLE (char_table
)->defalt
= value
;
1353 else if (INTEGERP (range
))
1354 Faset (char_table
, range
, value
);
1355 else if (VECTORP (range
))
1357 int size
= XVECTOR (range
)->size
;
1358 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1359 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1360 size
<= 1 ? Qnil
: val
[1],
1361 size
<= 2 ? Qnil
: val
[2]);
1362 return Faset (char_table
, ch
, value
);
1365 error ("Invalid RANGE argument to `set-char-table-range'");
1370 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1371 character or group of characters that share a value.
1372 DEPTH is the current depth in the originally specified
1373 chartable, and INDICES contains the vector indices
1374 for the levels our callers have descended.
1376 ARG is passed to C_FUNCTION when that is called. */
1379 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1380 Lisp_Object (*c_function
) (), function
, subtable
, arg
, *indices
;
1387 /* At first, handle ASCII and 8-bit European characters. */
1388 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1390 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1392 (*c_function
) (arg
, make_number (i
), elt
);
1394 call2 (function
, make_number (i
), elt
);
1396 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1401 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1404 for (i
; i
< to
; i
++)
1406 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1410 if (SUB_CHAR_TABLE_P (elt
))
1413 error ("Too deep char table");
1414 map_char_table (c_function
, function
, elt
, arg
,
1415 depth
+ 1, indices
);
1419 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1421 if (CHARSET_DEFINED_P (charset
))
1423 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1424 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1425 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1427 (*c_function
) (arg
, make_number (c
), elt
);
1429 call2 (function
, make_number (c
), elt
);
1435 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1437 "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
1438 FUNCTION is called with two arguments--a key and a value.\n\
1439 The key is always a possible RANGE argument to `set-char-table-range'.")
1440 (function
, char_table
)
1441 Lisp_Object function
, char_table
;
1444 /* The depth of char table is at most 3. */
1445 Lisp_Object
*indices
= (Lisp_Object
*) alloca (3 * sizeof (Lisp_Object
));
1447 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1457 Lisp_Object args
[2];
1460 return Fnconc (2, args
);
1462 return Fnconc (2, &s1
);
1463 #endif /* NO_ARG_ARRAY */
1466 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1467 "Concatenate any number of lists by altering them.\n\
1468 Only the last argument is not altered, and need not be a list.")
1473 register int argnum
;
1474 register Lisp_Object tail
, tem
, val
;
1478 for (argnum
= 0; argnum
< nargs
; argnum
++)
1481 if (NILP (tem
)) continue;
1486 if (argnum
+ 1 == nargs
) break;
1489 tem
= wrong_type_argument (Qlistp
, tem
);
1498 tem
= args
[argnum
+ 1];
1499 Fsetcdr (tail
, tem
);
1501 args
[argnum
+ 1] = tail
;
1507 /* This is the guts of all mapping functions.
1508 Apply fn to each element of seq, one by one,
1509 storing the results into elements of vals, a C vector of Lisp_Objects.
1510 leni is the length of vals, which should also be the length of seq. */
1513 mapcar1 (leni
, vals
, fn
, seq
)
1516 Lisp_Object fn
, seq
;
1518 register Lisp_Object tail
;
1521 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1523 /* Don't let vals contain any garbage when GC happens. */
1524 for (i
= 0; i
< leni
; i
++)
1527 GCPRO3 (dummy
, fn
, seq
);
1529 gcpro1
.nvars
= leni
;
1530 /* We need not explicitly protect `tail' because it is used only on lists, and
1531 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1535 for (i
= 0; i
< leni
; i
++)
1537 dummy
= XVECTOR (seq
)->contents
[i
];
1538 vals
[i
] = call1 (fn
, dummy
);
1541 else if (STRINGP (seq
))
1543 for (i
= 0; i
< leni
; i
++)
1545 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1546 vals
[i
] = call1 (fn
, dummy
);
1549 else /* Must be a list, since Flength did not get an error */
1552 for (i
= 0; i
< leni
; i
++)
1554 vals
[i
] = call1 (fn
, Fcar (tail
));
1562 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1563 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1564 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1565 SEPARATOR results in spaces between the values returned by FUNCTION.")
1566 (function
, sequence
, separator
)
1567 Lisp_Object function
, sequence
, separator
;
1572 register Lisp_Object
*args
;
1574 struct gcpro gcpro1
;
1576 len
= Flength (sequence
);
1578 nargs
= leni
+ leni
- 1;
1579 if (nargs
< 0) return build_string ("");
1581 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1584 mapcar1 (leni
, args
, function
, sequence
);
1587 for (i
= leni
- 1; i
>= 0; i
--)
1588 args
[i
+ i
] = args
[i
];
1590 for (i
= 1; i
< nargs
; i
+= 2)
1591 args
[i
] = separator
;
1593 return Fconcat (nargs
, args
);
1596 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1597 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1598 The result is a list just as long as SEQUENCE.\n\
1599 SEQUENCE may be a list, a vector or a string.")
1600 (function
, sequence
)
1601 Lisp_Object function
, sequence
;
1603 register Lisp_Object len
;
1605 register Lisp_Object
*args
;
1607 len
= Flength (sequence
);
1608 leni
= XFASTINT (len
);
1609 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1611 mapcar1 (leni
, args
, function
, sequence
);
1613 return Flist (leni
, args
);
1616 /* Anything that calls this function must protect from GC! */
1618 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1619 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1620 Takes one argument, which is the string to display to ask the question.\n\
1621 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1622 No confirmation of the answer is requested; a single character is enough.\n\
1623 Also accepts Space to mean yes, or Delete to mean no.")
1627 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1628 register int answer
;
1629 Lisp_Object xprompt
;
1630 Lisp_Object args
[2];
1631 struct gcpro gcpro1
, gcpro2
;
1632 int count
= specpdl_ptr
- specpdl
;
1634 specbind (Qcursor_in_echo_area
, Qt
);
1636 map
= Fsymbol_value (intern ("query-replace-map"));
1638 CHECK_STRING (prompt
, 0);
1640 GCPRO2 (prompt
, xprompt
);
1647 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1650 Lisp_Object pane
, menu
;
1651 redisplay_preserve_echo_area ();
1652 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1653 Fcons (Fcons (build_string ("No"), Qnil
),
1655 menu
= Fcons (prompt
, pane
);
1656 obj
= Fx_popup_dialog (Qt
, menu
);
1657 answer
= !NILP (obj
);
1660 #endif /* HAVE_MENUS */
1661 cursor_in_echo_area
= 1;
1662 choose_minibuf_frame ();
1663 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1665 if (minibuffer_auto_raise
)
1667 Lisp_Object mini_frame
;
1669 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1671 Fraise_frame (mini_frame
);
1674 obj
= read_filtered_event (1, 0, 0);
1675 cursor_in_echo_area
= 0;
1676 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1679 key
= Fmake_vector (make_number (1), obj
);
1680 def
= Flookup_key (map
, key
, Qt
);
1681 answer_string
= Fsingle_key_description (obj
);
1683 if (EQ (def
, intern ("skip")))
1688 else if (EQ (def
, intern ("act")))
1693 else if (EQ (def
, intern ("recenter")))
1699 else if (EQ (def
, intern ("quit")))
1701 /* We want to exit this command for exit-prefix,
1702 and this is the only way to do it. */
1703 else if (EQ (def
, intern ("exit-prefix")))
1708 /* If we don't clear this, then the next call to read_char will
1709 return quit_char again, and we'll enter an infinite loop. */
1714 if (EQ (xprompt
, prompt
))
1716 args
[0] = build_string ("Please answer y or n. ");
1718 xprompt
= Fconcat (2, args
);
1723 if (! noninteractive
)
1725 cursor_in_echo_area
= -1;
1726 message_nolog ("%s(y or n) %c",
1727 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1730 unbind_to (count
, Qnil
);
1731 return answer
? Qt
: Qnil
;
1734 /* This is how C code calls `yes-or-no-p' and allows the user
1737 Anything that calls this function must protect from GC! */
1740 do_yes_or_no_p (prompt
)
1743 return call1 (intern ("yes-or-no-p"), prompt
);
1746 /* Anything that calls this function must protect from GC! */
1748 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1749 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1750 Takes one argument, which is the string to display to ask the question.\n\
1751 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1752 The user must confirm the answer with RET,\n\
1753 and can edit it until it has been confirmed.")
1757 register Lisp_Object ans
;
1758 Lisp_Object args
[2];
1759 struct gcpro gcpro1
;
1762 CHECK_STRING (prompt
, 0);
1765 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1768 Lisp_Object pane
, menu
, obj
;
1769 redisplay_preserve_echo_area ();
1770 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1771 Fcons (Fcons (build_string ("No"), Qnil
),
1774 menu
= Fcons (prompt
, pane
);
1775 obj
= Fx_popup_dialog (Qt
, menu
);
1779 #endif /* HAVE_MENUS */
1782 args
[1] = build_string ("(yes or no) ");
1783 prompt
= Fconcat (2, args
);
1789 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1790 Qyes_or_no_p_history
, Qnil
));
1791 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1796 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1804 message ("Please answer yes or no.");
1805 Fsleep_for (make_number (2), Qnil
);
1809 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1810 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1811 Each of the three load averages is multiplied by 100,\n\
1812 then converted to integer.\n\
1813 If the 5-minute or 15-minute load averages are not available, return a\n\
1814 shortened list, containing only those averages which are available.")
1818 int loads
= getloadavg (load_ave
, 3);
1822 error ("load-average not implemented for this operating system");
1826 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1831 Lisp_Object Vfeatures
;
1833 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1834 "Returns t if FEATURE is present in this Emacs.\n\
1835 Use this to conditionalize execution of lisp code based on the presence or\n\
1836 absence of emacs or environment extensions.\n\
1837 Use `provide' to declare that a feature is available.\n\
1838 This function looks at the value of the variable `features'.")
1840 Lisp_Object feature
;
1842 register Lisp_Object tem
;
1843 CHECK_SYMBOL (feature
, 0);
1844 tem
= Fmemq (feature
, Vfeatures
);
1845 return (NILP (tem
)) ? Qnil
: Qt
;
1848 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1849 "Announce that FEATURE is a feature of the current Emacs.")
1851 Lisp_Object feature
;
1853 register Lisp_Object tem
;
1854 CHECK_SYMBOL (feature
, 0);
1855 if (!NILP (Vautoload_queue
))
1856 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1857 tem
= Fmemq (feature
, Vfeatures
);
1859 Vfeatures
= Fcons (feature
, Vfeatures
);
1860 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1864 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1865 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1866 If FEATURE is not a member of the list `features', then the feature\n\
1867 is not loaded; so load the file FILENAME.\n\
1868 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1869 (feature
, file_name
)
1870 Lisp_Object feature
, file_name
;
1872 register Lisp_Object tem
;
1873 CHECK_SYMBOL (feature
, 0);
1874 tem
= Fmemq (feature
, Vfeatures
);
1875 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1878 int count
= specpdl_ptr
- specpdl
;
1880 /* Value saved here is to be restored into Vautoload_queue */
1881 record_unwind_protect (un_autoload
, Vautoload_queue
);
1882 Vautoload_queue
= Qt
;
1884 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1887 tem
= Fmemq (feature
, Vfeatures
);
1889 error ("Required feature %s was not provided",
1890 XSYMBOL (feature
)->name
->data
);
1892 /* Once loading finishes, don't undo it. */
1893 Vautoload_queue
= Qt
;
1894 feature
= unbind_to (count
, feature
);
1901 Qstring_lessp
= intern ("string-lessp");
1902 staticpro (&Qstring_lessp
);
1903 Qprovide
= intern ("provide");
1904 staticpro (&Qprovide
);
1905 Qrequire
= intern ("require");
1906 staticpro (&Qrequire
);
1907 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1908 staticpro (&Qyes_or_no_p_history
);
1909 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1910 staticpro (&Qcursor_in_echo_area
);
1912 Fset (Qyes_or_no_p_history
, Qnil
);
1914 DEFVAR_LISP ("features", &Vfeatures
,
1915 "A list of symbols which are the features of the executing emacs.\n\
1916 Used by `featurep' and `require', and altered by `provide'.");
1919 defsubr (&Sidentity
);
1922 defsubr (&Ssafe_length
);
1923 defsubr (&Sstring_equal
);
1924 defsubr (&Sstring_lessp
);
1927 defsubr (&Svconcat
);
1928 defsubr (&Scopy_sequence
);
1929 defsubr (&Scopy_alist
);
1930 defsubr (&Ssubstring
);
1942 defsubr (&Snreverse
);
1943 defsubr (&Sreverse
);
1945 defsubr (&Splist_get
);
1947 defsubr (&Splist_put
);
1950 defsubr (&Sfillarray
);
1951 defsubr (&Schar_table_subtype
);
1952 defsubr (&Schar_table_parent
);
1953 defsubr (&Sset_char_table_parent
);
1954 defsubr (&Schar_table_extra_slot
);
1955 defsubr (&Sset_char_table_extra_slot
);
1956 defsubr (&Schar_table_range
);
1957 defsubr (&Sset_char_table_range
);
1958 defsubr (&Smap_char_table
);
1961 defsubr (&Smapconcat
);
1962 defsubr (&Sy_or_n_p
);
1963 defsubr (&Syes_or_no_p
);
1964 defsubr (&Sload_average
);
1965 defsubr (&Sfeaturep
);
1966 defsubr (&Srequire
);
1967 defsubr (&Sprovide
);